# # ---------------------------------------------------------------------- # # TODO: roundOutToX has a bug. It does not round to 0 when it should # # ---------------------------------------------------------------------- # # x <- seq(-2, 2, by=.01) # tbl <- table(roundOutToX(x, .2)) # tbl[as.numeric(names(tbl)) %in% c(-.2, 0, .2)] # tbl # notice that there is no `0` value in table # # ---------------------------------------------------------------------- # # # ---------------------------------------------------------------------- # # EDITED BUT NOT MOVED UP HERE: # # mkdsh, mbench, areEqual, areEqual.slow # # # ---------------------------------------------------------------------- # ## 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() } date.mmddyyyy.regex <- "(0[1-9]|1[012])[- /.](0[1-9]|[12][0-9]|3[01])[- /.](19|20)\\d\\d" cleanWS <- function(x) { ## Cleans multiple whitespaces to a single whitespaces, and trims whitespace from edge gsub("^\\s+|\\s+$", "", gsub(" +", " ", x) ) } 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) } msgBox <- function(..., sep="", col="\n", collapse=col, shiftLeft=0, prelines=1 , pad=8, dash="-", pound="") { msg <- paste(c(...), sep=sep, collapse=collapse) msg <- center(msg, pad=pad) msg <- mkdsh(msg, dash=dash, pound=pound, leftSpace=FALSE, toptoo=TRUE , dontCopy=TRUE, dontCollapse=TRUE, dontTrim=TRUE) lft <- pasteR(" ", shiftLeft) msg <- paste0(lft, unlist(strsplit(msg,"\n")), collapse="\n" ) cls(prelines) cat(msg, sep="\n") } 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))) ) } g_legend<-function(a.gplot){ # by: Jase_ on StackOverflow.com # from: http://stackoverflow.com/a/12539820/1492421 require(gridExtra) tmp <- ggplot_gtable(ggplot_build(a.gplot)) leg <- which(sapply(tmp$grobs, function(x) x$name) == "guide-box") legend <- tmp$grobs[[leg]] legend } 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) }) } removeNA <-function(x, replace=NULL) { # quick wrapper for atomic x to drop NAs if(!is.atomic(x)) stop("`x` must be atomic") if (is.null(replace)) return(x[!is.na(x)]) # else x[is.na(x)] <- replace x } roundLeft <- function(x, n=3, useCL=TRUE, pushup=1.5, noWarnOnChar=TRUE) { # n counts from the left. if(is.factor(x) || is.character(x)) x <- as.num.as.char(x, noWarnOnChar=noWarnOnChar) if(!is.numeric(x) || !is.atomic(x)) stop("x must be numeric and atomic") if (length(n) != 1) stop("n must be of length 1") if (n < 1) warning("n should be a positive integer") if (useCL) { cl <- ceiling(log(x, 10)+pushup) ex <- cl-n } else ex <- n ret <- round(x / 10^ex) * 10^ex return(ret) } 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)) } paste_l <- function(x, cols=3, spacer=", \t", eolAlsoHasSpacer=FALSE , usefw=TRUE, sameWidth=FALSE, extra=2, na.replace="") { ## wrapper function to collapse x into `cols` many columns. ## Each element of x is separated by spacer. ## if eolAlsoHasSpacer is TRUE, spacer is added to alll of x ## else spacer is added only to the none-eol elements of x ## note that the elements of x should all be length one ## and should all be coerceible into character. ## Otherwise, results could be unpredictable. ## usefw : if TRUE, use fw to format the columns ## sameWidth : only applies if usefw is TRUE. Should cols all have the same width or should each be its own minwidth. ## Examples: ## cat("\n",paste_l(LETTERS, 5)) ## cat("\n",paste_l(LETTERS, " - ")) ## cat("\n",paste_l(LETTERS, 4, " - ")) # Shorthand to allow for the second argument to be the spacer # This feature is undocumented. if (is.character(cols) && missing(spacer)) { spacer <- cols cols <- 3 } if (is.numeric(spacer)) spacer <- pasteR(" ", spacer) ## replace NA's, normally with blank space if (!is.null(na.replace)) x[is.na(x)] <- na.replace ## Calculate inds.endl <- seq_along(x) %% cols == 0 # add spacer to the other elements of x (or to all of x, if flagged) L <- length(x) # ensure cols is not larger than L cols <- min(L, cols) if (eolAlsoHasSpacer) x[-L] <- paste0(x[-L], spacer) else { # preserve the last element x.last <- x[L] x[!inds.endl] <- paste0(x[!inds.endl], spacer) x[L] <- x.last } ## RETURN if (usefw) { if (sameWidth) { x <- fwc(x, extra=extra) x[inds.endl] <- paste0(x[inds.endl], "\n") return(paste(x, collapse="")) } else { ret <- tapply(x, ((seq_along(x) %% cols) - 1) %% cols, fwc, extra=extra ) # Add a line break only if there are strictly more elements than requested columns if (cols < L) ret[[cols]] <- paste0(ret[[cols]], "\n") # part of ret will get recycled in the final paste. We need to padd it ot prevent this sizes <- sapply(ret, length) if(any(wh <- sizes < max(sizes))) ret[wh] <- lapply(ret[wh], c, "") ## THIS GETS RETURNED return(do.call(paste0, as.list(ret))) } } else { # add a linebreak where needed x[inds.endl] <- paste0(x[inds.endl], "\n") # collapse into a single parag return(paste(x, collapse="")) } } allSetDiff <- function(A, B, names=FALSE, sep=" | ", quiet=FALSE) { ## Simple wrapper to compute setdiff(A, B) and setdiff(B, A) ## plus fancy pants output ## A.nm <- substitute(A) B.nm <- substitute(B) if (missing(names) && (is.data.frame(A) || is.data.frame(B))) names <- TRUE if (names) { A <- names(A) B <- names(B) } AxB <- setdiff(A, B) BxA <- setdiff(B, A) if(!length(AxB)) AxB <- " < none >" if(!length(BxA)) BxA <- " < none >" nm <- c( paste("In", A.nm, "not", B.nm) , paste("In", B.nm, "not", 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 <- rbind(nm, t(listFlatten(ret))) # make prettiur rb[is.na(rb)] <- "" rb[-1, ] <- paste0(" ", rb[-1, ]) rb[1, ] <- paste0(" ", rb[1, ]) ## Add a seperator line if (!is.null(sep)) { sep.len <- max(sapply(ret, length)) sep.vec <- rep(sep, sep.len+1) rb <- cbind(rb, sep.vec)[, c(1,3,2)] rb <- rbind(rb[1, ], pasteR("-", 2+nchar(rb[1, ])), rb[2:nrow(rb), ]) } ## fancy output cat("\n", paste_l(t(rb), (2+!is.null(sep)), sameWidth=FALSE, spacer="" ), "\n", sep="") } return(invisible(ret)) } fwc <- function(x, minChar=NULL, maxChar=NULL, extra=0) { ## function to format characters, all the same length # minChar : pad with AT LEAST this many toal chars # maxChar : do NOT exceed this many total chars (will not crop elements which already exceed this value.) # extra : only applies to organic sizes (ie padding to the largest value), not to `minchar` value if (!is.atomic(x)) stop("x must be an atomic vector.") if (is.factor(x)) x <- as.character(x) dims <- if (!is.null(dim(x))) dim(x) nc <- nchar(x) ch <- max(nc + extra, minChar) ch <- min(ch, maxChar) ret <- paste0(x, pasteR(" ", ch-nc) ) if (!is.null(dims)) dim(ret) <- dims return(ret) } commaToNumeric <- function(x) as.numeric(gsub(",", "", x)) currToNumeric <- function(x) as.numeric(gsub("\\$|,", "", x)) percToNumeric <- function(x, divideBy100=TRUE) as.numeric(gsub("\\%|,", "", x)) / ifelse(divideBy100, 100, 1) 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 ", 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 } # ----------------------- START OF INSPECT FUNCTIONS ----------------------- # parseInspectLine1 <- function(line, nms) { require(stringr) # grab relevant info L1 <- str_trim(line[[1]]) mem <- substr(L1, 1, str_locate(L1, " ")[, "start"]-1) len <- as.numeric(str_extract(str_extract(L1, "len=\\d+"), "\\d+")) tlen <- as.numeric(str_extract(str_extract(L1, "tl=\\d+"), "\\d+")) # check the names if (missing(nms) || length(nms) != 1) nms <- paste0(as.expression(substitute(x)), collapse="") return(data.table(obj=nms, mem=mem, len=len, tlen=tlen)) } Inspect <- function(x, linesToOutput=3, cropInfo=TRUE, extractInfo=FALSE, inspect.max.length=7, dontIterate=FALSE, pos=1, en=parent.frame()) { ## Outputs helpful memory information, generally used with data.tables ## Returns the full output of `.Internal(inspect(x, max.length=inspect.max.length))` ## as a single, collapsed string. ## ## cropInfo : Whether or not to DISPLAY the "lines cropped" information. ## If FALSE, will not display how many lines were omitted ## This is useful in interactive, when comparing two objects, eg: ## { Inspect(DT1, cropInfo=FALSE); Inspect(DT2, cropInfo=FALSE) } ## dontIterate : Useuful for when x is a list and we want to inspect the list itself, not its elements ## If FALSE (default) will iterate over the elements of X when X is a list. ## Wrapper function to .Internal(inspect(x)) usually called on a data.table (or parttherof) ## to see whats going on with modify in place ## ## if (!cropInfo && missing(linesToOutput)) linesToOutput <- 1 CO <- eval(capture.output(.Internal(inspect(x, max.length=inspect.max.length))), envir=en) ret <- paste(CO, collapse="\n") ## Gather the names. Generally, just substitute(x), however, x might be list(DT1, DT2), in which case, we want to drop "list" nms <- as.character(substitute(x)) if (is.call(match.call()[["x"]]) ) nms <- nms[-1] ## If x is a list, iterate if (inherits(x, "list")) { warning("x is a list, and will be treated as a single object.\nFunction `Inspect` does not vectorize well.\n\nDid you mean to use `Inspectall(...)` instead?\n") # todo: ret <- lapply(x, Inspect, # todo: linesToOutput=linesToOutput, cropInfo=cropInfo, extractInfo=extractInfo, inspect.max.length=inspect.max.length, en=en) # todo: if (!extractInfo) # todo: return(invisible(ret)) # todo: ret <- rbindlist(ret)[, x := nms] # todo: groupingCodes <- lapply(seq_along(x), pasteR, x="#") # todo: # browser() # todo: ## add an indicator showing when elements share the same memory # todo: ret[, sameMem := ifelse(.N>1, groupingCodes[[.GRP]], ""), by=mem] # todo: return(ret) } if (extractInfo) return(parseInspectLine1(line=CO[[1]], nms=nms)) # else if (linesToOutput + 1 <= length(CO)) CO <- c(CO[seq(linesToOutput)], if (cropInfo) c(paste0(" --- < ", length(CO)-linesToOutput ," more lines cropped > --- "))) cat(paste(CO, collapse="\n"), "\n") return(invisible(ret)) } Inspectall <- function(...) { L <- length(list(...)) ret <- list() for (i in seq(L)) { obj.nm <- as.list(substitute(list(...)))[-1] [[i]] ret[[i]] <- capture.output( .Internal(inspect( eval(obj.nm, envir=parent.frame(1)) # get(as.character( # as.list(substitute(list(...)))[-1] # [[i]] # ), envir=parent.frame(1)) )) # // closing .Inte(insp( . )) )[[1]] } # Combine results into a single DT ret <- rbindlist(lapply(ret, parseInspectLine1)) ## Make fancy # adding names nms <- as.character(as.list(substitute(list(...)))[-1L]) ret[, obj := nms] # Add similarity indicators # note that the grouping codes have no actual significance. Just used as a quick visual to see if two objects have the same memory. groupingCodes <- c(" (✓) ", " o_o ", " +++ ", " .~. ", " :#: ", " xxx ", " --- ") if (L > length(groupingCodes)) groupingCodes <- c(groupingCodes, lapply(seq_along(x), pasteR, x="#")) ret[, sameMem := ifelse(.N>1, groupingCodes[[.GRP]], ""), by=mem] ## add dim info rows <- lapply(list(...), nrow) cols <- lapply(list(...), ncol) ret[, c("rows", "cols") := list(rows, cols)] ret } # ----------------------- END OF INSPECT FUNCTIONS ----------------------- # # ----------------------- START OF PRETTY STRING FUNCTIONS ----------------------- # sideByside <- function(x, y, sep=3, bar=NULL) { ## bar is a shorthand for "|" with spaces outside of if(!is.null(bar) ) { if (!missing(sep)) warning("Cannot use both `sep` and `bar` in the function `sideByside`. `bar` will superscede.") if (!is.numeric(bar)) stop("\n\nWhen using `bar` in `sideByside`,\nmake sure the value is numeric (ie, the total amount of spaces).\nFor everything else, use the `sep` argument.\n") sep <- paste0(pasteR(" ", floor(bar/2)), "|", pasteR(" ", floor(bar/2))) } if (is.numeric(sep)) sep <- pasteR(" ", n=sep) if (is.null(sep)) sep <- "" if (!is.character(sep)) stop("sep should be a number (of spaces) or a string.") x <- as.character(x) y <- as.character(y) x <- remEndl(x) L <- max(length(x), length(y)) x <- removeNA(x[seq(L)], pasteR(" ", nchar(x[[1]]))) y <- removeNA(y[seq(L)], pasteR(" ", nchar(y[[1]]))) paste(x, sep, y) } remEndl <- function(x) { if (!is.atomic(x)) stop("x must be atomic") gsub("\n$", "", x) } center <- function(x, width.min=NULL, pad=1, all.same=TRUE, header=!is.null(colnames(x)) , hbar=FALSE, add.endl=FALSE, matrix.lines.collapse=FALSE, NAsToBlank=TRUE , trim.first=TRUE, align=c("center", "left", "right"), shiftLeft=0 , even="Left" ) { # even: can be logical or `left` or `right`. # If there are an odd number of nchar, smooths out, by adding a space to the side indicated # browser() ## check for T/F/NA if (isTRUE(even)) even <- "left" if (identical(even, FALSE) || is.na(even)) even <- "X" ## Take the first letter, as uppercase even <- substr(toupper(as.character(even)), 1, 1) align <- tolower(align) align <- match.arg(align) if(isTRUE(pad)) pad <- 2 if(!isTRUE(is.numeric(pad))) pad <- 0 # header applies only to lists & DF/DTs if (header) { nms <- { if (!is.null(names(x))) names(x) else if (!is.null(colnames(x))) colnames(x) } if (!is.null(nms)) x <- mapply(c, nms, x) } if (is.list(x)) { if(all.same) width.min <- max(width.min, (nchar(unlist(x))+2*pad) ) ret <- (lapply(x, center, width.min=width.min, pad=pad, hbar=hbar, NAsToBlank=NAsToBlank, trim.first=trim.first, align=align, even=even)) if (add.endl) stop("Not sure how to implement for list `add.endl` for lists") return(ret) } if (is.matrix(x)) { if(all.same) width.min <- max(width.min, nchar(unlist(x))) ret <- (apply(x, 2, center, width.min=width.min, pad=pad, header=FALSE, hbar=hbar, NAsToBlank=NAsToBlank, trim.first=trim.first, align=align, even=even)) if (add.endl) ret[, ncol(ret)] <- paste0(ret[, ncol(ret)], "\n") if (matrix.lines.collapse) { ret <- apply(ret, 1, paste, collapse=" ") if (hbar) ret[[2]] <- gsub("- -", "-|-", ret[[2]]) } return(ret) } if (!is.atomic(x)) stop("x must be atomic in order to call `center` on it") ## TODO: Double check this if (length(x) > 1) x <- paste(x, collapse="\n") x <- as.character(x) splat <- strsplit(x, "\n")[[1]] if (trim.first) splat <- gsub("^\\s+|\\s+$", "", splat) if (NAsToBlank) { splat[is.na(splat)] <- "" splat <- gsub("^NA$", "", splat) } nc <- nchar(splat) # browser() width <- max(width.min, (nc+2*(pad)) ) toAdd <- width-nc ret <- { if (align=="left") paste0(pasteR(" ", pad), splat, pasteR(" ", toAdd-pad)) else if (align=="right") paste0(pasteR(" ", toAdd-pad), splat, pasteR(" ", pad)) else { tA <- floor(toAdd / 2) # even cleaned up at the top, will be either L/R if adding a space if (even %in% c("L", "R")) { even.filler <- pasteR(" ", width-((2*tA)+nc)) splat <- if (even=="L") paste0(splat, even.filler) else paste0(even.filler, splat) } paste0(pasteR(" ", tA), splat, pasteR(" ", tA)) } } if (hbar) { bar <- pasteR("-", max(nchar(ret))) ret <- c(ret[[1]], bar, if(length(ret) > 1) ret[2:length(ret)]) } if (shiftLeft > 0) ret <- paste0(pasteR(" ", shiftLeft), ret) return(ret) } pco <- function(...) { # # browser() paste0(capture.output(eval( (...), envir=parent.frame())), collapse="\n") } compareDTs <- function(DT1, DT2, mem=TRUE, quiet=FALSE) { if (mem) { 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 DT1.nm <- as.character(as.expression(substitute(DT1))) DT2.nm <- as.character(as.expression(substitute(DT2))) info[DT.NM == "DT1", DT.NM := DT1.nm] info[DT.NM == "DT2", DT.NM := DT2.nm] i.c <- center(info, add.endl=FALSE, hbar=TRUE, matrix.lines.collapse=TRUE, all.same=FALSE, pad=2.5) header.info <- paste0("\n ~~~ DIM & MEMORY COMPARISONS ~~~\n", pasteR("_", nchar(i.c)[[1]]), "\n") h.c <- center(header.info, width.min=max(nchar(i.c))) # put together DIM.MEM <- center(c(h.c, "",i.c), add.endl=TRUE, trim.first=FALSE) setdiffs <- allSetDiff(DT1, DT2, names=TRUE, quiet=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("\n~~~ COLUMN COMPARISONS ~~~\n", pasteR("_", nchar(col.diffs[[1]])), "\n") COL.NMS <- c(header.cols, col.diffs) COL.NMS <- center(COL.NMS, trim=FALSE) ## Output if (!quiet) { out <- c(paste("\t ", COL.NMS), "\n", DIM.MEM, "\n\n") cat(out, sep="\n") } return(invisible(list(mem=memory, dims=dims, setdiffs=setdiffs))) } # ----------------------- END OF PRETTY STRING FUNCTIONS ----------------------- # # ----------------------- START FOR POJECT TEMPLATE ----------------------- # ## undocumented function, for personal utility .fol <- function(x, dir=FALSE, silent=FALSE, copy=!silent) { folder <- as.character(substitute(x)) nms <- names(folders) nm <- nms[match(as.character(folder), nms)] out <- folders[[nm]] if(copy && exists("clipCopy")) clipCopy(out) if (dir) out <- dir(out) if (!silent) { print(cbind(out)) return(invisible(out)) } else return(out) } project.folders <- function(projName, pos=1, silent=FALSE) { folders <- list.dirs(as.path(wrkDir,projName)) names(folders) <- sapply(strsplit(folders, .Platform$file.sep), tail, 1) class(folders) <- "folders" assign("folders", folders, envir=parent.frame(pos)) if (!silent) print(folders) return(invisible(folders)) } print.folders <- function(folders, levs=0) { fsep <- .Platform$file.sep splat <- strsplit(folders, split = fsep) bare <- sapply(splat, function(x) paste(tail(x, levs+1), collapse=fsep)) names(folders) <- bare print(cbind(folders), quote=FALSE) } add.package <- function (pkgs, configFolder=folders[["config"]], configFile=file.path(configFolder, "global.dcf"), silent=FALSE) { if (!is.character(pkgs)) stop("The package names should be a string or vector of strings; use quotes if necessary.") contents <- readLines(configFile) lib.line <- max(grep("^libraries\\:", contents)) # remove "libraries: " and then split on the comma. splitOn <- "\\s*,\\s*" existing.pkgs <- strsplit( sub("^libraries\\: *", "", contents[lib.line]), splitOn)[[1]] all.pkgs <- unique(unlist(c(existing.pkgs, pkgs))) # log which packages will be added if(!silent) { project <- tail(strsplit(configFile, split=.Platform$file.sep)[[1]], 3)[[1]] pkgs.added <- setdiff(all.pkgs, existing.pkgs) pkgs.existed <- intersect(pkgs, existing.pkgs) } # combine into a single string all.pkgs <- paste0(all.pkgs, collapse=", ") ## replace that line contents[lib.line] <- paste("libraries:", all.pkgs) # writ to ouput writeLines(contents, configFile) # Informative output if (!silent) { cat("Adding the following packages to the config file for project \"", project, "\" : \n\t" , if(length(pkgs.added)) paste(pkgs.added, collapse=", ") else " < none added > ", "\n" , if (length(pkgs.existed)) paste0( "The following package were already in the config file: \n\t" , paste(pkgs.existed, collapse=", "), "\n" ) , sep="") } # invisibly return TRUE return(invisible(TRUE)) } rm.package <- function (pkgs, configFolder=folders[["config"]], configFile=file.path(configFolder, "global.dcf"), silent=FALSE) { if (!is.character(pkgs)) stop("The package names should be a string or vector of strings; use quotes if necessary.") contents <- readLines(configFile) lib.line <- max(grep("^libraries\\:", contents)) # remove "libraries: " and then split on the comma. splitOn <- "\\s*,\\s*" existing.pkgs <- strsplit( sub("^libraries\\: *", "", contents[lib.line]), splitOn)[[1]] all.pkgs <- setdiff(existing.pkgs, unlist(pkgs)) # log which packages will be added if(!silent) { project <- tail(strsplit(configFile, split=.Platform$file.sep)[[1]], 3)[[1]] pkgs.rmd <- intersect(pkgs, existing.pkgs) pkgs.notfound <- setdiff(pkgs, existing.pkgs) } # combine into a single string all.pkgs <- paste0(all.pkgs, collapse=", ") ## replace that line contents[lib.line] <- paste("libraries:", all.pkgs) # writ to ouput writeLines(contents, configFile) # Informative output if (!silent) { cat("\n The following packages were removed from the config file for project \"", project, "\" : \n\t" , if(length(pkgs.rmd)) paste(pkgs.rmd, collapse=", ") else " < none removed > ", "\n" , if (length(pkgs.notfound)) paste0( "\n The following package were not in the config file: \n\t" , paste(pkgs.notfound, collapse=", "), "\n" ) , sep="") } # invisibly return TRUE return(invisible(TRUE)) } show.packages <- function(configFolder=folders[["config"]], configFile=file.path(configFolder, "global.dcf"), silent=FALSE) { ## Shows whic packages will be loaded on startup contents <- readLines(configFile) lib.line <- max(grep("^libraries\\:", contents)) # remove "libraries: " and then split on the comma. splitOn <- "\\s*,\\s*" pkgs <- strsplit( sub("^libraries\\: *", "", contents[lib.line]), splitOn)[[1]] if (!silent) { project <- tail(strsplit(configFile, split=.Platform$file.sep)[[1]], 3)[[1]] ## formatting pkgs.out <- if (exists("paste_l") && exists("center")) paste_l(center(pkgs, align="left", pad=3), spacer=" ") else paste(pkgs, collapse=", ") cat("The following packages will be loaded with project \"", project, "\" : \n\n" , if(length(pkgs)) pkgs.out else " < none added > ", "\n\n" , sep="") } return(invisible(existing.pkgs)) } ## These are synonymous functions for those users who confuse terminology. ## Synonymous function names add.library <- function(..., WRONG.FUNCTION="USE add.package(.) INSTEAD") { message("\nYou probably meant to call `add.package( )`.\nThats okay, we understand. We'll call it for you.") add.package(...) } remove.package <- rm.library <- function(..., WRONG.FUNCTION="USE rm.package(.) INSTEAD") { message("\nYou probably meant to call `rm.package( )`.\nThats okay, we understand. We'll call it for you.") rm.package(...) } # ----------------------- END FOR POJECT TEMPLATE ----------------------- # # -------------------------------------------------------------------------------- # # # EDITED: # # setcolorderpt(), asCurr() # -------------------------------------------------------------------------------- # setcolorderpt <- function(x, neworder, endcols=NULL, failOnMissingCols=FALSE) { # Set Col Order Pt (as in, partly) # Wrapper to setcolorder, where this function allows for a partial # list of column names. If this list is missing names (relative to names(x)) # then it is filled with the remaining names from x # use the key as default if (missing(neworder) && !is.null(key(x))) neworder <- key(x) # ------------------------------------------------------------------ # # check that there aren't any names given that are not names of the DT # ------------------------------------------------------------------ # if (any(miss <- !(neworder %in% names(x)))) { msg <- paste0("\nThe following column names in `neworder` are not in the names of `", substitute(x), "`\n\t", paste0(neworder[miss], collapse="\n\t"), "\n", ifelse(!failOnMissingCols, "These columns will be ignored.\n", "") ) if(failOnMissingCols) stop(msg) # else warning(msg) neworder <- neworder[!miss] } # ------------------------------------------------- # if (any(miss <- !(endcols %in% names(x)))) { msg <- paste0("\nThe following column names in `endcols` are not in the names of `", substitute(x), "`\n\t", paste0(endcols[miss], collapse="\n\t"), "\n", ifelse(!failOnMissingCols, "These columns will be ignored.\n", "") ) if(failOnMissingCols) stop(msg) # else warning(msg) endcols <- endcols[!miss] } # ------------------------------------------------------------------ # neworder <- c( neworder, setdiff(names(x), c(neworder, endcols)), endcols ) setcolorder(x, neworder) } asCurr <- function(x, decim=2, noSpacesAfterSymb=1, symbol="$" , noWarnOnChar=FALSE, checkForNAChars=TRUE) { # returns a currency-formatted string # example: # x <- c(0.001, 0.02, 0.07, 0.1, 0.15, 0.23, 0.5, 0.73, 1, 1.12, 1234.72, 2.46, 17, NA) # data.frame(x, Curr2=asCurr(x, 2), Curr3=asCurr(x, 3), Curr0=asCurr(x, 0), stringsAsFactors=FALSE) # identify which values are NA. They will be put back to NA at the end. NaNs <- is.na(x) # if checkForNAChars is flagged AND we did not find any NAs already if (checkForNAChars && checkForNAChars && is.character(x)) NaNs <- stringr::str_trim(x) == "NA" supress <- if (noWarnOnChar) suppressWarnings else identity if (is.factor(x)) x <- supress(as.numeric(as.character(x))) if (!is.numeric(x)) x <- supress(as.numeric(x)) # Note to self: # I was capturing the NA's that were introduced by coercian to then somehow flag them. # However, this is not neccessary, as the will stick out # as `"$ NA.NA"` and also a warning will already be issued. ## BLANK SPACES AFTER SYMBOL spaces <- pasteR(" ", noSpacesAfterSymb) ## DECIMAL DIGIT if (decim==0) { deciDigsStr = "" } else { # grab the `decim` many digits, by first calculating the remainder when dividing by 1, then multiplying by a power of 10 and rounding to the 1's. decDigs <- round((x %% 1) * (10^decim), 0) # we have to catch values that are rounded up to a new digit (eg 99 ~> 100) if (any(extraDig <- which(decDigs > (10^decim) - 1), na.rm=TRUE)) { # remove NA's, which will mess up assignment x[extraDig] <- x[extraDig] + 1 ## TODO: Confirm to yourself that this is should be 1 decDigs[extraDig] <- 0 } #check for missing leading zero's, as in "2" from $777.02 (otherwise at the end we would get $777.2) deciDigsStr <- paste0(pasteR("0", decim - nchar(decDigs)), decDigs) # dont have to worry about NA's as they are handled at end # add a leading ".", which is not used if decim==0 deciDigsStr <- paste0(".", deciDigsStr) } ## BODY OF NUMBER xStr <- prettyNum(floor(x), scientific=FALSE, big.mark=",") ## PUT IT ALL TOGETHER ret <- paste0(symbol, spaces, xStr, deciDigsStr) ## NA's may # Put back the NA values ret[NaNs] <- NA # Add names if they exist if (length(names(x))) names(ret) <- names(x) # return return(ret) } # END asCurr mbench <- function(..., maxSeconds=20, maxReps=200L, verbose=TRUE, times=NA , align="right", check=TRUE, checkEQUAL=check, debug=FALSE) { # check : synonym for checkEQUAL # checkEQUAL : first evaluates each expression and confirms that they are all equal require(microbenchmark) cls(3) # grab the dots dots <- list(...) # Check that the arguments are quoted calls if(! all(sapply(dots, is.call)) ) { dots <- match.call(expand.dots=FALSE)[["..."]] warning("\n All arguments should be quoted calls.\n We will fix this by using match.call trickery, but the names will be funky.\n ", "Next time use something like \n\n\t\tsomeName <- quote(", dots[[1]], ")\n") } ## Grab names, add to dots mc <- match.call() nms <- as.character(mc[(1:length(dots))+1]) ## Debugging if (debug) browser() dots <- setNames(dots, nms) # Function for calculating time based on a sample time timesFormula <- function(sampleTime) min(as.integer(floor(maxSeconds / max(sampleTime, 0.00001) )), maxReps) # The max(., .0001) is to prevent div by zero ## if checkEQUAL, evaluate each one first then check that they are the same. Fail if not. if (checkEQUAL) { timeToEval <- system.time({ evald.dots <- lapply( seq(dots), function(x) eval( dots[[x]] ) ) }) if(!areEqual(evald.dots)) stop("Not all values passed evaluate to the same result.") # Use the time it took to Eval to calculate the `times` value times <- timesFormula(sampleTime=timeToEval[["user.self"]]) } # if times is not given explicitly, calculate it based on how long one execution of each takes if (is.na(times)) { times.matrix.single.run <- sapply(dots, function(x) system.time(eval(x))) user.times.single.run <- times.matrix.single.run["user.self", ] summed.run.time <- sum(user.times.single.run) times <- timesFormula(sampleTime=summed.run.time) } times <- as.integer(times) if (verbose) { preInfo <- center(capture.output({ cat("Times for a singe run are: \n") if (exists("user.times.single.run")) print(data.frame(t(user.times.single.run), check.names=FALSE), row.names=FALSE) else if (exists("timeToEval")) timeToEval else cat("< unavailable (not calculated) >\n") cat("\n Microbenchmark will run", times, "times") }), shiftLeft=12, trim.first=FALSE) cat(preInfo, sep="\n") cls(3) hr <- pasteR("~", 50) # cat(center("RESULTS:", pad=8, hbar=TRUE, width=50), sep="\n") } # compute res <- (microbenchmark(list=dots, times=times)) smy <- as.data.table(summary(res)) units <- attr(smy, "unit") # drop the unused columns smy[, c("min", "max", "neval") := NULL] # Clean the expr name smy[, expr := fwS(levels(expr), suffix=":", extra.R=1, align=align) ] # Identify which columns are numeric, then round numericCols <- which(sapply(smy, is.numeric)) roundTo <- ifelse(smy[, all(.SD>5), .SDcols=numericCols], 2, 4) smy[, c(numericCols) := lapply(.SD, round, roundTo), .SDcols=numericCols] ## Add spaces to numeric columns, to align the period smy[, c(numericCols) := lapply(.SD, fwS, align="right"), .SDcols=numericCols] setnames(smy, toupper(names(smy))) # capture output shift <- 6 out <- center(smy, pad=2.5, trim=FALSE, add.endl=FALSE, shiftLeft=0 , matrix.lines.collapse=TRUE, hbar=TRUE, all.same=FALSE) ## add units & times info nc <- min(nchar(out)) unitsInfo <- paste0("Units: ", units) repsInfo <- paste0("Number of Repetitions: ", times) nc.tot <- nchar(repsInfo) + nchar(unitsInfo) headerInfo <- paste0(unitsInfo, pasteR(" ", max(5, nc-nc.tot) ), repsInfo, "\n") ## Display Output (resultsHr <- paste0(center(c(hr, "RESULTS:", hr), pad=8, width=50, shiftLeft=6, add.endl=TRUE))) out <- c(resultsHr, "\n", paste0(pasteR(" ", shift), c(headerInfo, out) )) cat(center(out, shiftLeft=shift), sep="\n") # old - ## add units & times info # old - nc <- min(nchar(out)) # old - unitsInfo <- paste0("Units: ", units) # old - repsInfo <- paste0("Number of Repetitions: ", times) # old - nc.tot <- nchar(repsInfo) + nchar(unitsInfo) # old - headerInfo <- paste0(unitsInfo, pasteR(" ", max(8, nc-nc.tot) ), repsInfo, "\n") # old - cat(c(headerInfo, out)) # old - # old - # clean up output # old - levels(res$expr) <- fwS(levels(res$expr), suffix=":", extra.R=1, align=align) # old - out <- capture.output(print(res)) # old - out[[1]] <- paste0(" ", out[[1]]) # there is an extra space in the first line # old - out[[2]] <- sub(" neval$", "", out[[2]]) # old - out[3:length(out)] <- sub(" *[0-9]+$","", out[3:length(out)]) # old - # * # old - nc.o1 <- sum(nchar(c(out[[1]], "Number of Repetitions: ", times))) # old - nc.max <- max(nchar(out)) # old - out[[1]] <- paste0(out[[1]], pasteR(" ", nc.max-nc.o1), "Number of Repetitions: ", times) # old - cat(out, sep="\n") # return results from microbenchmark return(invisible(res)) } regOr <- function(vec, brackets=TRUE, asterisk=NULL, escape=FALSE, whole=FALSE, whitespace=FALSE) { # combines a string vector into a regex `or` statement if (whole && !brackets) { warning("Cannot use whole without brackets. Please add `^` `$` anchors manually") } if (escape) { vec <- glob2rx(vec) vec <- substr(vec, 2, nchar(vec)-1) vec <- gsub("\\)", "\\\\)", vec) } # ws will be pasted. If not grabbing whitespace, make this NULL ws <- if (whitespace) "\\s*" else NULL # The main string to return ret <- paste0(ws, c(vec), ws, collapse="|") # If not adding brackets, then we're all set. if (!brackets) return(paste0(ret, asterisk)) # else return ret <- paste0("(", ret, ")", asterisk, collapse="") if (whole) { # Two separate lines to combat vectorization of paste ret <- paste0("^", ret) ret <- paste0(ret, "$") } return(ret) } regexAll <- function(pattern, stringVec, replace="@@@", ignore.case=FALSE, fixed=FALSE, perl=FALSE, value=FALSE) { # quick comparisons of the different family of regex options list("OriginalString"=stringVec , "grep" = grep (pattern, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl, value=value) , "grepl" = grepl (pattern, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl) , "regexpr" = regexpr (pattern, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl) , "gregexpr" = gregexpr(pattern, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl) , "regexec" = regexec (pattern, stringVec, ignore.case=ignore.case, fixed=fixed) , "gsub" = gsub(pattern, replace, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl) , "sub" = sub (pattern, replace, stringVec, ignore.case=ignore.case, fixed=fixed, perl=perl) ) } lib <- function(pkg, newest=FALSE, rforge=newest, update=rforge, dependencies=TRUE, installSuggestions=TRUE, quietly=FALSE) { # newest is a shorthand for `update` and `rgorge` # Note that if `rforge` is selected, this automatically sets update to TRUE # # if nothing to load, it will return TRUE ## Now done in the default arguments. Keeping this here in case needing to revert. # old # newest is a shortcut for rforge & update both TRUE # old if (newest) # old rforge <- update <- TRUE # old # old # if `rforge` flagged on, that probably means update, unless explicit otherwise # old if (rforge && missing(update)) # old update <- TRUE # The idea is that if package is not quoted, it should still work. # -------------------------------------------------------------- # pkg.char <- as.character(substitute(pkg)) if(inherits(substitute(pkg), "call")) pkg.char <- pkg.char[-1] ## Determine if we should substitute pkg.char for pkg. # note that pkg.char is what was sent to this function. # it might be the name of an object, thus we check if it exists # if it does exist, then we do not substitute. if (!exists(pkg.char) || !is.character(substitute(pkg)) ) { # Next we check if pkg is a character. If it isn't, then we do substitute. # The isErr part is to shortcircuit the check for is.character of an object that does not exist if (isErr(is.character(pkg)) || !is.character(pkg)) pkg <- pkg.char } ## Error Check if (!(isTRUE(length(pkg)>0))) { warning("`pkg` has length 0. Nothing to load.") return(TRUE) } check <- c() # if update is flagged, skip this step and first install if (!update) { for (p in pkg) suppressWarnings(check[p] <- do.call(require, list(package=p, quietly=quietly))) ## if all packages loaded, we're done if (all(check)) return(invisible(check)) # else, filter the list down to just the errors pkg <- pkg[!check] # if failed, search for matches in lib and try again allPkgs <- dir(.libPaths()) hits <- match(tolower(eval(pkg)), tolower(dir(.libPaths()))) if(!all(is.na(hits))) { pkg[!is.na(hits)] <- allPkgs[hits][!is.na(hits)] # try again for (p in pkg) suppressWarnings(check[p] <- do.call(require, list(package=p, quietly=quietly))) if (all(check)) return(invisible(check)) } } # else repos <- ifelse(rforge, "http://R-Forge.R-project.org", getOption("repos")) install.packages(pkg, dependencies=dependencies, repos=repos) ## Catch any misnamed items if (exists("last.warning")) { w <- names(last.warning) w <- grep("Perhaps you meant", w, value=TRUE) } else w <- character() # if flagged, and there are suggestions from the server, try those if(installSuggestions && length(w) > 0) { ## Extract just the suggested package name re <- regexpr("‘.+’", w) en <- re + attr(re, "match.length") - 1 w <- substr(w, re+1, en-1) cat("Trying packages\n\t",paste(w, collapse="\n\t"), "\n") install.packages(w, dependencies=dependencies, repos=repos) # Load, note that we are also banking the new name for (p in w) suppressWarnings(check[p] <- do.call(require, list(package=p, quietly=quietly))) } ## TODO: if failed due to dependencies, (re)install dependencies ## eg: "Error : package ‘XML’ was built before" for (p in pkg) suppressWarnings(check[p] <- do.call(require, list(package=p, quietly=quietly))) return(invisible(check)) } 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))) ) } # 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) } # -------------------------------------------------------------------------------- # # -------------------------------------------------------------------------------- # #------------------------------------------------------# # THESE ARE THE FUNCTIONS PRESENT IN THIS FILE # #------------------------------------------------------# #------------------------------------------------------# # JavaTest ( stopRun=TRUE, runInit=TRUE ) # isErr ( expression ) # isNumber ( x ) # showProg ( flag, outp, header=FALSE, done=FALSE, tb=1 ) # pasteC ( ... ) # paste_ ( ... ) # pasteR ( x, n ) # pasteNoBlanks ( ..., sep=" ", collapse=NULL, na.rm=FALSE ) # fw0 ( num, digs=NULL, mkseq=TRUE, pspace=FALSE ) # fw0.older ( obj, digs=NULL ) # fw ( x, dec=4, digs=4, w=NULL, ... ) # fw3 ( x, dec=3, digs=3, w=NULL, ... ) # fwp ( x, dec=2, sep=" " ) # roundOutToX ( obj, x=10 ) # clipPaste ( flat=TRUE ) # clipCopy ( txt, sep="" ) # meantrm ( x, p=6 ) # CMT <- getCMT <- getClassModeTypeof ( obj ) # jythonIsGlobal ( ) # python ( jythonStatement ) # pythonGet ( pythonObj ) # pythonSet ( rObj ) # pythonSetDiffName ( pythonObj, rObj ) # pyParse ( strToParse ) # form ( x, dig=3 ) # getNCMT <- getNameClassModeTypeof ( obj ) # countNA01s ( vec ) # insert ( lis, obj, pos=0, objIsMany=FALSE ) # as.path ( ..., ext="", fsep=.Platform$file.sep, expand=TRUE, verbose=TRUE ) # cleanDotDotPath.split ( pathParts, fsep=.Platform$file.sep, expand=TRUE ) # cleanDotDotPath.combine ( splat, fsep=.Platform$file.sep, expand=TRUE ) # makeDictFromCSV ( csvFile ) # isSubstrAtEnd ( x, pattern, ignorecase=TRUE ) # s <- summary2 ( x, rows=6, cols=6, cmt=TRUE ) # c4 ( x, rows=20, cols=4, cmt=TRUE ) # printdims ( X, justTheValue=FALSE ) # topropper ( x ) # topropper_withPunc ( x ) # qy <- quity ( dir='~/' ) # qn <- quitn ( dir='~/' ) # tbs ( n, nl=FALSE ) # pip ( ) # slash ( ) # 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 ) # timeStamp ( seconds=FALSE ) # detectAssignment ( obj, single=TRUE, simplify=FALSE ) # loadbak ( f, env=parent.frame() ) # saveit ( obj, dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=TRUE, pos=1, addTimeStamp=TRUE, useSeconds=FALSE ) # jesusForData ( ..., dir=dataDir, sub=FALSE, stampFile=TRUE, stampDir=FALSE, pos=1, envir="" ) # savethem <- jesus ( ..., dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=sub, pos=1, sub=TRUE, stampDir=TRUE, stampFile=FALSE, summary=TRUE, envir="" ) # mkSaveFileNameWithPath ( objName, dir, pos=2, addTimeStamp=FALSE, ext=".Rda" ) # dimToString ( objName, pos=2, prefix="-" ) # 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 ) # asCurr ( x, decim=2, noSpacesAfterSymb=1, symbol="$" ) # lP <- listPacker ( receiver, ... ) # lsnf ( ... ) # lsi ( what, invert=FALSE, rm=FALSE ) # devsource ( file, dir="~/Dropbox/dev/R/!ScriptsR/" ) # gitsource ( file, dir="~/git/misc/rscripts/" ) # homesource ( file, dir="~/" ) # source.url ( ... ) # extendToMatch ( source, destin ) # rmDupLines ( obj, trim=T ) # cordl ( ..., length=NULL, justSize=FALSE, crop=TRUE, chop=TRUE ) # paraLineChop ( so, length=NULL, lines=NULL, justSize=FALSE ) # coefTable ( model ) # splitEvery ( string, n, remSpace = FALSE ) # cls ( LINES=100 ) # pkgFind ( toFind ) # regexAll ( pattern, stringVec, replace="@@@", ignore.case=FALSE, fixed=FALSE, perl=FALSE, value=FALSE ) # tbls ( envir=.GlobalEnv ) # colquote ( colNamesAsStrings ) # uniqueRows ( DT ) # getdotsWithEval ( ) # setkeyE ( x, ..., verbose = getOption("datatable.verbose") ) # shift ( x ) # shiftb ( x ) # namesdetect ( x, pattern ) # namesIn ( x, vec, positive=TRUE ) # namesNotIn ( x, vec ) # 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, ... ) # convertClass.data.table ( DT, colnameVector, to, from=NULL, originDate="1970-01-01", excelOriginName=".xlorigin" ) # areEqual.slow ( x, na.rm=TRUE ) # areEqual ( x, na.rm=TRUE, tolerance = .Machine$double.eps ^ 0.5, NoWarnings=FALSE ) # CamelCaseSplit ( string, flat=FALSE ) # gapply ( X, FUN, ..., simplify=FALSE, pos=1 ) # 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 ) # modelDescrFromCall.lm ( M ) # modelDescrFromCall.default ( M ) # paste.call ( ordr ) # modelDataSetFromCall ( ... ) # modelDataSetFromCall.Arima ( M ) # modelDataSetFromCall.lm ( M ) # dimCompare ( ..., decr=NA, decreasing=decr, sortOn=NA ) # rangesFromInt ( int, numberOfRanges, sizeOfEach, pairs=TRUE, aslist=TRUE, sequence=TRUE, fractions=FALSE ) # r.t ( x=clipPaste(), header=TRUE, sep=NULL, to=NULL, value=!(is.character(to)), pos=1, file=NULL ) # r.d ( x=clipPaste(), header=TRUE, sep=NULL, to=NULL, value=!(is.character(to)), pos=1, file=NULL ) # First ( silent=FALSE ) # as.path ( ... ) # howManyNAs ( x ) # sortXbyY ( X, Y, justIndex=FALSE, names=FALSE, names.X=names, names.Y=names ) # seasonFromDate ( D, factors=TRUE ) # revString ( x ) # mds ( includeInput=TRUE, x=clipPaste() ) # mkdshr ( x=clipPaste(), space=TRUE, pound="#", dash="-", leftSpace=TRUE, includeInput=TRUE, top=TRUE, minWidth=20, align=NA, mindent=4, dontSmoothPreSpace=FALSE, fancy=FALSE, match=FALSE ) # topAndBottom ( vec, n=1 ) # mr ( x=clipPaste(), mindent=9, minWidth=60, align="left", top=TRUE, match=FALSE, ... ) # mkdsh ( x=clipPaste(), space=TRUE, pound="#", dash="-", leftSpace=TRUE, includeInput=TRUE ) # spacecnt ( x=clipPaste() ) # dtWideToLong ( DT, cols=names(DT), cnames=c("Name", "Value") ) # knito ( input, output=gsub("src", "out", dirname(input)), encoding="UTF-8", ... ) # mbench ( ..., maxSeconds=20, maxReps=200L, verbose=TRUE ) # utilSource ( .Pfm=Sys.info()[['sysname']] ) # plrl ( word.pluarl.form, count, singular=(length(count)==1) ) # whichFactors ( x ) # 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 ) # lib ( pkg, newest=FALSE, dependencies=TRUE, rforge=FALSE, update=FALSE ) # are ( ll, simplify=TRUE ) # findLastSpace ( x, space=" " ) # sourceEntireFolder ( folderName ) # cnt ( col, DT=defaultDT ) # mergeDTlist ( DTlist, suffixes=NULL, checkKeys=TRUE ) #------------------------------------------------------ .Pfm <- Sys.info()[['sysname']] # Load Memory Functions try( ## Wrapping in `try` so that if fails, does not affect rest of the utils load #x-NBS-x# if (.Pfm=="Linux"){ #x-NBS-x# source(path.expand("~/NBS-R/utils/memoryFunctions.R")) #x-NBS-x# wrkDir <- "~/NBS-R/" #x-NBS-x# } else source(path.expand("~/git/misc/rscripts/utils/memoryFunctions.R")) , silent=TRUE) .RForge <- "http://R-Forge.R-project.org" # 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) .First <- function(silent=FALSE) { ## A few lines to clear the screen. if(!silent) cat(rep("\n", 10)) ## Load data.table. Wrap it in `try` to not fail the whole function. if (!silent) suppressMessages(try(library("data.table"))) else try(library("data.table")) assign(".Pfm", Sys.info()[['sysname']], envir=.GlobalEnv) ### ---------------------------------------------------------------------- ## If the baseDir option is set, use it. Otherwise, setit ### ---------------------------------------------------------------------- baseDir <- getOption("baseDir", default= { if (exists("baseDir")) baseDir else { baseDirTries <- c("/mnt/data/rprojs/", "~/git/misc/rscripts/", "~/git", getwd()) baseDirTries[ min(which(file.exists(baseDirTries))) ] } }) options(baseDir=baseDir) if (!silent) msgBox("baseDir is ", baseDir, shiftLeft=22) ### ---------------------------------------------------------------------- caught.utilsRS <- try(source(paste0(baseDir, "/utilsRS.r")), silent=TRUE) if (inherits(caught.utilsRS, "try-error")) warning("\n\n utilsRS was **not** loaded.\n\n") if(!exists("as.path")) as.path = function(...) do.call(function(...) paste(..., sep="/"), list(...)) utilsToSource <- c("workspace.R", "ListTransforms.R", "memoryFunctions.R") utilsFolder <- as.path(baseDir, "utils") utilsToSource <- as.path(baseDir, "utils", utilsToSource) caught <- list() for (fil in utilsToSource) caught[[as.character(fil)]] <- try(source(fil)) if (! any(sapply(c(caught, caught.utilsRS), inherits, "try-error"))) { if(!silent) cat("\n\t\tUtils Loaded on Startup\n\n") } else warning ("\n\tSome utils where not loaded\n") } #------------------------------------------------------ JavaTest <- function(stopRun=TRUE, runInit=TRUE) { ## ensures that rJava is up and running. If Java is NOT running and... ## stopRun=T, will throw an error. If stop=False, will throw a warning. ## If runInit=T, will load rJava and run .jinit() prior to running .jcheck() # Load rJava and initialize java if (runInit) { library(rJava) .jinit() } # Run .jCheck errString <- ".jcheck() failed. Please troubleshoot rJava" if (isErr(.jcheck())) { if (stopRun) { stop(errString) } else { warning(errString) } } } isErr <- function(expression) { # Boolean; Tries to evaluate the expresion; returns T if an error is thrown # Args: # expression: Make sure to use expression() to pass an expression (dont use Strings) # Returns: # T if expression throws an Error // F if expression is evaluated without error # NOTE: The actual evaluation of the expression is NOT RETURNED return( inherits(try(eval(expression), silent=T), "try-error") ) } isNumber <- function(x, treat.ZeroLength.asNumeric=FALSE) { # 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)) res <- suppressWarnings(!is.na(as.numeric(x))) if (treat.ZeroLength.asNumeric) res[length(x) == 0] <- TRUE return (res) } 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)) } # --------------------------------------------------- # # # # PASTE FUNCTIONS # # # # --------------------------------------------------- # ## TODO: Put this in the dictionaries file dict.parens <- c("(" = ")", "[" = "]", "{" = "}", "<" = ">") # like paste0, but with collapse="" pasteC <- function(..., C="") paste(..., collapse=C) paste_ <- function(...) paste(..., collapse="_") pasteR <- function(x, n) { ## allow for `pasteR(n)` if (missing(n) && is.numeric(x)) { n <- x x <- "-" } # if n is not a single number, iterate if (length(n) > 1) { if (length(n) == length(x)) return(mapply(pasteR, x, n)) return( sapply(n, function(n1) pasteR(x, n1)) ) } # otehrwise, siple return pasteC(rep(unlist(x), n)) } pasteQ <- function(..., q="'", wrap="(", sep="", collapse=", ") { # Encloses the terms in a quotes. # If `wrap` is not NULL, also adds those to each end. # `wrap` defaults to "("..")" and should be set to NULL/FALSE to turn off # alternates to NULL should be interpreted to NULL if (is.null(wrap) || is.na(wrap) || wrap=="" || identical(wrap, FALSE)) wrap <- NULL # `wrapR` is the closing-equiv of `wrap.` If no such equiv found, use `wrap`. wrapR <- dict.parens[wrap] wrapR <- ifelse(is.na(wrapR), wrap, wrapR) paste0(wrap, paste(q, unlist(list(...)), q , sep=sep, collapse=collapse) ,wrapR) } pasteNoBlanks <- function(..., sep=" ", collapse=NULL, na.rm=FALSE) { dots <- list(...) # remove NAs if(na.rm) dots <- dots[!is.na(dots)] # remove blanks remove <- identical(sep, paste0(dots, sep)) | (nchar(dots)==0) | (lapply(dots, length)==0) dots <- dots[!remove] f <- function(..., sep2=sep, collapse2=collapse){ paste(..., sep=sep2, collapse=collapse2) } # return pasted value return(Reduce(f, dots)) } # ------------------------------------------------------------------ # fwS <- function(vec, n=max(nchar(vec)), space=" ", suffix="", extra=0, align=c("left", "right"), extra.L=0, extra.R=0, space.R=space, space.L=space) { # like fw0, but adds spaces instead of 0's. ## TODO: add `align` argument, and extra.L, extra.R align <- match.arg(align) nc <- nchar(vec) if (align=="right") base <- paste0(pasteR(space, n-nc+extra), vec) else base <- paste0(vec, pasteR(space, n-nc+extra)) paste0(pasteR(space.L, extra.L), base, pasteR(space.R, extra.R), suffix) } # ------------------------------------------------------------------ # fw0 <- function(num, digs=NULL, mkseq=TRUE, pspace=FALSE) { ## formats digits with leading 0's. ## num should be an integer or range of integers. ## if mkseq=T, then an num of length 1 will be expanded to seq(1, num). # # Note that if num is a list, digs will not be automatically compared across the list, and therefore should be manually slected. # TODO 1: put more error check # when num is a list, call recursively. mkseq should not expand the list into seq, unless specifically user sets flag or entire list is just length one element if (is.list(num)) return(lapply(num, fw0, digs=digs, mkseq=ifelse(missing(mkseq), !length(num) > 1, mkseq))) if (!is.vector(num) & !is.matrix(num)) { stop("num should be integer or vector") } # capture the dims and we will put it back dims <- dim(num) # convert strings to numbers num <- as.numeric(num) # If num is a single number and mkseq is T, expand to seq(1, num) if(mkseq && !length(num)>1) num <- (1:num) # number of digits is that of largest number or digs, whichever is max digs <- max(nchar(max(abs(num))), digs) # if there are a mix of neg & pos numbers, add a space for pos numbers # (checking first for 0) # OR if pspace is flagged as TRUE posSpace <- ifelse((min(num) != 0 & sign(max(num)) != sign(min(num)) | pspace==TRUE), " ", "") # return: paste appropriate 0's and preface neg/pos mark ret <- sapply(num, function(x) ifelse(x<0, paste0("-", paste0(rep(0, max(0, digs-nchar(abs(x)))), collapse=""), abs(x)), paste0(posSpace, paste0(rep(0, max(0, digs-nchar(abs(x)))), collapse=""), x) )) # put back in original form. ie, make it a matrix if it was originally. Otherwise, this will just be NULL dim(ret) <- dims return(ret) } # --------------------------------------------------------- # ## THIS IS THE OLDER INTERPRETATION OF fw0. ## SPECIFICALLY FOR HOW IT HANDLES fw(199, digs=2) fw0.older <- function(obj, digs=NULL) { ## formats digits with leading 0's. ## obj should be an integer or range of integers. if (!is.vector(obj)) { stop("Obj should be integer or vector") } # TODO 1: put more error check # TODO 2: clean up the if statements. Consider using recursion # If digs is specified, also consider the obj specified (do not expand to range) if(!is.null(digs)) { sequ <- obj # Otherwise, calculate range, based on length of obj. Then calculate digs } else { if(!length(obj)>1) { sequ <- (1:as.numeric(obj)) } else { sequ <- obj } digs <- nchar(max(sequ)) } # return sapply(sequ, function(x) paste0(paste0(rep(0, max(0, digs-nchar(x))), collapse=""), x)) } #-------------------------------------------- #----------------------------------------------- ## functino to format numerics fw <- function(x, dec=4, digs=4, w=NULL, ...) { ## wrapper to function format(.) format(x, nsmall=dec, digits=digs, width=w, ...) } ## functino to format numerics fw3 <- function(x, dec=3, digs=3, w=NULL, ...) { ## wrapper to function format(.) ret <- format(x, nsmall=dec, digits=digs, width=w, ...) # add names if (length(names(x))) names(ret) <- names(x) if (length(dimnames(x))) dimnames(ret) <- dimnames(x) return(ret) } fwp <- function(x, dec=2, sep=" ", simplify=TRUE, pad=FALSE, symbol="%", justNumbs=FALSE) { # Formats as percentage # justNumbs : if TRUE, just multiplies by 100, rounds and pads # pad: Could be TRUE or a number. # basic settings to return only the number values if (justNumbs) { sep <- symbol <- "" if (missing(pad)) pad <- FALSE if (missing(dec)) dec <- 1 } ret <- sapply(x, function(y) paste(fw3(100*y, dec=dec, digs=1), symbol, sep=sep), simplify=simplify) # add spaces if (pad) { nc <- nchar(ret) max.char <- max(nc) + ifelse(is.numeric(pad), pad, 0) # if pad is a number (as opposed to TRUE), add it ret <- paste0(sapply(max.char-nc, pasteR, x=" "), ret) } # if `justNumbs` then convert back to numeric. However, cannot # pad a numeric, only a string. Thus only convert back if !pad as well. if (justNumbs && !pad) ret <- as.numeric(ret) if (is.null(dim(x)) || !simplify) { if (length(ret) == length(x)) names(ret) <- names(x) return(ret) } # if the original `x` was a matrix, it will now be flat. # set back the original dim & names before returning dim(ret) <- dim(x) dimnames(ret) <- dimnames(x) return(ret) } fwSecs <- function(seconds) { #' Converts a numeric to rounded seconds or minutes. if (!is.numeric(seconds)) stop("`seconds` must be numeric") if (length(seconds) > 1) return(sapply(seconds, fwSecs)) if (seconds < 1) return(paste(roundOutToX(seconds, .001), "seconds")) if (seconds < 10) return(paste(roundOutToX(seconds, .1), "seconds")) if (seconds < 100) return(paste(roundOutToDig(seconds, 1), "seconds")) return(paste(roundOutToDig(seconds/60, 1), "minutes")) } 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) } roundOutToX <- function(obj, x=10) # rounds away from 0 to the nearest x if(x==0) return(round(obj)) else ceiling(abs(obj) / x) * (obj/abs(obj)) * x roundOutToDig <- function(obj, d=1) { x <- floor( 10^(floor(log(obj, 10))-d)) roundOutToX(obj, x) } clipPaste <- function(flat=TRUE) { # equivalent of CMD+v piped through. # # returns whatsever in the OS's clipboard # if flat is TRUE, then it is collapsed into a single element # as opposed to multiple lines con <- pipe("pbpaste", open="rb") ret <- readLines(con, warn=FALSE) if (flat) ret <- paste0(ret, collapse="\n") close(con) return(ret) } clipCopy <- function(txt, sep="") { # equivalent of highlighting txt and hitting CMD+C txt <- paste(txt, collapse="\n") # won't work on linux, etc if(.Pfm=="Linux") return(txt) con <- pipe("pbcopy", "w") writeLines(txt, con, sep=sep) close(con) return(invisible(txt)) } ############################################################### ############################################################### # 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))) } jythonIsGlobal <- function() { # Checks to see if jython is properly set, if not then sets it # # Returns FALSE if jython was not previously set; else returns TRUE testForjython <- try(class(jython), silent=TRUE) if (class(testForjython) == "try-error" | testForjython!="jobjRef") { require(rJython) .jinit() jython <<- rJython() return(FALSE) } return(TRUE) } python <- function(jythonStatement) { # Executes in python the string passed # (Simply a wrapper for an easier way to make python calls) # Arg: # jythonStatement: an executable line of python code of type string # # Returns: # passes through the return from the jython.exec command (generally NULL) jythonIsGlobal() return(jython.exec(jython, jythonStatement)) # OLD: return(jython.exec(jython, paste(jythonStatement))) } pythonGet <- function(pythonObj) { # From Python Environment, Gets the value of pythonObj. # (Simply a wrapper for an easier way to get a python object) # # Arg: # pythonObj: name of object in python whose value will be retrieved & returned # # Returns: # the value of pythonObj in the python environment jythonIsGlobal() return(jython.get(jython, pythonObj)) # OLD return(jython.get(jython, paste(substitute(pythonObj)))) } pythonSet <- function(rObj) { # Sets the value of a python object of same name as rObj to value of rObj. # same as pythonSetDiffName() but with one less argument to have to type # # Arg: # rObj: object in R; value will be assigned to object of same name in python # # # NOTE: when rObj is a string, pythonSet will create # a variable whose name is the value of the string # and whose value is also the value of the string. # # Returns: # passes through the return from the jython.assign command (generally NULL) jythonIsGlobal() return(jython.assign(jython, substitute(rObj), rObj)) } pythonSetDiffName <- function(pythonObj, rObj) { # Sets the value of a python object named pythonObj to that of rObj # # Arg: # pythonObj: name of object in python environment that will receive rObj # rObj: object in R whose value is getting assigned to pythonObj # # Returns: # passes through the return from the jython.assign command (generally NULL) jythonIsGlobal() return(jython.assign(jython, pythonObj, rObj)) } pyParse <- function(strToParse) { # Uses Python to parse a string along any non-char delim # Arg: # strToParse: any string needing parsing # # Returns: # list of parsed strings python("import re") pythonSetDiffName("strToParse123b4c5", strToParse) return(pythonGet(paste("re.findall('\\w+', str(strToParse123b4c5))"))) } form <- function(x, dig=3) { # just a wrapper for format(x), with options defualted to 3 return(as.numeric(format(x, digits=dig, nsmall=dig))) } 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=0, objIsMany=FALSE) { # Inserts obj into list *at* atition at # all existing items in list, form at onward, are moved forward # NOTE: If atition > length(list), obj is inserted at 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 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 } #-------------------- as.path <- function(..., ext="", fsep=.Platform$file.sep, expand=TRUE, verbose=TRUE, stop.if.bad.values=TRUE, show.warnings=TRUE) { # concatenates the `...` into a valid path, accounting for extra slashes and dot-dot's ## ## Depends on: cleanDotDotPath.split() & cleanDotDotPath.combine() # grab the dots, remove any null values. dots <- list(...) # <<<<< This was my old way of checking for NULL, but it missed character(0) etc. >>>>> The new way captures those errors as well # ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # # If the dots are nothing but NULL's, simply return(ext) and exit. # # if (all(is.null(dots))) { # warning("No values sent to create a path or filename from. Returning ", ifelse(all(ext==""), "''.", paste0(" simply the value of `ext`='", paste(ext, collapse=", "), "'.")) ) # return(ext) # } # # # remove any NULL values # # dots <- dots[!sapply(dots, is.null)] # ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # NEW WAY: Once confirmed that it is working, you can get rid of the code for the old way. # dots <- lapply(dots, as.character) dots <- dots[sapply(dots, length)>0] if (!length(dots)) { if (show.warnings) warning("No values sent to create a path or filename from. Returning ", ifelse(all(ext==""), "''.", paste0(" simply the value of `ext`='", paste(ext, collapse=", "), "'.")) ) return(ext) } # ----------------------------------------------------------------------------------------------------------------------------------------------------------------------------------- # # after removing specific NULL values, etc, we may still have lists or vectors that have odd values inside. We may also have NAs if (stop.if.bad.values || show.warnings) { alldots <- unlist(dots, recursive=TRUE) whichbad <- sapply(alldots, function(x) is.null(x) || is.na(x) || length(x) == 0 || nchar(x) == 0) if (any(whichbad)) { # if the only bad value is the last one, it will be treated as a value that should be dropped if (!any(head(whichbad, -1)) && length(alldots)>1) { # if not any of the first ones, alldots <- head(alldots, -1) } else { msg <- paste("Some values sent to `as.path` are peculiar.\n The suspicious values are the following: \n\t", pasteQ(alldots[whichbad], wrap=""), "\n") if (stop.if.bad.values) stop(msg) warning(msg) } } } ## If first argument starts with "http" or "ftp" and `fsep` hasn't been explicitly set, ## Then fsep should be "/". if(any(grepl("^(http|ftp)", as.character(dots[[1]]))) && missing(fsep)) fsep <- "/" # error check if (any(grepl("^/~", dots[[1]]))) stop ("Path cannot start with `/~`\nDid you mean to use simply `~` ?") ## If starts with "..", append getwd() ahead of it. as in `as.path("..", subdir)` # note : `dotdot` refers to folder level `/../subdir` # `dots` refers to R's ellipsis (...) argument if ( any( {wh.dotdot <- grepl("^\\.\\.", dots[[1]])} )) { if (show.warnings && exists("wrkDir") && !identical(wrkDir, getwd())) warning("`wrkDir` and `getwd()` differ. `as.path` is returning value relative to `getwd()`") if (length(dots[[1]]) == 1) # if the first element is not a vector, we can just append the wd to the list and proceed as normal dots <- c(getwd(), dots) else # if however, it is a vector, we need to append only to appropriate elements. # Furthermore, to preserve vectorization capabilities, we need to flatten to a single string, each element within dots dots[[1]][wh.dotdot] <- as.path(getwd(), dots[[1]][wh.dotdot]) } ## If starts with fsep, we will preserve it. startWith <- ifelse(substr(dots[[1]], 1, 1) == fsep, fsep, "") # Clean up the input (removing superfluous slashes, dots, etc) cleaned <- lapply(dots, function(x) { # remove any leading slashes x <- ifelse(substr(x, 1, 1) == fsep, substr(x, nchar(fsep)+1, nchar(x)), x) # remove any trailing slashes lng <- nchar(x) x <- ifelse(substr(x, lng, lng) == fsep, substr(x, 1, lng-1), x) # return x to cleaned x }) ## TODO: this was to prevent some edge case where an element in `cleaned` was blank ## currently, I cannot identify such a case. If found, document it. cleaned <- cleaned[!sapply(cleaned, function(x) identical(nchar(x), integer(0)))] # put back any starting fsep cleaned[[1]] <- paste0(startWith,cleaned[[1]]) # append '.ext' to last item if (!is.na(ext) && !ext=="") cleaned[[length(cleaned)]] <- paste0(cleaned[[length(cleaned)]], ".", gsub("^\\.", "", ext)) # checking for '..' ie: "~/git/" + "../out" ==> "~/out" if(any ( grepl("\\.\\.", cleaned) )) { return(cleanDotDotPath.split(cleaned, fsep=fsep, expand=expand)) } # else putTogether <- do.call(file.path, c(cleaned, fsep=fsep)) if (!expand) return(putTogether) return(path.expand(putTogether)) } cleanDotDotPath.split <- function(pathParts, fsep=.Platform$file.sep, expand=TRUE) { ## PURPOSE: Combine pathParts by taking into account `../` ## eg, if the pathParts is: # list("~/git/nbs", "../../../Shared/Adobe") # output should be: # "/Users/Shared/Adobe" # # pathParts: A list of path-like objects that will be concatenated into a single path string # If it is not a list, it will be coerced into one. # fsep : a character representing the seaparator between path parts. ie, "/" or "\\" # expand : If T, "~" will be expanded, normally to "/Users/usrName/" or similar, as per system # If F, path may be expanded anyway, if the amount of ".."'s require it. # expand "~usr/" if (expand) pathParts <- lapply(pathParts, path.expand) # pathParts should be a list. Coerce if it isn't if (!is.list(pathParts)) pathParts <- as.list(pathParts) # first paste the multi pieces together then split on fsep putTogether <- do.call(file.path, c(pathParts, fsep=fsep)) splats <- strsplit(putTogether, fsep) if (length(splats) == 1) return(cleanDotDotPath.combine(splats[[1]], fsep=fsep, expand=expand)) return(sapply(splats, cleanDotDotPath.combine, fsep=fsep, expand=expand)) } cleanDotDotPath.combine <- function(splat, fsep=.Platform$file.sep, expand=TRUE) { # check for superfluous "", which came from 'dir1//dir2.' # These should be ignored and hence removed # However if splat[1] is "", this came from '/dir1' and should be preserved if (any(splat[-1] == "")) splat <- c(splat[[1]], splat[-1][!splat[-1]==""] ) # now each element in spat is a single directory or a dotdot # identify which are the dotdots. isdotdot <- splat == ".." # check if there are more dotdot's than folders before it. eg: # FALSE FALSE FALSE FALSE FALSE TRUE FALSE FALSE # "~" "git" "nbs" ".." ".." ".." "Shared" "Adobe" if(any(toroot <- cumsum(isdotdot) >= cumsum(!isdotdot))) { ## TODO: This might be incorrect for as.path("..", subdir) # if we hadn't expanded, rerun this function with expand being TRUE if(!expand) return(cleanDotDotPath.combine(pathParts, fsep=fsep, expand=TRUE)) # otherwise.. # the first of the "too many dots" is the new root root <- min(which(toroot)) # keep only those elements of splat after the new root. # adding in `""` which signifies "/" when pasted back splat <- c("", tail(splat, -root)) # re-run this function from the new root return(cleanDotDotPath.combine(splat, fsep=fsep, expand=expand)) } # else: # for each index of dotdot, we are going to remove the index of the dir # that is "right before" it, ie the max of the indecies less than it areDots <- which(isdotdot) # these are the indecies to the dots areDirs <- which(!isdotdot) # these are the indecies to the directories # remove from areDirs, the largest index smaller than dot for(dot in areDots) areDirs <- setdiff(areDirs, which.max(areDirs[areDirs < dot]) ) # replace splat with only the indecies being kept. The `as.list` is for the `do.call` splat <- as.list(splat[areDirs]) # paste it back together with fsep return(do.call(file.path, c(splat, fsep=fsep)) ) } #-------------------------- makeDictFromCSV <- function(csvFile) { # Creates a dictionary out of a CSV file where # col1 of the CSV are the keys and col2 are the values. # # Arg: # dictCSVPath: A path to a CSV file # # Returns a dictionary (list) s|t dict["key"] = "value" # eg: dict["LooonngWooord"] = "shortwrd" c <- read.csv(csvFile) dict <- list(as.character(c[[2]])) names(dict[[1]]) <-(as.character(c[[1]])) rm(c) # keep it clean return(dict[[1]]) } 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) } s <- smry <- summary2 <- function(x, rows=6, cols=6, cmt=TRUE) { # prints out a the first rows & cols of x # if either is negative, prints from the end for that axis # # Also print out the Class, Mode, Typeof of the object cat("\n") print(CMT(x)) cat("\n") # check if x is Multidimensional or not isArr <- ifelse(is.null(dim(x)),FALSE,TRUE) # MULTIDIMENSIONAL if (isArr) { rx <- nrow(x) cx <- ncol(x) cat(" TOTAL ROWS: ", rx, "\t TOTAL COLS: ", cx, "\n\n") #rows to print if (rows < 0) { rowsRange <- rx:max(1, rx+rows) #rows is negative } else { rowsRange <- 1:min(rows, rx) } #cols to print if (cols < 0) { colsRange <- cx:max(1, cx+cols) #cols is negative } else { colsRange <- 1:min(cols, cx) } return(print(x[rowsRange, colsRange])) } # UNI-DIMENSIONAL else { rx <- length(x) cat(" TOTAL ROWS: ", rx, "\n\n") #rows to print if (rows < 0) { rowsRange <- rx:max(1, rx+rows) #rows is negative } else { rowsRange <- 1:min(rows, rx) } return(print(x[rowsRange])) } } c4 <-function(x, rows=20, cols=4, cmt=TRUE) { ## wrapper to function summary2, with rows=20 and cols=4. (hence c4) ## note, calling c4(x, 35) will give 35 rows and 4 cols. (simpler than s(x, 35, 4)) if(is.data.table(x)) if (ncol(x) < 3) return(x) else return(x[ , unique(c( 1:min(ncol(x), (ifelse(missing(rows), 5, rows-2))), ncol(x) + (-1:0) ) ) , with=FALSE ]) # else: summary2(x, rows, cols, cmt) } printdims <- function(X, justTheValue=FALSE) { nm <- as.character(match.call()[[2]]) if (any(grepl("^\\[\\[", nm))) nm <- "[ ? ]" dims <- paste0(nm, ": (", paste(dim(X), collapse=" x "), ")") if (justTheValue) return(dims) else (print(dims)) } #--------------------------------------------# topropper <- function(x) { # Makes Proper Capitalization out of a string or collection of strings. sapply(x, function(strn) { s <- strsplit(strn, "\\s")[[1]] paste0(toupper(substring(s, 1,1)), tolower(substring(s, 2)), collapse=" ")}, USE.NAMES=FALSE) } topropper_withPunc <- function(x) gsub("\\b([a-z])([a-z]+)", "\\U\\1\\E\\2", x, perl=TRUE) ## compare: # topropper("last-one") # [1] "Last-one" # topropper_withPunc("last-one") # [1] "Last-One" #--------------------------------------------# qy <- quity <- function(dir='~/') { ## quits R and saves the .RData and .Rhistory to dir setwd(dir) quit('yes') } qn <- quitn <- function(dir='~/') { ## quits R and saves the .RData and .Rhistory to dir setwd(dir) quit('no') } 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=""))) } pip <- function() { # for broken keyboard, missing pipe cat(" | ") } slash <- function() { # for broken keyboard, missing pipe cat(" \\ ") } 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,]) } makeDictWithIntegerKeys <- function(KVraw, applyLabels=TRUE) { ### problem: if # we want a dict such that dict[aritstid] = source_name # PROBLEM: since sourceid's are integers, dict[sourceid] will return the sourceid'th (nth) item # eg: dict[510] will return the 510th item of dict, not the source whose id is 510 *rather, not necessarily.. # that is, dict[510] != dict["510"] # # this wouldnt be a problem if we can ensure that each sourceid gets loaded # into dict at the position of its integer value # then dict[sourceid] and dict[sQuote(sourceid)] will return the same value # # Args: KVraw should be two-dim matrix with col1==Keys, and col2==Values, # applyLabels: if T, dict will have names st dict["123"] == dict[123]; # if F, dict["123"] is undefined # NOTE: The labels are needed in order to be able to make calls like # which(names(dict) %in% subsetOfKeys) where subsetOfKeys # is some collection of keys and we want the corresponding values # Return: # a one-dim list where dict[key] == value, where key is an integer ## initialize the dict largestK <- max(KVraw[[1]]) # make sure we create enough room in dict dict <- rep(NA,largestK) # note that length(dict) >= length(KVraw) names <- dict ## assign values for (i in 1:nrow(KVraw) ) { dict[as.integer(KVraw[[1]][i])] <- KVraw[[2]][i] names[as.integer(KVraw[[1]][i])] <- as.character(KVraw[[1]][i]) } ## assign labels if option'd if (applyLabels) { names(dict) <- names } return(dict) } 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) } } mgsub <- function(pattern, replacement, x, ..., fixed=TRUE) { # like an mapply on gsub, but done iteratively. if(length(pattern) != length(replacement)) stop("pattern and replacement differ should be the same length") ## TODO: add recycling and error-check for(i in 1:length(pattern)) x <- gsub(pattern[i], replacement[i], x, ..., fixed=fixed) return(x) } cleanChars <- function(text, replacement="_", Whitelist=NULL) { # wrapper for gsub, with regex pre-composed # replaces all non-basic chararcters with replacement (underscore by default) # Whitelist is non-functional for now # TODO if (!is.null(Whitelist)) stop("Whitelist is non-functional") Simple_regex <- "[^0-9a-zA-Z -.]" gsub(Simple_regex, replacement, text) } replaceBadCharsUnderscore <- function(str, WhiteList=NULL) { stop ("use cleanChars() instead") } timeStamp <- function(x=NULL, seconds=FALSE, sep="_", pre.ext=FALSE, frmt="%Y%m%d_%H%M") { # 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 (missing(frmt)) frmt <- ifelse(seconds, "%Y%m%d_%H%M%S", "%Y%m%d_%H%M") ts <- format(Sys.time(), frmt) # 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) } #==========================================================================# #--------------------------------------------------------------------------# # SAVEIT & SAVETHEM & JESUS # # mkSaveFileNameWithPath & dimToString # # # # depends: detectAssignment, timeStamp, as.path # #__________________________________________________________________________# ## TODO: I dont really use this dir setup anymore for data archiving. ## Instead using `jesusForData` along with the `workspace.R` functions. ## Clean this up so it is usable again loadbak <- function(f, env=parent.frame()) # wrapper function for loading from outDir/data_bak/ load(as.path(outDir, "data_bak", as.character(match.call()[[2]])), envir=env) saveit <- function(obj, dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=TRUE, pos=1, addTimeStamp=TRUE, useSeconds=FALSE) { ## Like savethem() but only takes a single obj argument ## The advantage of using saveit() is not having to ## type 'dir=...'. ## Yep, that is all. (this func also was written first then modified to get savethem()) ## ## saves obj to file of type .Rda and with ## name of file same as name of obj + time stamp ## in location: dir ## subDir: if TRUE, will create subdirectory data_bak ## inside dir and use that folder. (if alreaddy exists, will just use) ## ## returns: the path/to/file.Rda where obj was saved # get object from the parent environment objName <- as.character(match.call()[[2]]) #----- EVAL IN OBJ NAME ------# ## this allows the use of, eg, saveit(eval(paste0("model.", bestVal)), outDir) # that is, if obj begins with eval(), then eval-parse it for the correct string if(objName[[1]]=="eval") objName <- eval(parse(text=objName)) #----- EVAL IN OBJ NAME ------# #----- ERROR CHECKS ------# # If multiple arguments passed to saveit, this may detect the mistake. if(!is.character(dir) || !is.logical(subDir)) warning("Did you mean to use savethem() instead of saveit()?") # If any of the assignment operators are found in the list, throw an error if(detectAssignment(objName)) stop("Cannot assign in the call to this function.") #----- ERROR CHECKS ------# # use subdirectory data_bak unless indicated not to (create it if needed) if (subDir) { dir <- as.path(dir, "data_bak") } # Create dir if needed dir.create(dir, recursive=TRUE, showWarnings=FALSE) # Create Suffix (based on dim, if applicable, and append timeStamp if required) suffix <- dimToString(objName, pos=pos+1) if(addTimeStamp) suffix <- paste0(suffix, "-", timeStamp(seconds=useSeconds)) # create the filename, cleaning objName of bad chars fileName <- paste0(cleanChars(objName),suffix,".Rda") fileWithPath <- as.path(dir,fileName) # Save the object do.call(save, args=c(list(objName), envir=parent.frame(pos+1), file=fileWithPath) ) # return the path/to/file return(fileWithPath) } #------------------------------------------------------------------------# ## WRAPPER jesusForData <- function(..., dir=dataDir, sub=FALSE, stampFile=TRUE, stampDir=FALSE, pos=1, envir="") { # If no objects specified, save all the DT's if (length(list(...)) > 0L) jesus(..., dir=dir, sub=sub, stampFile=stampFile, stampDir=stampDir, pos=pos+1, envir=envir) else { nms <- lsos(type="DT", b=1)[, Name] jesus(eval(nms), dir=dir, sub=sub, stampFile=stampFile, stampDir=stampDir, pos=pos+1, envir=envir) } } ### savethem <- jesus <- function(..., dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=sub, pos=1, sub=TRUE, stampDir=TRUE, stampFile=FALSE, summary=TRUE, envir="", verbose=TRUE) { ## Like saveit() but can take multiple objects as arguments ## ## saves objects passed as (...) arguments to file of type .Rda and with ## name of file same as name of obj + time stamp ## in location: dir ## subDir: if TRUE, will create subdir data_bak ## inside dir and use that folder. (if alreaddy exists, will just use) #S sub: a synonym for subDir. (since use of ... does not allow for partial matches) ## ## returns: the path/to/file.Rda where objects were saved start.time <- proc.time() ## NOTE TO SELF: You cannot use `dots.list` and `list(...)` interchangeably in substitute ## dots.list <- list(...) # get objects from dots objNames <- as.list(as.character(substitute(list(...)))[-1L]) # check for arguments being (eval(...)) whichAreEval <- sapply(objNames, function(x) grepl("^eval\\(.+\\)$", x)) if (any(whichAreEval)) { # confirm they are calls whichAreCalls <- sapply(substitute(list(...))[-1], is.call) # proceed only if they match if (identical(whichAreCalls, whichAreEval)) { objNames2 <- list(...)[whichAreCalls] objNames <- unlist(c(objNames2, objNames[!whichAreCalls])) } } ### TODO: June 2013. Apparently the `eval(vector.of.obj.names)` was not working. I wrote the part immediately above this. ### Confirm all is working correctly. # -- check this -- # # TODO: double-check pos value. It might be off. # -- check this -- # # check any value is eval(XX), if so parse it. Collect all values into a single vector. # -- check this -- # objNames <- unlist( lapply(objNames, function(ob) # -- check this -- # if(substr(ob, 1, 5)=="eval(") eval(parse(text=substr(ob, 6, nchar(ob)-1)), envir=ifelse(is.environment(envir), envir, parent.frame(pos+1)) ) else ob # -- check this -- # ) ) # No need to save any object twice objNames <- unique(objNames) #----- ERROR CHECKS ------# # If any of the assignment operators are found in the list, throw an error if(detectAssignment(objNames)) stop("Cannot assign in the call to this function.") #----- ERROR CHECKS ------# # Check that the objects to be saved exist NotPresent <- !(sapply(objNames, exists)) if (any(NotPresent)) { warning("The following objects were not found and hence could not be saved:\n ", paste(objNames[NotPresent], collapse=" "), "\n") objNames <- objNames[!NotPresent] } # if flag is true, add appropriate subdir if (subDir) dir <- as.path(dir, "data_bak") # add timeStamp to dir if required if(stampDir) dir <- paste0(as.path(dir), "_", timeStamp()) # Create dir if needed dir.create(as.path(dir), recursive=TRUE, showWarnings=FALSE) # create the file paths, cleaning objNames of bad chars fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, dir=dir, addTimeStamp=stampFile) # Save the object tryCatch(mapply(function(obj, thefile) # note that with the save+do.call we are going in an extra two environments, hence pos + 2 (also, tested with pos+1, pos+3, both wrong) do.call(save, args=list(obj, envir=parent.frame(pos+2), file=thefile) ) # pos + 3 will be off if , objNames, fileWithPath), error = saveErrorHandle) ## This does NOT work. # filesCreated <- do.call(saveit, args=list(objNames, pos=pos+1, dir=dir, addTimeStamp=stampFile)) # return(filesCreated ) # output time it took to complete end.time <- proc.time() if (verbose) { cat("Time it took to save the files: ", fwSecs( (end.time-start.time)[["elapsed"]] ), ".\n\n", sep="") # print(structure(end.time - start.time, class = "proc_time")) # cat("\n\n") } # return the path/to/files or just a summary if (summary) ## `summary=` was called `summary2=` for some reason..? I changed it. Hope this doesnt cause bugs in other programs return(list(summary=paste(length(fileWithPath), "files were created in:"), dir=dir)) return(fileWithPath) } #__________________________________________________________________________# #--------------------------------------------# saveErrorHandle <- function(e) { if(grepl("error writing to connection", e)) { warning("Could not write to connection. Object has not been saved.\n Check that the disk is not full.") } else stop(e) } mkSaveFileNameWithPath <- function(objName, dir, pos=2, addTimeStamp=FALSE, ext=".Rda") { ## This is a helper function for jesus() # error check if (!is.character(objName)) stop("objName should be character. Did you forget quotation marks?") # Create Suffix (based on dim, if applicable, and append timeStamp if required) suffix <- dimToString(objName, pos=pos+1) if(addTimeStamp) suffix <- paste0(suffix, "-", timeStamp()) # create the filename, cleaning objName of bad chars # return the file path as.path(dir, paste0(cleanChars(objName),suffix), ext=ext) } #--------------------------------------------# dimToString <- function(objName, pos=2, prefix="-", markers="!") { # gets the dimensions of an object and converts it to a string; if dim is NULL returns "" # error check if (!is.character(objName)) stop("objName should be character. Did you forget quotation marks?") obj.dim <- dim(get(objName, envir=parent.frame(pos)) ) suffix <- "" if (!is.null(obj.dim)) suffix <- paste0(prefix, markers, paste(obj.dim, collapse="x"), markers) return(suffix) } #--------------------------------------------# stringToDim <- function(fileName, pos=2, prefix="-", markers="!", simplify=FALSE) { # extracts the dims from a file name, if the file was saved using jesus() or saveit() # example file name: "artist_and_dates-!47082x7!-20130607_1846.Rda" # error check if (!is.character(fileName)) stop("objName should be character. Did you forget quotation marks?") # string pattern to search for pat <- paste0(markers, ".*", markers) dims <- stringr::str_extract(string=fileName, pattern=pat) # remove the markers dims <- gsub(markers, "", dims) # split on the x dims <- strsplit(dims, "x") # convert to numeric dims <- lapply(dims, as.numeric) # convert to numeric, simultaneously adding names if 2-dimensional dims <- lapply(dims, function(x) if (length(x)==2) setNames(as.numeric(x), c("rows", "cols")) else as.numeric(x)) # dims will be a list. However, if only one file name sent we want to return a vector if (length(fileName)==1) return(dims[[1]]) if (!simplify) return(dims) # else, simplify # if not all the same length, cannot simplify. Return the list as is if (!areEqual(lapply(dim, length))) return(dims) # otherwise, simplify return(data.frame(do.call(rbind, dims))) } #--------------------------------------------# #__________________________________________________________________________# #==========================================================================# 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]) } #/@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@@\# ## DIRECTORY FUNCTIONS ## ### PURPOSE OF THE xxxxsource(file) FUNCTIONS ARE TO BE ABLE ### TO CALL A FILE MORE RAPIDLY WITHOUT HAVING TO RETYPE PATHS devsource <- function(file, dir="~/Dropbox/dev/R/!ScriptsR/"){ # Calls source on file located in dev folder source(paste(dir,file,sep="")) } gitsource <- function(file, dir="~/git/misc/rscripts/"){ # Calls source on file located in git folder source(paste(dir,file,sep="")) } homesource <- function(file, dir="~/"){ # Calls source on file located in home folder source(paste(dir,file,sep="")) } ## ---------------------------------------------## ## FUNC FORM ## ## FOR SOURCING URLS ## ## note the difference in envir=(.) ## ## ## ## ---------------------------------------------## source.url <- function(...) { # load package require(RCurl) urls <- list(...) eval(parse(text=getURL(urls, followlocation=TRUE, cainfo=system.file("CurlSSL", "cacert.pem", package="RCurl"))), envir=parent.frame(1)) } ## ---------------------------------------------## #####%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%######## ### ---------------------------------------------------------------------------- ### BATCH ASSIGN ### ### Source: ### http://strugglingthroughproblems.wordpress.com/2010/08/27/matlab-style-multiple-assignment-in%C2%A0r/ ### ### # Generic form '%=%' = function(l, r, ...) UseMethod('%=%') ### ### # Binary Operator '%=%.lbunch' = function(l, r, ...) { Envir = as.environment(-1) if (length(r) > length(l)) warning("RHS has more args than LHS. Only first", length(l), "used.") if (length(l) > length(r)) { warning("LHS has more args than RHS. RHS will be repeated.") r <- extendToMatch(r, l) } for (II in 1:length(l)) { do.call('<-', list(l[[II]], r[[II]]), envir=Envir) } } ### ### # Used if LHS is larger than RHS extendToMatch <- function(source, destin) { s <- length(source) d <- length(destin) # Assume that destin is a length when it is a single number and source is not if(d==1 && s>1 && !is.null(as.numeric(destin))) d <- destin dif <- d - s if (dif > 0) { source <- rep(source, ceiling(d/s))[1:d] } return (source) } ### ### # Grouping the left hand side g = function(...) { List = as.list(substitute(list(...)))[-1L] class(List) = 'lbunch' return(List) } ### ### ### ---------------------------------------------------------------------------- ### ### TO EXECUTE: ### Group the left hand side using the new function 'g()' ### The right hand side should be a vector or a list ### Use the newly-created binary operator '%=%' ### ### eg: g(a, b, c) %=% list("hello", 123, list("apples, oranges")) #### ### ---------------------------------------------------------------------------- #####%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%######## #_________________________________________# #%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%%% #-----------------------------------------# # cordl, rmDupLines, paraLineChop # #_________________________________________# #-----------------------------------------# #-------------------------- rmDupLines <- function(obj, trim=T) { # removes duplicate lines from obj and returns the modified object. # especially useful for captured output of summary.lm() # trim only applies to vectors (ie, null dim) if (!is.null(dim(obj))) return(obj[!sapply(seq(obj)[-1L], function(i) obj[i,]==obj[i-1,])]) if (trim) { filler <- sapply(obj, identical, "", USE.NAMES=FALSE) obj <- obj[min(which(!filler)):max(which(!filler))] } return(obj[!sapply(seq(obj)[-1L], function(i) obj[[i]]==obj[[i-1]])]) } #-------------------------------------------------------- cordl <- function(..., length=NULL, justSize=FALSE, crop=TRUE, chop=TRUE) { # Capture Output, Remove Duplicate Lines, wrapper function. # Will run paraLineChop unless either of crop or chop are FALSE # crop and chop serve the same purpose. Allowing for synonyms # for forgetful programmers. ret <- rmDupLines(capture.output(eval(substitute(...)))) if (!crop) return(ret) return(paraLineChop(ret, length=length, justSize=justSize)) } #-------------------------------------------------------- paraLineChop <- function(so, length=NULL, lines=NULL, justSize=FALSE) { # chops up the lines in a capture.ouput paragraph to length # so is some output from capture.output # # if justSize, then will output value of chop and how many lines will be chopped # if user provided a length, use that. Else calculate it as a weighted average if (!is.null(length)) { chop <- length feather <- 0 } else { feather <- 5 lngs <- sort(nchar(so)) lngs <- lngs[!lngs == 0] # we want to trim, but only if there is something to tirm L <- length(lngs) trm <- ceiling(max(1, .15*L, .08*L)) weigtd <- mean(lngs[-(1:trm)]) chop <- round(mean(c(lngs[L-trm], mean(lngs[-(1:trm)])))) + 6 } # if no value for chop determined if (is.na(chop)) { warning("couldnt chop") return(so) } # determine which lines need cropping lines <- nchar(so) > chop if (justSize) return (c(lines=sum(lines), chop=chop)) # if there are no lines to crop, return the thing now if(!any(lines)) return(so) matches <- regexpr(" ", substr(so[lines], chop-11, chop+feather)) # TODO: Deal with NA by chopping at chop-1, then adding a hyphon matches[matches<0] <- NA # Mark the specific spot in each line where the chop will happen markers <- chop-11 + matches # 2nd Halfs sublines <- substr(so[lines], markers, nchar(so[lines])) # add some tabs sublines[nchar(sublines) < (chop - 8)] <- paste0(tbs(2), sublines[nchar(sublines) < (chop - 8)]) sublines[nchar(sublines) < (chop - 4)] <- paste0(tbs(1), sublines[nchar(sublines) < (chop - 4)]) # 1st Halfs so[lines] <- substr(so[lines], 1, markers-1) numbLines <- length(sublines) for (j in seq(numbLines)) { antij <- numbLines - j +1 i <- which(lines)[[antij]] tail <- seq(i+1, length(so)) # error prevention for the last line, so that we dont have leng:(leng+1) if (i == length(so)) tail <- i so[tail+1] <- so[tail] so[i+1] <- sublines[[antij]] } # if any long lines remain, recurse if (any(nchar(so) > chop)) return(paraLineChop(so, length=chop)) return(so) } #_________________________________________# #---------------------------------------# #_________________________________________# ### 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))] } #===================================================================# # --------------------------------------- # # # #------------------# # DATA TABLE UTILS # #------------------# #_________________________________________# tbls <- function(envir=.GlobalEnv) # shorter tables() summary with column count tables(env=envir, silent=TRUE)[,list(NAME, MB, NROW, NCOL= 1 + stringr::str_count(COLS, ","), KEY)] colquote <- function(colNamesAsStrings) { # Converts a vector of strings to a quoted (expression) list. # eg: converts: c("colName1", "colName2") # to: quote(list(colName1, colName2)) as.call(lapply(c("list", colNamesAsStrings), as.symbol)) } #---------------# uniqueRows <- function(DT) { # IF DT IS KEYED, FUNCTION ACTS SIMILAR TO unique.data.frame(.) # If not keyed (or not a DT), use regular unique(DT) if (!haskey(DT) || !is.data.table(x) ) return(unique(DT)) .key <- key(DT) setkey(DT, NULL) setkeyE(unique(DT), eval(.key)) } getdotsWithEval <- function () { dots <- as.character(match.call(sys.function(-1), call = sys.call(-1), expand.dots = FALSE)$...) if (grepl("^eval\\(", dots) && grepl("\\)$", dots)) return(eval(parse(text=dots))) return(dots) } setkeyE <- function (x, ..., verbose = getOption("datatable.verbose")) { # SAME AS setkey(.) WITH ADDITION THAT # IF KEY IS WRAPPED IN eval(.) IT WILL BE PARSED if (is.character(x)) stop("x may no longer be the character name of the data.table. The possibility was undocumented and has been removed.") #** THIS IS THE MODIFIED LINE **# # OLD**: cols = getdots() cols <- getdotsWithEval() if (!length(cols)) cols = colnames(x) else if (identical(cols, "NULL")) cols = NULL setkeyv(x, cols, verbose = verbose) } #_________________________________________# #-------------------------------------# ## FUNCTIONS #-------------------------------------# shift <- function(x) c(x[-1], x[1]) shiftb <- function(x) c(x[length(x)], x[-length(x)]) 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))) } `%ni%` <- Negate(`%in%`) # wrapper for use in *ply functions is.allNA <- function(x) all(is.na(x)) invDict <- function(dict) # inverts a dictionary (ie, swapping the names with the values) setNames(names(dict), dict) setNamesDict <- function(DT, dict, replaceMissing=NULL, silent=FALSE) { # Replaces names of DT with values of `dict` where ever there is a match # between `names(dict)` and `names(DT)` # dict should be "oldColumnName" = "newColumnName" # If replaceMissing is specified, column names of DT which are not present # in dict will be replaced with the value of replaceMissing nm <- names(DT) # check if dict needs to reversed if(sum(dict %in% nm) > sum(names(dict) %in% nm)) { dict <- setNames(names(dict), dict) if (!silent) warning("inverting dictionary") } # check if there are no matching values matched <- nm %in% names(dict) if (!any(matched)) { if (!silent) warning("No values in the dict match the column names of the data.table") return(FALSE) } # Only partial matches... if (!all(matched)) { # optionally warn: if (!silent) warning("Not all names present: ", sum(!matched), " missing", ifelse(missing(replaceMissing), ".", " and being replaced.")) # optionally replace missing values if (!missing(replaceMissing)) setnames(DT, nm[!matched], paste(replaceMissing, 1:sum(!matched), sep=".")) } setnames(DT, nm[matched], dict[nm[matched]]) return(TRUE) } uniqueKeys <- function(DT) { # returns all unique keys of a given data.table if (!is.data.table(DT)) stop ("DT passed to `uniqueKeys(DT)` is not a data.table") 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 --------# areEqual.slow <- function(x, na.rm=TRUE, checkNames=TRUE, debug=FALSE, silent=FALSE) { # checks if all elements in a single vector are equal # returns TRUE / FALSE ## Debugging if (debug) browser() # check input type if(!is.null(dim(x)) && !is.matrix(x)) stop("x must be a vector, a list, or a matrix") # All the dims should be equal (even if NULL). # This avoids having to check all of the values if (!all( duplicated( lapply(x, dim)[-1] ) )) { return(FALSE) } if (!checkNames) { ## data.tables have to be handled differently if (is.data.table(x) || is.data.table(x[[1]])) { x <- copy(x) setattr(x, "names", NULL) for (i in seq_along(x)) ## cannot unname(x[[i]]) for certain DTs (might be bug). Instead, give them all the same name. setattr(x[[i]], "names", paste0("X", seq_along(length(x[[i]]))) ) } else { x[] <- unname(x) if (length(x[[1]]) > 1) x <- lapply(x, unname) } } if(na.rm) x <- x[!is.na(x)] # Compare each emelent in x against x[[1]]. They should all be the same. ret <- sapply(x, all.equal, x[[1]]) # If there were some that were not the same, ret will have a value other than T/F # hence we need to check first that it is logical, and then that it is TRUE all(sapply(ret, function(y) is.logical(y) && y)) } areEqual <- function(x, na.rm=TRUE, tolerance = .Machine$double.eps ^ 0.5 , NoWarnings=FALSE, checkNames=FALSE, NoWarningsName=NoWarnings, debug=FALSE) { # Depends on: areEqual.slow() # # checks if all of the elements of a vector, list, or matrix are equal # if checkNames is on, and the names are different, no further checks are made. # Returns TRUE / FALSE (does not give info on what is not equal) # check input # #--------------------------------------# if(!is.null(dim(x)) && !is.matrix(x)) stop("x must be a vector, a list, or a matrix") if(!length(x)) { if (!NoWarnings) warning("x is length 0") return(TRUE) } #--------------------------------------# ## Debugging if (debug) browser() # if we are checking names, check those first. # all but the first element should be duplicates if (checkNames && !all(duplicated(names(x))[-1])) { # note: `all()` returns TRUE for `logical(0)` if(!NoWarningsName) warning("Names differ, not checking any further.") return(FALSE) } # if x is a list of list, we need to compare all of the elements against themselves. # Thus use the slower method, which iterates over each element in the list if(length(x[[1]]) > 1) { ## TODO: Insert check for `all(duplicated(names(x))[-1])` <~~ When should this work? return(areEqual.slow(x, na.rm=na.rm, checkNames=checkNames, debug=debug)) } # check if x is an empty set if (length(x)==0) { if (!NoWarnings) warning("x has no elements. Returning TRUE by default.") return(TRUE) } # check if the whole vector is nothing but NA's. if (all(NAs <- is.na(x))) { # check to see if na.rm is flagged on. In which case, that would leave the empty set if (na.rm && !NoWarnings) warning("`na.rm` is flagged on, but the vector is nothing but `NA`s. `TRUE` was returned by default.") return(TRUE) } # NA's found in previous if statment if(na.rm) x <- x[!NAs] # if x is a factor, we will compare its numeric value if (is.factor(x)) x <- as.integer(x) # otherwise, calculate the range and compare the max and the min. # Note that this works even if `x` is `character` rng <- range(x, na.rm=na.rm) # if we are not checking the names, remove the names if(!checkNames) rng <- unname(rng) ## TODO: I had this next portion ni here before adding the check for `all(is.na(x))` (two sections up) ## I think this is no longer needed, but not certain. Specifically, the `is.infinite` part. ## When else could I get unexpected infiinities? # # if we're not removing NA's we need to check for all NA # if(all(is.na(rng)) || all(is.infinite(rng))) # return(all(is.na(x))) # else: ret <- all.equal(rng[[1]], rng[[2]], tolerance=tolerance) # all.equal will not return a logical value if they are not equal return(is.logical(ret) && ret) } 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)) } printBox <- function(x, width=68, dash="~", sides="#", crop=FALSE, topspace=0, bottomspace=0, tabs=1, header="") { splat <- splitToWidth(x, width) ncs <- nchar(splat) # Add header if given if (!is.na(header) && nchar(header)) splat <- c(Header, splat) # should the total width be based on the width param or # instead cropped down to the longest line mx <- ifelse(crop, max(ncs), width-2) # add spacer lines ## TODO: splat <- c(rep("", topspace), splat, rep("", bottomspace)) # Add tabs. Converting numerics to string of spaces. if(is.numeric(tabs)) tabs <- pasteC(rep(" ", tabs)) splat <- paste0(tabs, splat) # create line of dashes & add to splat dashes <- pasteC(rep(dash, mx)) splat <- c(dashes, splat, dashes) # align text, padding with whitespaces padded <- alignText(splat, halign="left", tabs=tabs) final <- paste(sides, unlist(strsplit(padded, "\n")), sides, collapse="\n") cat(final) } 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.logical(x)) return(identical(x, FALSE)) if (is.character(x)) return(toupper(x)=="F") 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)) } # wrapper of paste call with defaults paste.call <- function(ordr) { if(inherits(ordr[[1]], "name")) ordr <- ordr[-1] paste0("(", paste(ordr, collapse=", "), ")") } # ------------ # 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) # ----------------------------------------------------------------------------------------------- # # This is for the findFnsInFile() that gets thrown off by the extra paren string above # ignoreThis <- ")" rm(ignoreThis) # ----------------------------------------------------------------------------------------------- # } 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)) } # ------------------------------------------------------------------------ # # Wrappers for importing data form SO questions # r.t <- function(x=clipPaste(), header=TRUE, sep=NULL, to=NULL, value=!(is.character(to)), pos=1, file=NULL) { mc <- match.call() if(missing(to) && length(mc) > 1 && !(is.character(mc2 <- mc[[2]])) && names(mc)[[2]]=="x") { to <- as.character(mc2) if (is.null(file)) x=clipPaste() value <- ifelse(missing(value), FALSE, value) } if(!missing(to) && !is.character(to)) to <- as.character(substitute(to)) args <- list(file=file, text=x, header=header, stringsAsFactors=FALSE, sep=sep) args <- args[!sapply(args, is.null)] ret <- do.call(read.table, args) if (length(to) && !is.na(to)) { assign(to, ret, envir=parent.frame(pos)) cat("Assigned to", to, "\n\n") } if (value) return(ret) return(invisible(TRUE)) } r.d <- function(x=clipPaste(), header=TRUE, sep=NULL, to=NULL, value=!(is.character(to)), pos=1, file=NULL) { mc <- match.call() if(missing(to) && length(mc) > 1 && !(is.character(mc2 <- mc[[2]])) && names(mc)[[2]]=="x") { to <- as.character(mc2) if (is.null(file)) x=clipPaste() value <- ifelse(missing(value), FALSE, value) } if(!missing(to) && !is.character(to)) to <- as.character(substitute(to)) ret <- data.table(r.t(x=x, header=header, sep=sep, to=NULL, value=TRUE, pos=pos+1, file=file)) if (length(to)) { assign(to, ret, envir=parent.frame(pos)) cat("Assigned to", to, "\n\n") } if (value) return(ret) return(invisible(TRUE)) } # ------------------------------------------------------------------------ # howManyNAs <- function(x, returnPercentage=FALSE) { if (exists("data.table") && is.data.table(x)) if (returnPercentage) return(x[, c(lapply(.SD, function(col) sum(is.na(col)) / .N )) ]) else return(x[, c(lapply(.SD, function(col) sum(is.na(col)))) ]) if (is.data.frame(x)) { if (returnPercentage) warning("Currently, `returnPercentage` is not implemented for data.frame's.\nReturning absolute counts instead.") return(as.data.frame(c(lapply(x, function(col) sum(is.na(col))) ))) } if (is.list(x)) { if (returnPercentage) warning("Currently, `returnPercentage` is not implemented for lists.\nReturning absolute counts instead.") return( c(lapply(x, function(col) sum(is.na(col))) )) } if (returnPercentage) return(sum(is.na(x)) / length(x)) return(sum(is.na(x))) } 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)] ) } seasonFromDate <- function(D, factors=TRUE) { # given a date, return a factor/string of the corresponding Season # grab the month from the date M <- lubridate::month(D) # list of season values, in order Seasons <- c("Winter", "Spring", "Summer", "Fall") # Compute the numerical season-value M.as.season <- ((M %% 12) %/% 3) + 1 if (factors) return(factor(M.as.season, levels=c(1, 2, 3, 4), labels=Seasons)) return(Seasons[M.as.season]) } revString <- function(x) sapply(lapply(strsplit(x, NULL), rev), paste, collapse = "") mds <- function(includeInput=TRUE, x=clipPaste()) { mkdsh(x=x, includeInput = !isFALSE(includeInput) ) } mkdshr <- function(x=clipPaste(), space=TRUE, pound="#", dash="-", leftSpace=TRUE, includeInput=TRUE , top=TRUE, minWidth=20, align=NA, mindent=4, dontSmoothPreSpace=FALSE , fancy=FALSE, match=FALSE) { ## This function takes a header that contains space to its left and adds equal space to the right. ## TODO: Match does not work, and it will not work unless I strip any closing pounds. ## this is the output of spacecnt if(exists("spacecntoutputvalues")) { mindent <- spacecntoutputvalues[["mindent"]] minWidth <- spacecntoutputvalues[["minWidth"]] # this is a temp workaround until i properly account for pound spaces if (spacecntoutputvalues[["totalLength"]] - spacecntoutputvalues[["minWidth"]] == 4) minWidth <- minWidth + 2 suppressWarnings(rm(spacecntoutputvalues, envir=.GlobalEnv)) if (missing(top)) top <- FALSE } ## TODO: double check minWidth & mindent ## Currently, mindent is one too many, thus subtracting one mindent <- max(0, mindent-1) mc <- match.call() # for shorthands, we're interested in evaluating what was typed at the console. # if the call came in through a wrapper, we want to evaluate that if (as.character(sys.call(1)[[1]]) == "mr") mc <- match.call(call=sys.call(1)) # if there was at least one argument, then we will evaluate it mc2 <- if (length(mc) > 1) mc[[2]] else NULL ## Shorthands, allow for the first argument to be `align` or `top` if (is.numeric(mc2)) { minWidth <- mc2 x <- clipPaste() } else if(!is.null(mc2) && !is.logical(mc2)) { mc2 <- paste(as.character(mc2), collapse="") m <- substr(tolower(mc2), 1, 1) if (m %in% c("l", "c", "r", "n") && length(mc2) < 8) { # "n" for "no align" align <- m x <- clipPaste() } else if (tolower(mc2)=="match") { match=TRUE x <- clipPaste() } else if (tolower(mc2)=="top") { x <- clipPaste() top <- TRUE } else if (tolower(mc2)=="x") { x <- clipPaste() } } ## this allows to quickly set the other params in the function call if (x[[1]]=="x") x <- clipPaste() # for debugging, hold on to the original orig <- x # Collapse if multiple lines if (length(x) > 1) { x <- paste(x, collapse="\n") } ## remove any trailing line-break (normally from copy+pasting one extra line break) x <- gsub("\\n$", "", x) ## TODO: Had this in here for some reason. Cannot remember why. Taking it out for now. # x <- gsub("\\\\n*", "", x) # I dont remember why these are here, other than there was a use case that called for it. # Split up the lines x <- strsplit(x, "\n")[[1]] # remove any trailing spaces x <- sub("\\s*$", "", x) # any blank lines will get a starting pound, if all others have starting pounds blankLines <- which(x=="") if (match) { # identify the longest line with a closing pound minWidth <- max(nchar( grep(paste0(pound, "$"), x, value=TRUE) )) } # Bank & Strip any pre-white spaces wherePreSpace <- regexpr("^\\s*", x) ## Find it preSpace <- substr(x, wherePreSpace, attr(wherePreSpace, "match.length")) ## Bank it x <- substr(x, attr(wherePreSpace, "match.length")+1, nchar(x)) ## Strip it # Bank & Strip any opening pounds prePound <- regexpr(pattern=paste0(pound, "+(%|\\*)*"), x) ## Find it leftPound <- substr(x, prePound, attr(prePound, "match.length")) ## Bank it x <- substr(x, attr(prePound, "match.length")+1, nchar(x)) ## Strip it # Bank & Strip the main space whereSpace <- regexpr(pattern="^\\s+", x) ## Find it LSpace <- substr(x, whereSpace, attr(whereSpace, "match.length")) ## Bank it x <- substr(x, attr(whereSpace, "match.length")+1, nchar(x)) ## Strip it ## add Pound to any blank lines leftPound[blankLines] <- names(which.max(table(leftPound))) # add top & bottom blank lines, if needed if (top) { x <- c("", x, "") topAndBottom <- function(vec, n=1) return(c(head(vec, n), vec, tail(vec, n))) leftPound <- topAndBottom(leftPound) LSpace <- topAndBottom(LSpace) } # for aligning left or right, extra spaces will be needed for pounds of differring widths poundPadding.count <- max(nchar(leftPound)) - nchar(leftPound) # total width of each line, minus any leftspace widths <- nchar(x) + 2 * (nchar(LSpace) + nchar(leftPound) + poundPadding.count) # padding left and right # the minimum width for all lines is the max amongst the requested width & all the widths minWidth <- ifelse(match, minWidth, max(widths, minWidth)) # if we are matching, then we stick to the minwidth ##$ TODO: CHECK FOR LONG LINES --- # Is the longestLine the longest padded pound ##$ TODO: CHECK FOR LONG LINES --- # long lines are any where they are within the poundPadding of the longest pound ##$ TODO: CHECK FOR LONG LINES --- widths - 2* nchar(leftPound) ##$ TODO: CHECK FOR LONG LINES --- longestLine <- intersect(which(nchar(x) == max(nchar(x))), which(nchar(leftPound) == max(nchar(leftPound)))) # how many spaces does each line need (note that the poundPadding gets compensated for here and in the switch statement) spacesNeeded <- minWidth - (nchar(x) + 2 * nchar(leftPound) ) + max(poundPadding.count) # why 2*padding? In case the longest line also has the most ## TODO: look at this part in the next line: `min(spacesNeeded - poundPadding.count)` Is that supposed to be minus? If so, why the `min`? # pad the spaces need with minimum of indent spacesNeeded <- spacesNeeded + max(0, (2*mindent) - min(spacesNeeded - poundPadding.count)) # if centering, divide spaces in half, otherwise just cound how many spaces on left, so that we know how many remain for right # if left align, use the smallest space for which there is text (ie nchar(x) > 0) # Left & Right aligns need to be adjusted for differing lengths of pounds. (Center is not neccssary) ncls <- nchar(LSpace) ncls.min <- ifelse(any(ncls > 0), min(ncls[ncls > 0]), 0) # find the smallest ncls above zero, if it exists. minSpace <- max(mindent, ncls.min) # check if any "should be" indented (6 Spaces more than the smallest non-zero space) extraIndent <- minSpace * as.integer(ncls > ncls.min+6) # calculate the number of spaces need on the LEFT and on the RIGHT LSpace.count <- switch(substr(tolower(align), 1, 1), l = {rep( minSpace, length(spacesNeeded)) + poundPadding.count + extraIndent}, r = {spacesNeeded - (minSpace + poundPadding.count + extraIndent)}, c = {spacesNeeded / 2}, ncls ) LSpace.count <- floor(LSpace.count) RSpace.count <- spacesNeeded - LSpace.count # Create the spaces for each side LEFT <- sapply(LSpace.count, pasteR, x=" ") RIGHT <- sapply(RSpace.count, pasteR, x=" ") # add the pounds back in LEFT <- paste0(leftPound, LEFT) RIGHT <- paste0(RIGHT, revString(leftPound)) # construct into single lines x <- paste(LEFT, x, RIGHT) ## Now all that is missing is the top and bototm dashes ## and the preSpace on the left if (top) { # if the leftPound are all the same length and all longer than length of pound, add a nice extra space nclp <- nchar(leftPound) addspace <- (fancy || (length(x) > 8 && all(nclp > length(pound)) && mean(nclp)==nclp[[1]])) # if we're not adding a space, the pound to use should be as long as the shortest pound already present if(!addspace) pound <- pasteR(pound, max(1, min(nclp)) ) # use a slighlty shorter x, if we're adding space x.use <- ifelse (addspace, substr(x, 2, nchar(x)-1)[[1]], x[[1]]) # create top & bottom bar from `mkdsh()` bar <- mkdsh(x.use, space=space, pound=pound, dash=dash, leftSpace=leftSpace, includeInput=FALSE ) # add in the space bar <- ifelse(addspace, paste0(" ", bar, " "), bar) # add the bars into x x <- c(bar, x, bar) } # smooth preSpace if (!dontSmoothPreSpace) preSpace[] <- preSpace[which.max(nchar(preSpace))] # add back any spaces in place before the `pound` x <- paste0(preSpace, x) # collapse into a single string x <- paste(x, collapse="\n") clipCopy(x, sep="\n") return(invisible(x)) } mr <- function(x=clipPaste(), mindent=9, minWidth=60, align="left", top=TRUE, match=FALSE, ...) mkdshr(..., top=top, mindent=mindent, minWidth=ifelse(match, 1, minWidth), align=align, match=match) mkdsh <- function(x=clipPaste(), space=TRUE, pound="#", dash="-", leftSpace=TRUE, toptoo=FALSE , includeInput=TRUE, dontCollapse=FALSE, dontCopy=FALSE, dontTrim=FALSE) { # pound: turn off by making it FALSE or making it "" # dontCollapse, dontCopy : useuful for programmatic modes. ## this allows to quickly set the other params in the function call if (x[[1]]=="x") x <- clipPaste() ## TODO: Are you sure you want to collapse? # Collapse if multiple lines if (length(x) > 1) { x <- paste(x, collapse="\n") } ## Allow for a line of all whitespace. Thus, all the whitespace trimming is inside an if clause if (!dontTrim && !identical(strsplit(x, "\\s*"), list(""))) { x <- gsub("\\n$", "", x) leftSpaces <- 0 if(leftSpace) # TODO: turn this into regex with whitespace. Save the whole white space as a substring. Dont count it. leftSpaces <- min(which(strsplit(x, " ", fixed=TRUE)[[1]]!="")) - 1 original <- x x <- gsub("(^\\s*|\\s*$)", "", x) } else { leftSpace <- 0 original <- x } x <- sapply(strsplit(x, "\\n"), tail, 1) nc <- nchar(x) if (space) nc <- nc -2 if (!isFALSE(pound) && nchar(pound)) nc <- nc - 2*nchar(pound) dashes <- pasteR(dash, nc) if (space) dashes <- paste0(" ", dashes, " ") if (!isFALSE(pound) && nchar(pound)) dashes <- paste0(pound, dashes, pound) if (leftSpace) dashes <- paste0(pasteR(" ", leftSpaces), dashes) # # output to console # cat("\n\n", original,"\n", dashes, "\n\n", sep="") ## No need to output if using clipCopy # combine with original if (includeInput) dashes <- c(original, dashes) ## add dashes bar to the top if (toptoo) dashes <- c(tail(dashes, 1), dashes) # Collapse into a single string if (!dontCollapse) dashes <- paste(dashes, collapse="\n") # copy to clipboard if(!dontCopy) clipCopy(dashes, sep="\n") # return invisibly return(invisible(dashes)) } 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)) } .a <- args knito <- function(input, output=gsub("src", "out", dirname(input)), encoding="UTF-8", ...) { dir.create(dirname(output)) knit(input=input, output=output, encoding=encoding, ...) } # ------------------------------------------------------------------------------------------ # .us <- # synonym utilSource <- function(.Pfm=Sys.info()[['sysname']], main=TRUE, 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. ## POSSIBLE MISSING FUNCTIONS if(!exists("as.path")) as.path <- function(...) do.call(function(...) paste(..., sep="/"), list(...)) if (!exists("plrl")) plrl <- function(x, y) return(x) ## No need for distinction utilsFolder <- ifelse(.Pfm=="Linux", "/home/rstudio/git/misc/rscripts/utils", "~/git/misc/rscripts/utils") 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 unsuccessful and encountered the following error\n\t\"", gsub("\n$", "", caught.main[[1]]), "\"\n") } else if (verbose) cat("Main 'utilsRS.r' File Loaded Succesfully.\n\n", sep="") } ## Load NBS Utils if on the science box #x NBS if (.Pfm=="Linux") { #x NBS # Try to load, then report any error if present #x NBS caught.nbsutils <- try(source("~/NBS-R/utils/utils.r"), silent=TRUE) #x NBS if (inherits(caught.nbsutils, "try-error")) #x NBS warning("Loading the NBS utils file was unsuccessful and encountered the following error\n\t\"", gsub("\n$", "", caught.nbsutils[[1]]), "\"\n") #x NBS else #x NBS if (verbose) #x NBS cat("NBS Utils File Loaded Succesfully.\n\n", sep="") #x NBS } utilsToLoad <- c("dt_changeLevels.R", "findFnsInFile.R", "ggTSplot.R", "Introspection.R", "ListTransforms.R", "memoryFunctions.R", "paraLineChop.R", "PlotMCestimateWithSE.R", "reproduce.R", "sampleByGroup.data.table.R", "DB_Utils.r", "simpleFromJSON.r", "setScience.R", "signifArima.R", "transferLibrary.R", "workspace.R") failed <- list() for (util in utilsToLoad) { caught.others <- try(source(as.path(utilsFolder, util)), silent=TRUE) if (inherits(caught.others, "try-error")) { failed[[length(failed)+1]] <- util } else if (verbose) cat("'", util, "' Loaded Succesfully.\n", sep="") } if (length(failed)) warning("The following utils ", plrl("files were", failed), " not properly loaded:\n\t", paste(failed, collapse=", ")) } # ------------------------------------------------------------------------------------------ # plrl <- function(word.pluarl.form, count, singular=(length(count)==1)) { # Makes grammatically correct words based on the quanity of count plrl.single.dict <- c(were="was", are="is", have="has", files="file") # if vector of words if(length(word.pluarl.form) > 1) return(sapply(word.pluarl.form, plrl, count=count)) # if single string of many words 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. # 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) } setkeyIfNot <- function(DT, ..., verbose=TRUE, warnForColNameInEnv=TRUE) { # sets the key to a DT, however, first checks if # the key is already set to the given column(s) # # if ... is only one argument and it is a variable of strings, the values of that var will be used # unless it is ALSO a column name of DT, in which case it is treated as a column name but will throw a warning. # # Purpose of this function is to save the overhead # of setting the key when a key is already set. ## TODO: ## This does not work (indexing a character vector). Why? ## setkeyIfNot(sparse.DT, colsGrouped[1:2]) ### ### ### INFO ON TIMING: ### ### ### ### given a 1,991,816 x 13 DT, and two numeric columns as keys, ### ### which are already set, we get the following timings: ### ### ### ### Unit: microseconds (ran 16 Times) ### ### expr min lq median uq max neval ### ### sk 1169691.701 1232075.2535 1262345.5290 1293192.183 1392595.847 16 ### ### skIfNot 14.422 15.1835 32.0665 77.529 92.712 16 ### ### ### ### ### if (is.character(DT)) DT <- get(DT, envir=parent.frame()) # grab the dots dots <- as.character(substitute(list(...))[-1]) # if dots has only one value, and it is an object name AND it is not a column name of DT # then substitute its value for if (length(dots)==1 && exists(dots, envir=parent.frame())) { if (dots %in% names(DT)) { # warn if flagged, else do nothing if (warnForColNameInEnv) warning ("Ambiguous key selected:\n\t`", dots, "` is a variable name AND a column name of the data.table.\nThe key will be set to the single column, `", dots, "`\n") } else dots <- get(dots, envir=parent.frame()) } # grab the current key to compare against current <- key(DT) # if they are not the same, change the key and return TRUE if (!identical(current, dots)) { setkeyv(DT, dots) verboseMsg(verbose, "Key has been set", time=FALSE) } else verboseMsg(verbose, "Key did not need to be set", time=FALSE) return(invisible(DT)) } 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)) # ----------------------------------------------------------------------------------------------------------- # ## apply `is` to each element in a list, data.frame, etc, returning only the first response are <- function(ll, simplify=TRUE, listlist=is.list(ll[[1]])) { if (listlist) return(t(sapply(ll, are))) sapply(ll, function(x) is(x)[[1]], simplify=simplify) } ## 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) } ## finds all .R files within a folder and soruces them sourceEntireFolder <- function(folderName) { files <- list.files(folderName, full.names=TRUE) # Grab only R files files <- files[ grepl("\\.[rR]$", files) ] invisible(lapply(files, function(f) try(source(f, local=FALSE, echo=FALSE), silent=TRUE) )) } ## 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, show.warnings=FALSE) } if (length(filesWithPath)==0 || all(sapply(filesWithPath, nchar)==0)) { warning("No valid files to source.") } # source the files res <- invisible(lapply(filesWithPath, function(f) try(source(f, local=FALSE, echo=FALSE), silent=TRUE) ) ) # we will check if any errors and return T/F accordingly. # xxx Scratching this idea, since it makes the return names unpredictable # # first getting a set of names to apply to the T/F values # if(!any(duplicated(files))) # nms <- files # else { # nc <- nchar(filesWithPath) # nms <- paste0("....", substr(filesWithPath, max(1, nc-14), nc)) # } setNames(!sapply(res, isErr), files) } mergeDTlist <- function(DTlist, suffixes=NULL, checkKeys=TRUE , all=TRUE, all.x=all, all.y=all) { ## TODO: Allow for DTlist to be the names of the table, by using `get()` further down in the code # DTlist should be an actual list of DT's. If instead it is names, use `lapply(.., get)` if(all(sapply(DTlist, is.character)) && all(sapply(DTlist, length)==1)) { en <- parent.frame() DTlist <- lapply(DTsToMerge, get, envir=en) } ## check the keys if (checkKeys) { intersection <- Reduce(intersect, lapply(DTlist, key)) if (identical(character(0), intersection)) stop("Cannot automatically merge this list of DTs. No shared key amongst the DTs") # else checkKeys <- FALSE } ## set suffixes if (is.null(suffixes)) { suffixes <- paste0(".", fw0(length(DTlist))) } if (length(DTlist)==1) return(DTlist) if (length(DTlist)==2) return(merge(DTlist[[1]], DTlist[[2]], suffixes=suffixes, all=all, all.x=all.x, all.y=all.y)) # if there are more than 2 elements, merge the 2nd into the 1st, and iterate DTlist[[1]] <- merge(DTlist[[1]], DTlist[[2]], suffixes=suffixes, all=all, all.x=all.x, all.y=all.y) DTlist[[2]] <- NULL suffixes <- suffixes[-2] return(mergeDTlist(DTlist, suffixes=suffixes, checkKeys=checkKeys, all=all, all.x=all.x, all.y=all.y)) } greplAny <- function (pattern, x, ignore.case=FALSE, perl=FALSE, fixed=FALSE, useBytes=FALSE) { # searchs for ANY value of pattern in `x` found <- sapply(pattern, grepl, x, ignore.case=ignore.case, perl=perl, fixed=fixed, useBytes=useBytes ) ret <- rowSums(found) >= 1 setNames(ret, x) } removeWord <- function(word, removeFrom, ignore.case=TRUE, preSpaceIfLastWord=TRUE) { # Removes `word` from `removeFrom` if (preSpaceIfLastWord) removeFrom <- gsub(paste0(" ?\\b", word, "$"), "", removeFrom, ignore.case=ignore.case) gsub(paste0("\\b", word, " ?\\b"), "", removeFrom, ignore.case=ignore.case) } lunique <- function(x) { # shorthand for finding the number of unique elements if (!is.null(dim(x))) return(dim(unique(x))) length(unique(x)) } 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) } chop <- function(DT, vec, simplify=FALSE, add.nrow=TRUE) { # takes the results from makeIntervals(vec) and uses it to # chop DT into a list of tables if (add.nrow) if (!(nrow(DT) %in% vec)) vec <- c(vec, nrow(DT)) indecies <- makeIntervals(vec, final=NULL) ret <- lapply(indecies, function(ind) DT[ind, ]) if (simplify) return(rbindlist(ret)) return(ret) } expandGridByRow <- function(DT, vec, suffixes=c(".DT", ".vec"), keyToUse=key(DT), preserveList.vec=TRUE) { # preserveList.vec : if FALSE, we will attempt to coerce each list element into a DT column. If TRUE, we will leave each element as a DT row # unlistSingle : if TRUE, if vec is a list of length 1, it is treated as a vector # ----------------------------------------------------- # # Error Checks # ----------------------------------------------------- # # DT should be a data.frame or data.table if (!(inherits(DT, "data.frame"))) stop("DT must be a data.table or data.frame") if (length(dim(vec)) > 2) stop("vec cannot be more than two-dimensional") # ----------------------------------------------------- # # ----------------------------------------------------- # # Conver to data.tables # ----------------------------------------------------- # # if vec is not a data.table, convert to one if (!is.data.table(vec)) { # check if vec is a list (not a data.frame, data.table, etc) if (is.list(vec) && is.null(dim(vec))) { # if preserveList is set to TRUE, then we want to use `data.table(vec)` # not `as.data.table(vec)` as the latter "stands up" the list. vec <- if (preserveList.vec) data.table(vec) else as.data.table(vec) # check if it is an atomic vector } else if(is.null(dim(vec))) { vec <- data.table(vec) # else, data.frame, etc, use `as.data.table` } else { vec <- as.data.table(vec) } } # convert to data.table, if not already. (easier for name-dup resolution) if (!is.data.table(DT)) DT <- as.data.table(DT) # ----------------------------------------------------- # # ----------------------------------------------------- # # Ensure no duplicate names # ----------------------------------------------------- # # find any names present in both DT & vec dupNms <- intersect(names(DT), names(vec)) # if there are any, resolve by appending suffix if (length(dupNms)) { setnames(DT, dupNms, paste0(dupNms, suffixes[[1]])) setnames(vec, dupNms, paste0(dupNms, suffixes[[2]])) } # Note: When replicating DT & vec, one should repeat element(or row)-wise, one should repeat table-wise. # We will have DT be element-wise for two reasons. # (1) we can levarge key'ing and # (2) having vec repeat table-wise allows us to simply use cbind, and leverage R's recycling. # Alternatively, having vec repeat element wise is a lot more invovled, since we would # have to account for element-wise reps when vec is a vector and then row-wise when vec has dim. # Make reps of DT # ------------------- # reps is either the number of rows or the length of vec reps <- ifelse(is.null(dim(vec)), length(vec), nrow(vec)) DT.reppd <- data.table::rbindlist(replicate(reps, DT, simplify=FALSE)) setkey(DT.reppd) # Add in reps of vec - R will recycle vec automatically # ------------------- DT.reppd <- cbind(DT.reppd, vec) # set key if `keyToUse` is not null if(length(keyToUse)) { if (all(keyToUse == "all")) { if ("all" %in% names(DT.reppd)) warning("Problem with keying the expanded DT:\n Argument `keyToUse` set to 'all', but there is also a column named 'all'.\n Using all columns.") setkey(DT.reppd) } else setkeyv(DT.reppd, keyToUse) } return(DT.reppd) } # ----------------------------------------------------------------------------------- # validPercentage <- function(x, min=0, max=1, nm=substitute(x), silent=FALSE, fixAttempt=TRUE, stopif=FALSE) { # Checks if x is inside [min, max] # Returns the valid x if yes, FLASE if no # fixAttempt: if TRUE, this function will dividie or multiply by 100 to attempt to convert x to a valide percentage # if x was modified and silent is TRUE, this function will throw a warning indicating as such # stopif: If TRUE and if x is not valid throws error. # If fixAttempt is also TRUE, will only throw error if failed to fix AND stopif is TRUE # For now, this function only works on single values if (length(x) > 1 || !is.atomic(x)) stop("`validPercentage` can only be called on a single value. Support for vectors, lists, etc is planned.") x.orig <- x nm.char <- as.character(nm) nm <- ifelse (nm.char[[1]] == "[[", "x", paste0("`", deparse(nm), "`")) # Check for NA value in x if (is.na(x)) { if (!(silent)) warning(nm, " has a value of NA and hence is not a valid percentage.\n") return(FALSE) } # Try to fix x. x.was.fixed <- FALSE if (fixAttempt) { # how to fix if (max==1) fix <- function(z) z / 100 if (max==100) fix <- function(z) z * 100 # attempt to fix if (x < min || x > max) { x <- fix(x) x.was.fixed <- TRUE } } # If x is valid, return TRUE if (x >= min && x <= max) { if (!silent && x.was.fixed) warning("\n\n ", nm, " should be a value in [", min, ", ", max, "].\n ", nm, " was an invalid percentage, but has been\n converted from ", x.orig, " to ", x, "\n") return(x) } msg <- paste0("\n", nm, " should be a value in [", min, ", ", max, "].\n", nm, " = ", x.orig, " is not a valid precentage", ifelse(fixAttempt, " and could not be fixed.", ""), "\n") ## else, x is invalid # throw error, if flagged to do so if (stopif) stop(msg) # issue warning, unless flagged not to if (!silent) warning(msg) # warning("\n", nm, " should be a value in [", min, ", ", max, "].\n", # nm, " = ", x.orig, " is not a valid precentage and could not be fixed.\n") # return FALSE (if no flag for errro) return(FALSE) } # ----------------------------------------------------------------------------------- # dict.numbs <- c( "one" = 1 , "two" = 2 , "three" = 3 , "four" = 4 , "five" = 5 , "six" = 6 , "seven" = 7 , "eigth" = 8 , "nine" = 9 , "ten" = 10 , "14" = 14 , "28" = 28 , "29" = 29 , "30" = 30 ) # ----------------------------------------------------------------------------------- # 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) ) } setFactorOrder <- function(fctr, order=sort(levels(fctr))) { # TODO: Just found out about `relevel()`. # Looks like same function. # # Returns a factor ordered by order. # If order is missing, defaults to # Useful for ggplot, were ordering is based on the order of the levels if (!is.factor(fctr)) { warning("`fctr` is not a factor. Will coerce.") if (missing(order)) order <- sort(unique(fctr)) } factor(fctr, level=order) } # For when I'm too lazy to copy and paste dputc <- function(...) { clipCopy(capture.output(dput(...))) } copyAsCol <- function(...) { invisible(clipCopy(dput(...))) } s.t <- function(expr, msg="", verbose=TRUE, gcFirst=FALSE, title="", pause=0) { # 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 ret <- capture.output(system.time(expr=expr, gcFirst=gcFirst)) ret <- paste(ret, collapse="\n") if (nchar(title)) msg <- paste0("Time to complete ", title, ":") Sys.sleep(pause) if (verbose){ if (nchar(msg) == 0) cat(ret) else cat(pasteC(msg), ret, sep="\n") } } verboseMsg <- function(verbose, ..., time=TRUE, sep=" ", stampFirstLine=TRUE, endl=1) { ## 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. if (!verbose) return(invisible(NULL)) if (time) { stamp <- format(Sys.time(), "%H:%M") stamp <- paste0(" -- [", stamp, "]") # collect and flatten all the message elements, ie, the dots dots <- list(...) dots.flat <- paste(dots, collapse=sep) # if there is a linebreak, insert the time stamp after the first line break if (stampFirstLine && grepl("\\n", dots.flat)) { junk <- "qqxxzypdfd_sdfdodreklsdjfdlken" # some meaningless symbol to capture ending line breaks splat <- strsplit(paste0(dots.flat, junk), "\\n")[[1]] # remove junk splat[[length(splat)]] <- gsub(junk, "", splat[[length(splat)]]) dots.flat <- paste(c( paste0(splat[[1]], stamp), splat[-1]), collapse="\n") } else dots.flat <- paste0(dots.flat, stamp) # output cat(dots.flat, pasteR("\n", endl)) # if no time stamp } else { cat(..., pasteR("\n", endl), sep=sep) } 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)) # } # ----------------------------------------------------------------------------------------------------------- # ## SIMILAR TO JESUS, BUT USES write.table() FOR MATRIX-LIKE OBJECTS THAT DO NOT HAVE LIST-LIKE COLUMNS ## Once confirmed that this works properly, replace `jesus()` jesus2 <- function(..., dir=ifelse(exists("outDir"), outDir, as.path(getwd(), "out")), subDir=sub, pos=1, sub=TRUE, stampDir=TRUE, stampFile=FALSE, summary=TRUE, envir="", tablesAsCSV=TRUE, row.names=FALSE, col.names=FALSE) { ## Like saveit() but can take multiple objects as arguments ## ## saves objects passed as (...) arguments to file of type .Rda and with ## name of file same as name of obj + time stamp ## in location: dir ## tablesAsCSV: if TRUE, matrix-like (2-dim objects) will be written to csv ## subDir: if TRUE, will create subdir data_bak ## inside dir and use that folder. (if alreaddy exists, will just use) #S sub: a synonym for subDir. (since use of ... does not allow for partial matches) ## ## returns: the path/to/file.Rda where objects were saved ## NOTE TO SELF: You cannot use `dots.list` and `list(...)` interchangeably in substitute ## dots.list <- list(...) # get objects from dots objNames <- as.list(as.character(substitute(list(...)))[-1L]) # check for arguments being (eval(...)) whichAreEval <- sapply(objNames, function(x) grepl("^eval\\(.+\\)$", x)) if (any(whichAreEval)) { # confirm they are calls whichAreCalls <- sapply(substitute(list(...))[-1], is.call) # proceed only if they match if (identical(whichAreCalls, whichAreEval)) { objNames2 <- list(...)[whichAreCalls] objNames <- unlist(c(objNames2, objNames[!whichAreCalls])) } } ### TODO: June 2013. Apparently the `eval(vector.of.obj.names)` was not working. I wrote the part immediately above this. ### Confirm all is working correctly. # -- check this -- # # TODO: double-check pos value. It might be off. # -- check this -- # # check any value is eval(XX), if so parse it. Collect all values into a single vector. # -- check this -- # objNames <- unlist( lapply(objNames, function(ob) # -- check this -- # if(substr(ob, 1, 5)=="eval(") eval(parse(text=substr(ob, 6, nchar(ob)-1)), envir=ifelse(is.environment(envir), envir, parent.frame(pos+1)) ) else ob # -- check this -- # ) ) # No need to save any object twice objNames <- unique(objNames) #----- ERROR CHECKS ------# # If any of the assignment operators are found in the list, throw an error if(detectAssignment(objNames)) stop("Cannot assign in the call to this function.") #----- ERROR CHECKS ------# # Check that the objects to be saved exist NotPresent <- !(sapply(objNames, exists)) if (any(NotPresent)) { warning("The following objects were not found and hence could not be saved:\n ", paste(objNames[NotPresent], collapse=" "), "\n") objNames <- objNames[!NotPresent] } # if flag is true, add appropriate subdir if (subDir) dir <- as.path(dir, "data_bak") # add timeStamp to dir if required if(stampDir) dir <- paste0(as.path(dir), "_", timeStamp()) # Create dir if needed dir.create(as.path(dir), recursive=TRUE, showWarnings=FALSE) if (tablesAsCSV) { ## Determine which are matrix-like twoDimmed <- gapply(objNames, is.twodim, pos=pos+1, simplify=TRUE) # determine which have list columns hasLists <- gapply(objNames, has.listColumn, pos=pos+1, simplify=TRUE) # keep only two dimmed that do not have list columns twoDimmed <- (twoDimmed) & !(hasLists) # Track any failures ## CURENTLY NOT IMPLEMENTED failed <- as.character(c()) # isolate just those that will be CSV'd csv.objNames <- objNames[twoDimmed] # create the file paths, cleaning objNames of bad chars csv.fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, ext=".csv", dir=dir, addTimeStamp=stampFile) for (i in seq_along(csv.objNames)) { obj <- get(csv.objNames[[i]], envir=pos+1) # double check pos fil <- csv.fileWithPath[[i]] ## TODO: add try() and save any failures to `failed` write.table(obj, file=fil, append=FALSE, quote=TRUE, sep="|", row.names=row.names, col.names=col.names, qmethod="escape", fileEncoding="UTF-8") } # clear out those saved as CSV objNames <- objNames[!twoDimmed] objNames <- c(objNames, failed) } # create the file paths, cleaning objNames of bad chars rda.fileWithPath <- sapply(objNames, mkSaveFileNameWithPath, ext=".rda", dir=dir, addTimeStamp=stampFile) # Save the object tryCatch(mapply(function(obj, thefile) # note that with the save+do.call we are going in an extra two environments, hence pos + 2 (also, tested with pos+1, pos+3, both wrong) do.call(save, args=list(obj, envir=parent.frame(pos+2), file=thefile) ) # pos + 3 will be off if , objNames, rda.fileWithPath), error = saveErrorHandle) ## This does NOT work. # filesCreated <- do.call(saveit, args=list(objNames, pos=pos+1, dir=dir, addTimeStamp=stampFile)) # return(filesCreated ) ret.fileWithPath <- c(csv.fileWithPath, rda.fileWithPath) # return the path/to/files or just a summary if (summary) return(list('quantity'=paste(length(ret.fileWithPath), "files were created in:"), 'dir'=dir)) return('back.up.files'=ret.fileWithPath) } scaleunif <- function(vec, min, max, 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 mn <- min(vec) mx <- max(vec) ret <- ((vec-mn) / (mx-mn) * (max - min)) + min if (round) ret <- round(ret) ret } substitute.mc <- function(what, alternate) { } # ----------------------------------------------------------------------------------------------------------- # runShiny <- function(shinyapp.name) { require(shiny) runApp(as.path(srcDir, shinyapp.name)) } percOf <- function(x, outOf, roundDigs=4) return(round((outOf - x)/outOf, roundDigs)) 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) } ### -------------------------------------------------------------------------- ### ### TODO: Figure out why this is failing in RStudio. For now, wrapping in TRY ### ------------ {RSTUDIO ERROR } ------------------------------------------- ### try( ### ------------ {RSTUDIO ERROR } ------------------------------------------- ### ## Shorthand for tunring off legends if ("ggplot2" %in% rownames(installed.packages())) .nolegend <- ggplot2::theme(legend.position="none") ### ------------ {RSTUDIO ERROR } ------------------------------------------- ### , silent=TRUE) ### ------------ {RSTUDIO ERROR } ------------------------------------------- ### # --------------------------------------------------------- # # --------------------------------------------------------- # # 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) } # --------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------- # 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, ...) { UseMethod ("sampleChunks") } sampleChunks.default <- function(...) { stop ("\n\nsampleChunks is only defined for data.table's\n") } .so <- function() { ## copies the bitly link to reproduce.r link <- "http://bit.ly/SORepro" out <- paste("Hello and welcome to SO. To help make a reproducible example, you can use `reproduce()` . Instructions are here: ", link, " .") cat("\n", out, "\n") clipCopy(out) return(link) } rboxPull <- function() system("/home/rstudio/") # ----------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------- # options("utilsLoaded"=TRUE) ## Indicates that this file has been loaded options("dontReloadUtils"=FALSE) ## .RProfile will generally run `utilSource()` unless this is set to TRUE