# ---------------------------------------------------------------------------------------------------------------------------------------------------------------- # # -------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # File Name : format functions.r # # Last Updated Funclist : 19 Feb 2015, 12:52 PM (Thursday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : data.table, stringr # # # # -------------------------------------------------------------------------------------------------------------------------------------------------------------- # # # # form ( x, dig=3 ) # # formatBytes ( x, min="KB", max="TB", MBthresh=600, digs=2, force=NULL # # , .B.magnitudes=c("B", "KB", "MB", "GB", "TB") ) # # formbytes ( x, digs=2 ) # # asCurr ( x, decim=2, noSpacesAfterSymb=1, symbol="$", noWarnOnChar=FALSE, checkForNAChars=TRUE ) # # secondsScale ( units.new=c("nanoseconds", "microseconds", "milliseconds", "seconds", "minutes", "hours", "days", "secs", "mins"), toSeconds=!fromSeconds # # , fromSeconds=FALSE ) # # readableTime ( x, justTime=FALSE, ts.local ) # # order.readableTime ( x, decreasing=FALSE, times.last=TRUE ) # # sort.readableTime ( x, decreasing=FALSE, times.last=TRUE ) # # formatK ( x, digs=1 ) # # print.bytes ( x, min="KB", max="TB", MBthresh=600, digs=2, force=NULL, ... ) # # fwS ( 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 ) # # fw ( x, dec=4, digs=4, w=NULL, scientific=FALSE, ... ) # # fw0 ( num, digs=NULL, mkseq=TRUE, pspace=FALSE ) # # fw0.older ( obj, digs=NULL ) # # fw3 ( x, dec=3, digs=3, w=NULL, scientific=FALSE, ... ) # # fwp ( x, dec=2, sep=" ", simplify=TRUE, pad=FALSE, symbol="%", justNumbs=FALSE, big.mark="" # # , zero.if.less.than="auto" ) # # fwTDiff ( start, end, using="elapsed" ) # # convertTime ( x, from.units="seconds", to.units="hours" ) # # fwSecs ( seconds # # , numbOfTimeUnits=ifelse(any(seconds > 24 * 60 * 60), 3, 2), units.of.seconds=attr(seconds, "units"), fraction.seconds.allowed=TRUE # # , dict.convert_to_seconds=getDict("dict.convert_to_seconds") ) # # fwc ( x, minChar=NULL, maxChar=NULL, extra=0 ) # # formnumb ( x, selfRound="auto", ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE # # , perc_auto=TRUE, perc_dec="auto", perc_thresh=0.75 ) # # # # # # # # -------------------------------------------------------------------------------------------------------------------------------------------------------------- # # ---------------------------------------------------------------------------------------------------------------------------------------------------------------- # ## This is an old function and might be useless 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))) } ## function to format numerics fw <- function(x, dec=4, digs=4, w=NULL, scientific=FALSE, ...) { if (inherits(x, "data.table")) return( iterateByClass(DT=x, classes=c("numeric", "integer")) ) ## wrapper to function format(.) format(x, nsmall=dec, digits=digs, width=w, scientific=scientific, ...) } fw3 <- function(x, dec=3, digs=3, w=NULL, scientific=FALSE, ...) { if (inherits(x, "data.table")) return( iterateByClass(DT=x, classes=c("numeric", "integer")) ) ## wrapper to function format(.) ret <- format(x, nsmall=dec, digits=digs, width=w, scientific=scientific, ...) # 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, big.mark = "", zero.if.less.than="auto") { # Formats as percentage # justNumbs : if TRUE, just multiplies by 100, rounds and pads # pad: Could be TRUE or a number. zeroAuto <- missing(zero.if.less.than) || identical(zero.if.less.than, "auto") if (is.logical(zero.if.less.than)) { zero.if.less.than <- if (isTRUE(zero.if.less.than)) "auto" else 0 } if (!is.numeric(zero.if.less.than) && !(identical(zero.if.less.than, "auto"))) stop ("zero.if.less.than if not a number must be either 'auto', TRUE or FALSE (TRUE is same as 'auto')") if (inherits(x, "data.table")) return( iterateByClass(DT=x, classes=c("numeric", "integer")) ) if (is.list(x)) { ARGS <- collectArgs(except="x") return(lapply(x, function(x_i) do.call(fwp, c(ARGS, x=x_i)))) } ## Capture the NA's which will be put back at the end nas <- is.na(x) # basic settings to return only the number values if (justNumbs) { sep <- symbol <- "" if (missing(pad)) pad <- FALSE if (missing(dec)) dec <- 1 } ## Auto-detect dec based on values in x if (dec == "auto") { if (all(is.na(x))) dec <- 0 else { max.check <- if (!zeroAuto) abs(log10(min(100, zero.if.less.than))) else 5 counts <- sapply(seq(2, max.check), function (p) sum(x > 10^(-p) | x == 0, na.rm=TRUE)) counts <- counts / length(removeNA(x)) dec <- -1 + min(which(counts > .35 & c(diff(counts), 0) < .15), length(counts)) } # cat("using dec = ", dec, "\n") } if (zeroAuto) zero.if.less.than = 10^{-(1+max(3, dec))} # OLD # ret <- sapply(x, function(y) paste(fw3(100*y, dec=dec, digs=1, big.mark=big.mark, scientific=FALSE), symbol, sep=sep), simplify=simplify) # NEW: ret <- paste(format(round(100*x, dig=dec), big.mark=big.mark, scientific=FALSE), symbol, sep=sep) if (FALSE) { ## These two lines allow for small values to be shown with more digits than dec. ## However, why bother, if I am using zero.if.less.than ?? cropped <- x > zero.if.less.than & x < (round(5/9, 2+dec) / 100) ret[cropped] <- sapply(x[cropped], function(y) paste(fw3(100*y, dec=dec, digs=1, big.mark=big.mark, scientific=FALSE), symbol, sep=sep), simplify=simplify) } ## if very small, replace ## TODO 2015-01-25 Allow for very small negative values ret[abs(x) < zero.if.less.than & x != 0] <- sprintf("~%s %s", fw3(0, dec=dec), symbol) ## Allign on the decimal. Note if no decimal, padding will be on the left if (pad) { ## LEFT pad nc.l <- nchar(gsub("\\..*", "", ret)) ret <- paste0(pasteR(" ", max(nc.l) - nc.l), ret) ## RIGHT pad nc.r <- nchar(gsub(".*\\.", "", ret)) ret <- paste0(ret, pasteR(" ", max(nc.r) - nc.r)) ## put any tilde before the space ret <- gsub(" ~0", "~ 0", ret) ## move symbol to end ret <- gsub("(%)(\\s+)", "\\2\\1", ret) ## show. Only useful when dev'ing cbind(ret) } ## Put back the NAs ret[nas] <- NA # 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) } fwTDiff <- function(start, end, using="elapsed") { if (using %in% names(start)) start <- start[[using]] if (using %in% names(end)) end <- end[[using]] difftime <- end - start unname(fwSecs(difftime)) } convertTime <- function(x, from.units="seconds", to.units="hours") { multiplyBy <- unname(secondsScale(units=to.units, fromSeconds=TRUE) * secondsScale(units=from.units, toSeconds=TRUE)) ret <- (x * multiplyBy) data.table::setattr(ret, "units", to.units) return(ret) } fwSecs <- function(seconds, numbOfTimeUnits=ifelse(any(seconds > 24*60*60), 3, 2), units.of.seconds=attr(seconds, "units"), fraction.seconds.allowed=TRUE, dict.convert_to_seconds=getDict("dict.convert_to_seconds")) { #' Converts a numeric to rounded seconds or minutes. # if (length(seconds) > 1) # return(sapply(seconds, fwSecs, units.of.seconds=units.of.seconds)) NAs <- is.na(seconds) if (all(NAs)) return(seconds) ## Give the NAs a value. It will be replaced later seconds[NAs] <- 60 ## downstream from here, seconds is copied over. Thus, force units.of.seconds and take a back up copy force (units.of.seconds) seconds.orig <- copy(seconds) if (!is.numeric(seconds)) seconds <- unname(as.numeric(seconds)) if (!is.null(units.of.seconds)) { units.of.seconds <- match.arg(units.of.seconds, names(dict.convert_to_seconds)) seconds <- as.numeric(seconds) * secondsScale(units.of.seconds) } seconds <- abs(seconds) ## Clean up the dict so that shorter names get priority, except for "seconds" dict.convert_to_seconds <- dict.convert_to_seconds[order(nchar(names(dict.convert_to_seconds)), decreasing=FALSE)] dict.convert_to_seconds <- c(dict.convert_to_seconds["seconds"], dict.convert_to_seconds[names(dict.convert_to_seconds) != "seconds"]) ## Make sure the dict is unique, sorted, then reverse it. Then pad a dummy value to the front dict.convert_to_seconds <- rev(sort(dict.convert_to_seconds[!duplicated(dict.convert_to_seconds)])) dict.convert_to_seconds <- c(dummy_value=max(seconds)+1, dict.convert_to_seconds) ## This could be modified to adjust for "smallest unit allowed" if (fraction.seconds.allowed) { dict.convert_to_seconds <- dict.convert_to_seconds[dict.convert_to_seconds >= dict.convert_to_seconds[["seconds"]]] ## If fraction.seconds.allowed are NOT allowed, check we want to increase all dict values to be whole integers, to avoid machine-precision error } else if (any(round(seconds) != seconds) && min(dict.convert_to_seconds) < 1) { if (any(abs(seconds / min(dict.convert_to_seconds)) > 4.5e15)) ## the value 4.5e15 was found via brute force warning ("Some seconds are close to machine max, while others have portions between 0 and 1. Machine precision may effect ultimate output, specifically along the sub-second level ") else { seconds <- seconds / min(dict.convert_to_seconds) dict.convert_to_seconds <- dict.convert_to_seconds / min(dict.convert_to_seconds) } } ## create an named-index vector to iterate over. ## The names are important as sapplyt() will set them as the rownames to the resulting matrix inds <- seq_along(dict.convert_to_seconds) data.table::setattr(inds, "names", paste0(" ", gsub("s$", "", names(dict.convert_to_seconds)))) ## Create a matrix M <- sapplyt(inds[-1L], function(i) { (seconds %% dict.convert_to_seconds[i-1]) %/% dict.convert_to_seconds[i] }, .to.dt=FALSE) ## if seconds was a single number, M will NOT be a matrix but a vector. Adjust it. if (!is.matrix(M)) { data.table::setattr(M, "dim", c(length(M), 1)) data.table::setattr(M, "dimnames", value=list(names(inds)[-1L], names(seconds))) } ## how far to round. This will be used again below, when checking for very small seconds dig <- abs(max(-4, min(-2, 1+floor(log10(abs(seconds)))))) if (fraction.seconds.allowed && any(round(seconds) != seconds)) { i <- max(inds) ## Only allow for decimals in those values where there is a 'minute' value as well or seconds is less than a minute testCondition <- if (i-2 > 0) M[i-2, ] | seconds < 60 else seconds < 60 M[i-1, ] <- ifelse(testCondition, round((seconds %% dict.convert_to_seconds[i-1]) / dict.convert_to_seconds[i], dig=dig), M[i-1, ]) } ## Paste the rownames, with an optional "s" M.str <- ifelse(M==0, NA, paste0(format(M, nsmall=dig, scientific=FALSE), rownames(M), ifelse(M != 1 , "s", ""))) ## for each x, start at the first non-NA, then proceed (numbOfTimeUnits-1) forward, then remove NAs ret <- apply(M.str, 2, function(x) pasteC(removeNA(x[locateFirstNonNA(x, showWarnings=FALSE) + c(0:(numbOfTimeUnits-1))]), C=" ")) ## remove any ".00" from the other units ## TODO: This could be handled in the M.str portion by having a different paste for 'seconds' than the rest ret <- gsub("\\.0+ ", " ", ret) if (fraction.seconds.allowed && any(wh.small <- abs(seconds) < 10^-(dig))) ret[wh.small] <- paste0("< ", format(10^-(dig), scientific=FALSE), " seconds") if (any(neg <- (seconds.orig < 0))) ret[neg] <- paste("-", ret[neg]) ## Put the NAs back if (any(NAs)) ret[NAs] <- NA return(ret) } # fwSecs_old <- function(seconds, numbOfTimeUnits=ifelse(seconds > OneDay, 3, 2), units=attr(seconds, "units"), dict.convert_to_seconds=getDict("dict.convert_to_seconds")) { # #' Converts a numeric to rounded seconds or minutes. # # if (length(seconds) > 1) # return(sapply(seconds, fwSecs, units=units)) # # cat("seconds = ", seconds, " | numbOfTimeUnits = ", numbOfTimeUnits, "\n") # # if (!is.numeric(seconds)) # seconds <- unname(as.numeric(seconds)) # # if (!is.null(units)) { # units <- match.arg(units, names(dict.convert_to_seconds)) # seconds <- as.numeric(seconds) * secondsScale(units) # } # # # if (inherits(seconds, "difftime")) { # # seconds <- as.numeric(seconds) * secondsScale(attr(seconds, "units")) # # seconds <- unname(seconds) # # } # # # ## IF not a number, try to convert, else fail. # # if (!is.numeric(seconds)) { # # if (isNumber(seconds)) # # seconds <- as.numeric(seconds) # # else # # stop("`seconds` must be numeric") # # } # # if (FALSE) { # ## For smaller values use roundOutToX # if (seconds < 1) # return(sprintf("%2.03f seconds", roundOutToX(seconds, .001))) # # if (seconds < 10) # return(sprintf("%2.02f seconds", roundOutToX(seconds, .010))) # # if (seconds < 60) # return(sprintf("%2.01f seconds", roundOutToX(seconds, .100))) # # ## For medium & larger values use roundOutToDig -- WHY? # if (seconds < 100) # return(sprintf("%2.00f seconds", roundOutToDig(seconds, 1))) # # if (seconds < 7200 && missing(numbOfTimeUnits)) # 2 hours # return(paste(roundOutToDig(seconds/60, 1), "minutes")) # } # # ## else # OneNanoSec <- 1e-6 # OneMicroSec <- 1e-6 # OneMilliSec <- 1e-3 # OneSecond <- 1 ## In case, in the future we change units # OneMinute <- 60 * OneSecond # OneHour <- 60 * OneMinute # OneDay <- 24 * OneHour # OneYear <- 365.25 * OneDay # OneCentury <- 100 * OneYear # ## We cant use Inf, so we use seconds + 1 # OneCap <- seconds + 1 # # # e.working <- environment() # TimeUnits <- c("Cap", "Century", "Year", "Day", "Hour", "Minute", "Second") # if (any(abs(seconds) < 1)) # TimeUnits <- c(TimeUnits, "NanoSec", "MicroSec", "MilliSec") # ones <- lapply(TimeUnits, function(u) get(paste0("One", u), envir=e.working)) # counts <- c() # for (i in 2:length(TimeUnits)) # counts[[TimeUnits[[i]]]] <- (seconds %% ones[[i-1]]) %/% ones[[i]] # # text.out <- paste(rep("%i %s%s", numbOfTimeUnits), collapse=", ") # m <- min(which(counts != 0), length(counts)) # # inds <- m + (0:min(numbOfTimeUnits-1, length(counts)-m)) # # ret <- commaSep(sprintf("%i %s%s", counts[inds], names(counts)[inds], ifelse(counts[inds] == 1, "", "s"))) # # return(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) } formnumb <- function(x, selfRound="auto", ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE, perc_auto=TRUE, perc_dec="auto", perc_thresh=.75) { UseMethod("formnumb") } formnumb.data.table <- function(x, selfRound="auto", ignore_by_names=TRUE, ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE, perc_auto=TRUE, perc_dec="auto", perc_thresh=.75) { # round should be a number to which to round to. # if it is TRUE, it will be assumed to be zero ## ignore_by_names :: if TRUE, will check the names of the columns, and not touch those which look like IDs or Years if (!nrow(x)) return(x) colsnumb <- nwhich(sapply(x, is.numeric) & !sapply(x, inherits, "idcol") & names(x) %ni% c("year", "month", "date")) if (ignore_by_names) { colsnumb %<>% {.[!grepl("(^(activity|accounting)_?year$|.*id$)", .)]} if ("yr" %in% colsnumb && all(nchar(x[["yr"]]) == 4)) colsnumb %<>% {.[. != "yr"]} } ## if there are no numbers to convert if (!length(colsnumb)) return(x) x <- copy(x) if (isTRUE(curr_auto)) { colsDollar <- grep("dollar", colsnumb, value=TRUE) colsnumb <- setdiff(colsnumb, colsDollar) if (length(colsDollar)) x [, c(colsDollar) := lapply(.SD, asCurr, symbol="$", decim=2), .SDcols=colsDollar] } if (isTRUE(perc_auto)) { colsPerc <- nwhich(detectPercentColumns(x, showWarnings=FALSE, thresh.for.values.gt.1=perc_thresh)) colsnumb <- setdiff(colsnumb, colsPerc) if (length(colsPerc)) x [, c(colsPerc) := lapply(.SD, fwp, dec=perc_dec), .SDcols=colsPerc] } if (length(colsnumb)) x [, c(colsnumb) := lapply(.SD, formnumb, round=round, selfRound=selfRound, convertToNumeeric=convertToNumeeric), .SDcols=colsnumb] return(x) } formnumb.data.frame <- function(x, selfRound="auto", ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE, perc_auto=TRUE, perc_dec="auto", perc_thresh=.75) { # round should be a number to which to round to. # if it is TRUE, it will be assumed to be zero if (!nrow(x)) return(x) ARGS <- collectArgs(except="x") do.call(formnumb.data.table, c(list(x=as.data.table(x)), ARGS)) } formnumb.list <- function(x, selfRound="auto", ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE, perc_auto=TRUE, perc_dec="auto", perc_thresh=.75) { return(lapply(x, formnumb, selfRound=selfRound, ...=..., round=round)) } formnumb.default <- function(x, selfRound="auto", ..., round=NULL, convertToNumeeric=TRUE, curr_auto=TRUE, perc_auto=TRUE, perc_dec="auto", perc_thresh=.75) { L <- length(x) if (is.perc(x)) return(fwp(x, dec=ifelseNULL(round, 2, ifelse(round >=0, round, 2)))) if (convertToNumeeric) x[] <- as.num.nowarn(x) ## Automate selfRound. If round is not set and there are any large values, or more than 60% medium values if (selfRound == "auto") { selfRound <- is.null(round) && (any(x > 1e3) || sum(x > 100 | x == 0) / L > .6) } ## Wrap all of the rounding and formatting in try() ## Since often this function is called in the output at the end of other functions ## If this function fails, then the other function usually fails too try({ if (isTRUE(selfRound)) x[] <- selfRound(x) else if (isTRUE(round)) x[] <- round(x, 0) else if (is.numeric(round) && is.finite(round)) x[] <- round(x, digits=round) x[] <- format(x, big.mark=",", scientific=FALSE, ...) }) return(x) } # sort.bytes <- function(bb, decreasing=FALSE, ...) { # not yet implemented # } is.bytes <- function(x) { inherits(x, "bytes") } as.bytes <- function(x) { class(x) <- c("bytes", class(x)) x } if (FALSE) { as.numeric.bytes(c("10mb","10 mb","10MB","10 MB","10 b","10gb"), FALSE) as.numeric.bytes(x=c(".2MB", "2.MB", "19.5mb","19.5 mb","19.5MB","19.5 MB","19.5 b","19.5gb"), FALSE) } as.numeric.bytes <- function(x, showWarnings=TRUE) { if (is.numeric(x)) return(as.numeric(classUnappend_(x, "bytes"))) if (!is.character(x)) x <- as.character(x) if (!is.bytes(x)) x %<>% toupper %>% gsub(",", "", .) %>% gsub("\\s*((\\d|\\.)+)\\s*([A-Z]?B)\\s*", "\\1 \\3", .) if (showWarnings) warning("Calling as.numeric on a 'bytes' object will result in rounding errors.") ## CONVERT scales <- getBytesScale() ## column 1 is values; column 2 is scales M <- strsplit(x, " ") %>% do.call(what=rbind) as.numeric(M[, 1]) * scales[M[, 2]] %>% setNames(nm=names(x)) } getBytesScale <- function() { c( B = 1L , KB = 1024L , MB = 1048576L , GB = 1073741824L , TB = 1099511627776 ) } formatBytes <- function(x, min="KB", max="TB", MBthresh=600, digs=2, force=NULL, .B.magnitudes=c("B", "KB", "MB", "GB", "TB")) { # Convert a raw byte value to a string, where the number value is divided and rounded according to the scale # Chooses scale automatically: The largest magnitude such that x is within less than 0.90 of the next magnitude # min/max :: constraint which scale can be picked. # When min > max, that is an error # Set min = max to force a specific magnitude of scale # .B.magnitudes :: Candidates for byte magnitdues. This argument should not be modified. # It is placed in the template simply to show the user when they look at the function formals scales <- getBytesScale() if (!missing(.B.magnitudes)) stop("Please do not modify .B.magnitudes, it is for internal use only") if (any(names(scales) != .B.magnitudes)) stop ("Internal error in formatBytes() -- scales and .B.magnitudes do not match") if (!length(x)) return(x) non.finite <- sapply(x, Negate(is.finite)) # if no x are finite, just return x if (all(non.finite)) return(x) ## NULLs for min/max use the top and bottom of .B.magnitudes if (is.null(min)) min <- .B.magnitudes[[1]] if (is.null(max)) max <- .B.magnitudes[[length(.B.magnitudes)]] ## Otherwise match arg, then match to .B.magnitudes to convert to an index number ## ... min min <- match.arg(toupper(min), choices=.B.magnitudes) min <- match(min, .B.magnitudes) ## ... max max <- match.arg(toupper(max), choices=.B.magnitudes) max <- match(max, .B.magnitudes) ## ERROR CHECK: if (min > max) stop ("'max' cannot be of a larger scale than 'min'") ## For each x, find the largest magnituded still smaller than x ## We impliment min and max by have a 'scales_crop' copy of 'scales' which is restricted to min/max ## Additionally, we set the 'min' of 'scales_crop' to be -Inf, this way all x will be flagged to at least that value scales_crop <- scales[seq(from=min, to=max)] scales_crop[1L] <- (-Inf) # assign -Inf so that xi will be at least larger than the first value ## Find the index of 'scales' for each x. Note the (min-1) to adjust for the difference between scales_crop and scales index.scales_using <- (min - 1) + sapply(abs(x), function(xi) ifelse(!is.finite(xi), 1, max(which(xi > scales_crop * 0.9)))) scales_using <- scales[index.scales_using] ## ------ FORMAT ---------------- frmt <- paste0("%0.0", digs, "f %s") ret <- sprintf(frmt, x / scales_using, names(scales_using)) ## ALTERNATE, comma separated. I prefer without the comma # paste(formnumb(x / scales_using, round=digs), names(scales_using)) ## ------ FORMAT ---------------- ## Put back any +/- Inf if (any(non.finite)) ret[non.finite] <- as.character(x[non.finite]) classAppend_(ret, "bytes") return(ret) } formbytes <- function(x, digs=2) { warning("formbytes() is depracated. Use formatBytes() instead.") oneKB <- 1024 oneMB <- 1048576 oneGB <- 1073741824 if (x > oneGB) { paste(formnumb(x / oneGB, digits=digs), "GB") } else if (x > oneMB) { paste(formnumb(x / oneMB, digits=digs), "MB") } else if (x > oneKB) { paste(formnumb(x / oneKB, digits=digs), "KB") } else { paste(formnumb(x / 1, digits=digs), "Bytes") } } 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) ## Bank the dims dim.bak <- dim(x) ## bank the dimnames dimnames.bak <- dimnames(x) # 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 && is.character(x)) { NaNs_string <- stringr::str_trim(x) == "NA" if (any(NaNs) && any(NaNs_string)) warning ("There are actual and there are 'NA' values in the set. The 'NA' will be ignored, though ultimately, they will not be represented properly") else NaNs <- NaNs_string } 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 # Put the names if they exist if (length(dim(x))) data.table::setattr(ret, "dim", dim(x)) if (length(dimnames(x))) data.table::setattr(ret, "dimnames", dimnames(x)) if (length(names(x))) data.table::setattr(ret, "names", names(x)) # return return(ret) } # END asCurr secondsScale <- function(units.new=c("nanoseconds", "microseconds", "milliseconds", "seconds", "minutes", "hours", "days", "secs", "mins"), toSeconds=!fromSeconds, fromSeconds=FALSE) { ## DEPENDS on: dict.convert_to_seconds missing.from <- missing(fromSeconds) missing.to <- missing(toSeconds) if (missing.from && !missing.to) fromSeconds <- !toSeconds if (missing.to && !missing.from) toSeconds <- !fromSeconds if (!missing.from && !missing.to) stop ("Cannot Select both toSeconds and fromSeconds. One must be FALSE.") conversions <- getDict("dict.convert_to_seconds") if (!all(tolower(units.new[[1]]) %in% names(conversions))) { warning(pasteR(60), "\n\n Here is your warning..... These are the values of units.new followed by names(conversions)\n") cat("units.new :: "); print(units.new) cat("names(conversions) :: "); print(names(conversions)) warning("\n", pasteR(60), "\n\n", call.=FALSE) } units.new <- match.arg(tolower(units.new[[1]]), names(conversions)) if (units.new == "secs") units.new <- "seconds" if (units.new == "mins") units.new <- "minutes" if (!(units.new %in% names(conversions))) stop ("Do not know how to convert from ", units.new, " to seconds.") ret <- conversions[units.new] if (!toSeconds) { ret <- 1 / ret names(ret) <- paste0("FROM Seconds TO ", names(ret)) } else { names(ret) <- paste0("FROM ", names(ret), " TO Seconds") } return(ret) } readableTime <- function(x, justTime=FALSE, ts.local, year.included=FALSE) { ## formats a time to "Aug 27 (Wed) 10:08p" if (!is.logical(justTime)) stop ("'justTime' in readableTime() should be logical. Did you accidentally send arg for ts.local without naming it?") x.isPosix <- inherits(x, c("POSIXct", "POSIXt")) x.isDate <- inherits(x, "Date") if (missing(ts.local)) { ## check the parent.frame if (exists("ts.local", parent.frame())) ts.local <- get("ts.local") else ts.local <- getOption("default.tz", "America/New_York") } ## x must be Date or POSIX if (!(x.isDate || x.isPosix)) stop ("x must be Date or POSIXct") ## format for date or POSIX format <- "%b %d (%a)" if (x.isPosix) { time_format <- "%l:%M %p" format <- ifelse (isTRUE(justTime), time_format, paste0(if (year.included) "%Y ", format, " ", time_format)) } browser(expr=inDebugMode("readableTime"), text="in readableTime() before usetz") ## decide between two different calls to format: ## ---------------------------------------------------------------- ## (1) str <- format(x, format=format, tz=ts.local, usetz=usetz) ## (2) str <- format(x, format=format, usetz=FALSE) ## ## We use the former (1) if x.isPosix AND ts.local is NOT null ## in this case, usetz will be TRUE iff ts.local differs from the 'natural' timezone of x ## If x is not posix or ts.local is NULL, we use (2) ## if (x.isPosix && !is.null(ts.local)) { usetz <- !identical(attr(as.POSIXlt(x, tz=ts.local), "tzone") [-1L] , attr(as.POSIXlt(x ), "tzone") [-1L]) str <- format(x, format=format, tz=ts.local, usetz=usetz) } else { str <- format(x, format=format, usetz=FALSE) } ## ---------------------------------------------------------------- ## Change the 'AM' / 'PM' to 'a' / 'p' (respectively) str <- gsub(" AM\\b", "a", str) str <- gsub(" PM\\b", "p", str) classAppend_(str, "readableTime") str } order.readableTime <- function(x, decreasing=FALSE , times.last=TRUE) { ## Convert AM/PM back x <- gsub("(a|p) ", " \\U\\1M ", x, perl=TRUE) ## remove day x <- gsub(" \\([A-Za-z]{,3})", "", x) date_format <- "%b %d" time_format <- "%l:%M %p" ret <- as.POSIXct(x, format=paste(date_format, time_format)) ## Try just DATE NAs <- is.na(ret) if (any(NAs)) ret[NAs] <- as.POSIXct(x[NAs], format=date_format) ## IF ALL NA, us time NAs <- is.na(ret) if (all(NAs)) ret[NAs] <- as.POSIXct(x[NAs], format=time_format) return(order(ret, decreasing=decreasing, na.last=TRUE)) } sort.readableTime <- function(x, decreasing=FALSE, times.last=TRUE) { x[order.readableTime(x, decreasing=decreasing, times.last=times.last)] } formatK <- function(x, digs=1) { ## Converts numbers to a string in Billions, Millions, Thousands, etc ## eg, changes 3765888 to "3.8 M" ## eg, changes 5888 to "5.9 K" scales <- c( 10^0 , K = 10^3 , M = 10^6 , B = 10^9 , T = 10^12 ) nas <- is.na(x) signs <- sign(x) ## Find corresponding thousands-power ind.scales <- trunc(log(abs(x)[!nas], base=1000)+1) ## any value beyond our scale (too large or too small), gets the end point ind.scales[ind.scales <= 0] <- 1 ind.scales[ind.scales >= length(scales)] <- length(scales) ret <- rep(NA_character_, length(x)) ret[!nas] <- paste0(round(x[!nas]/scales[ind.scales], digits=digs), ifelse(ind.scales > 1, " ", ""), names(scales)[ind.scales]) ret } print.bytes <- function(x, min="KB", max="TB", MBthresh=600, digs=2, force=NULL, quote=FALSE, print.gap=TRUE, right=TRUE, ...) { if (is.numeric(x)) print(formatBytes(x, max=max, min=min, MBthresh=MBthresh, digs=digs, force=force), quote=quote, print.gap=print.gap, right=right, ...) else if (is.character(x)) { print.default(as.character(x), quote=quote, print.gap=print.gap, right=right, ...) } else print(classUnappend_(copy(x), "bytes"), quote=quote, print.gap=print.gap, right=right, ...) } # ------------------------------------------------------------------ # 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. if (inherits(x, "data.table")) return( iterateByClass(DT=x, classes=c("numeric", "integer")) ) 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 if (inherits(num, "data.table")) return( iterateByClass(DT=x, classes=c("numeric", "integer")) ) # 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 a matrix or a vector") } # capture the dims and we will put it back dims <- dim(num) if (is.factor(num)) num <- as.character(num) # convert strings to numbers, don't warn for coercian num <- as.num.nowarn(num) if (num > 1e5 && mkSeq) { if (missing(mkSeq)) mkSeq <- FALSE else stop ("num is too large to have mkSeq be TRUE. You cna manually make the sequence and then pass to fw0()") } # If num is a single number and mkseq is T, expand to seq(1, num) if(mkseq && length(num) == 1 && !(num==0)) num <- (1:num) ## NA's, if present, will throw off the max/mins in `digs` and `posSpace` ## instead of littering the code with 'na.rm=TRUE', compute one time num.noNA <- num[!is.na(num)] # number of digits is that of largest number or digs, whichever is max digs <- max(nchar(max(abs(num.noNA))), 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.noNA) != 0 & sign(max(num.noNA)) != sign(min(num.noNA)) | 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)) }