# ------------------------------------------------------------------------------------------------------------------------- # # ----------------------------------------------------------------------------------------------------------------------- # # # # File Name : c4 and other print functions.r # # Last Updated Funclist : 08 Feb 2015, 5:14 AM (Sunday) # # # # Author Name : Rick Saporta # # Author Email : RickSaporta@gmail.com # # Author URL : www.github.com/rsaporta # # # # Packages Called : NA # # Packages Used via NS : base # # # # ----------------------------------------------------------------------------------------------------------------------- # # # # print.dims ( X, verbose=FALSE ) # # center ( 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", h.rows=1, C=NULL # # , debug=FALSE ) # # splitHeader ( z, valign=c("top", "bottom"), simplify=TRUE ) # # topbottom ( x, filler, valign ) # # pco ( ... ) # # dim2txt ( rowcols ) # # print.dim ( x ) # # dim ( ..., .txt=FALSE ) # # printdims ( X, justTheValue=FALSE ) # # summary2 ( x, rows=6, cols=6, cmt=TRUE ) # # c4 ( x, cols=4, rows=20, cmt=TRUE ) # # sideByside ( x, y, sep=3, bar=NULL ) # # remEndl ( x ) # # # # # # # # ----------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # # ------------------------------------------------------------------------------------------------------------------------- # # These functions were some of the earlier crap I put together to have cleaner output. # Many are not used as often, and should be reworked # ------------------------------------------------------------------------------------------------------------------------- # # ----------------- print.dim / print.dims ----------------- # print.dims <- function(X, verbose=FALSE) { ## TODO: Decide if I want to depricate this and use just print.dim ## TODO 2: If keeping this, clean up code to leverage print.dim if (!is.null(dim(X))) D <- dim(X) ret <- paste(formnumb(D[[1]]), "rows X", formnumb(D[[2]]), "cols") if (verbose) { X.nm <- paste0(as.character(as.expression(substitute(X))), collapse="_") ret <- paste(X.nm, "has", ret) cat(ret, "\n") } return(ret) } dim2txt <- function(rowcols, round=NULL) { ## rowcols should be a length-two vector, eg, the output of dim(DT) if (is.data.frame(rowcols)) rowcols <- dim(rowcols) if (length(nrow(rowcols))) stop ("The argument to dim2txt() should be the output of dim(DT)") paste(formnumb(rowcols[[1]], round=round), "rows X", formnumb(rowcols[[2]], round=round), "cols") } print.dim <- function(x) { round <- attr(x, "print_rounded") ## will default to NULL if attribute does not exist if (length(x) <= 1) out <- x else if (length(x) == 2) out <- dim2txt(x, round=round) else out <- paste(x, collapse=" X ") print.default(out, quote=FALSE) } dim <- function(..., .txt=FALSE, round=NULL) { ret <- base::dim(...) if (length(ret)) class(ret) <- c("dim", class(ret)) if (!is.null(round)) attr(ret, "print_rounded") <- round if (.txt) return(dim2txt(ret, round=round)) return(ret) } printdims <- function(X, justTheValue=FALSE) { ## printdims is an older function. Not sure where it used? warning("2015-02-05 printdims() was just called.") 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)) } # ----------------- print.dim / print.dims ----------------- # 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, cols=4, rows=20, 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 (rows >= nrow(x)-2) rows <- seq(nrow(x)) else rows <- c(1:floor(rows/2), nrow(x) - ((ceiling(rows/2)-1):0) ) if (ncol(x) < 3) cols <- seq(ncol(x)) else cols <- unique(c( 1:min(ncol(x), (ifelse(missing(cols), 5, cols-2))), ncol(x) + (-1:0) ) ) return(x[rows, cols, with=FALSE]) } # else: ## Flip the arguments from relative to DT summary2(x, rows=cols, cols=rows, cmt) } # ----------------------- 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", h.rows=1, C=NULL, debug=FALSE ) { # 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 ## 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 browser(expr=debug) # 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 (any(grepl("\\n", nms))) { nms <- splitHeader(nms, valign="top", simplify=FALSE) h.rows <- max(sapply(nms, length)) } 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, h.rows=h.rows, debug=debug)) 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, h.rows=h.rows, debug=debug)) if (add.endl) ret[, ncol(ret)] <- paste0(ret[, ncol(ret)], "\n") if (matrix.lines.collapse) { ret <- apply(ret, 1, paste, collapse=" ") if (hbar) ret[[h.rows+1]] <- gsub("- -", "-|-", ret[[h.rows+1]]) } 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:h.rows], bar, if(length(ret) > h.rows) ret[(h.rows+1):length(ret)]) } if (shiftLeft > 0) ret <- paste0(pasteR(" ", shiftLeft), ret) if (!is.null(C)) ret <- pasteC(ret, C=C) return(ret) } splitHeader <- function(z, valign=c("top", "bottom"), simplify=TRUE) { z.ctr <- lapply(strsplit(z, "\n"), center, pad=0, header=FALSE, hbar=FALSE, trim.first=FALSE) L.max <- max(sapply(z.ctr, length)) sapply(z.ctr, function(z.ctr_i) if ({L<-length(z.ctr_i)}==L.max) return(z.ctr_i) else topbottom(z.ctr_i, rep(pasteR(" ", max(nchar(z.ctr_i))), L.max-L), valign) ,simplify=simplify) } topbottom <- function(x, filler, valign) { valign <- match.arg(valign) if (valign=="top") c(x, filler) else c(filler, x) } pco <- function(...) { # # browser() paste0(capture.output(eval( (...), envir=parent.frame())), collapse="\n") }