Compare two tables with the same structure by merging them

compare.tables <- function(d1, d2, by.idx = 1)
{ 
    ## Purpose: Compare two tables with the same structure by merging them. 
    ## Arguments:
    ##    d1: table A
    ##    d2: table B
    ##    by.idx: an index vector to common variables.
    ## Return: a full joined table for comparision

    b <- names(d1)[by.idx]
    d <- full_join(d1, d2, by = b)
    tex.print(d, type = "HTML")
    invisible(d)
}
if (F) {                                # Unit Test
    d1 <- rc()
    d2 <- rc()
    by.idx <- 1:4
    compare.tables(d1, d2, by.idx)
}

List duplicated files in a directory

list.dup.files <- function(p, file.name.head = 20)
{ 
    ## Purpose: List duplicated files in a directory. 
    ## Arguments:
    ##   file.name.head: number of starting characters in the file name to use for duplication detection
    ## Return: a list of file names that are duplicated (by sorted order). 
    ## Author: Feiming Chen, Date: 13 Nov 2017, 16:36
    ## ________________________________________________
    
    p1 <- dir(p)
    p2 <- sort(p1, decreasing = T)
    p3 <- as.character(sapply(p2, function(x) substr(x, 1, file.name.head)))
    p4 <- p2[duplicated(p3)]
    if (length(p4) > 0) {
        cat("Duplicated Older Files:\n")
        print(p4)
    } else {
        cat("NO Duplicated Files.\n")
    }
    file.path(p, p4)
}
if (F) {                                # Unit Test
    p <- "~/tmp/Updated-Databases"
    file.name.head <- 25
    x <- list.dup.files(p, file.name.head)
    file.remove(x)
}

Convert all character variables in your data.frame to factors

df.make.factors <- function(df)
{ 
    ## Purpose: Convert all character variables in your data.frame to factors 
    ## Arguments:
    ##   df: a data frame
    ## Return: a data frame with converted factors on those character variables.
    ## Author: Feiming Chen, Date: 17 Oct 2017, 14:26
    ## ________________________________________________

    character_vars <- sapply(df, class) == "character"
    df[, character_vars] <- lapply(df[, character_vars], factor)
    df
}
if (F) {                                # Unit Test
    df <- data.frame(x=c("x", "x", "y"), y=1:3, z=c("1", "3", "3"))
    df.make.factors(df)
}

Display a (numeric) vector in a pretty format

display.vector <- function(x)
{ 
    ## Purpose: Display a vector in a pretty format
    ## Arguments:
    ##   x: a vector
    ## Return: a png picture for the vector. (each row has 10 elements)
    ## Author: Feiming Chen, Date:  2 Oct 2017, 14:54
    ## ________________________________________________

    N <- length(x)
    n1 <- N %% 10
    if (n1 > 0) {
        n2 <- 10 - n1
        x.add <- rep(NA, n2)
        x <- c(x, x.add)
    }

    x1 <- matrix(x, ncol = 10, byrow = T)
    n2 <- nrow(x1)
    nr <- paste0(10 * (seq.int(n2) - 1) + 1, ": ")
    dimnames(x1) <- list(nr, 1:10)

    tex.print(x1)
}
if (F) {                                # Unit Test
    x <- c(402.6615584,402.1343365,402.5467634,401.835917,402.9268321,404.5185276,406.0735012,408.7713965,408.2033098,411.043676,413.953578,420.6021333,426.6352944,440.9007592,471.5614004,523.8426555,619.173643,782.3175971,1033.289048,1321.267143,1615.935774,1898.979548,2173.03472,2442.864835,2682.25644,2884.575978,3064.278857,3252.58248,3413.084683,3588.447246,3701.244129,3796.824264,3840.251429,3943.184319,4084.131835,4037.30822,4116.338229,4191.71438,4173.699815,4110.847391,4197.181334,4221.081422,4207.343855,4209.140892,4263.463393,4306.872737,4312.087451,4269.522631,4313.924265,4265.306511) 
    display.vector(x)
}

tex.print <- function(x, type=c("PNG", "HTML"), file=NULL, caption = file, digits=0, ...) {
    ## Purpose: Generate HTML or PNG representation of a data/table/model object.
    ##          Require R "memisc" package. 
    ## Arguments:
    ##   x: an object (table, ftable, data frame, model object, etc. that are acceptable in R "memisc" package.
    ##   type: what to generate -- 
    ##         "HTML" shows a HTML table in a web browser. 
    ##         "PNG" shows a PNG (image) file (require linux commands: latex, dvipng, display).
    ##   file: make a copy of the PNG file with this name.  Also used for the table name.
    ##   caption: table caption. 
    ##   digits: number of decimal places to use. 
    ##    ...: passed to "toLatex"
    ## Return: Display the data representation and an image file (type="PNG") for insertion. 
    ## Author: Feiming Chen, Date: 14 Feb 2017, 11:59
    ## ________________________________________________

    require(memisc)
    type <- match.arg(type)
    
    switch(type,
           HTML = {
               ## Show HTML table in a Web Browser
               memisc::show_html(x)      
           }, 
           PNG = {
               ## Generate LaTeX and PNG Image file
               r <- toLatex(x, ..., digits=digits, show.vars=TRUE)
               f <- file("X.tex", "w")
               writeLines(c("\\documentclass{article}",
                            "\\usepackage{booktabs}",
                            "\\usepackage{dcolumn}",
                            "\\begin{document}", 
                            "\\pagenumbering{gobble}"), f)
               if (!is.null(file)) writeLines("\\begin{table}  \\centering", f)

               writeLines(r, f)

               if (!is.null(caption)) {
                   writeLines(paste0("\\caption{", caption, "} \\end{table}"), f)
               }

               writeLines("\\end{document}", f)
               close(f)

               system("latex X.tex >/dev/null") # Generate DVI file from LaTeX file (X.tex -=> X.dvi)
               system("dvipng -q* -o X.png -T tight -D 200 X.dvi >/dev/null") # convert to PNG file with Tight box and Resolution of 200
               system("display X.png &")                                     # display the PNG file. 
               file.remove("X.tex", "X.log", "X.aux", "X.dvi")

               if (!is.null(file)) file.copy("X.png", paste0(file,".png"), overwrite = T) 
               if (!grepl("/tmp", getwd())) {
                   file.copy("X.png", "~/tmp/X.png", overwrite = T)
               }
           }
           )
    invisible(NULL)
}

Extracts all calls to a function (except for those in standard packages)

my.fun_calls <- function(f)
{ 
    ## Purpose: Extracts all calls to a function (except for those in standard packages) in a function 
    ##          Differs from pryr::fun_calls by excluding basic functions. 
    ## Arguments:
    ##   f: a function
    ## Return: All calls to a function (that are not in standard packages, e.g. base, stats, etc.)
    ## Author: Feiming Chen, Date:  7 Sep 2017, 11:23
    ## ________________________________________________

    if (is.function(f)) {
        my.fun_calls(body(f))
    } else if (is.call(f)) {
        fname <- as.character(f[[1]])
        if (identical(fname, ".Internal")) fname3 <- NULL
        f1 <- try(pryr::where(fname), silent = TRUE)
        if (is.tryerror(f1)) {
            if (fname[1] == "::") {   # Example: pryr::where  fname = c("::", "pryr", "where")
                fname3 <- paste0(fname[2], fname[1], fname[3])
            } else {
                fname3 <- NULL
            }
        } else {
            fname2 <- environmentName(f1)
            if (fname2 %in% c("base", "package:stats", "package:graphics", "package:grDevices", "package:utils", "package:datasets", "package:methods")) {
                fname3 <- NULL
            } else {
                if (fname2 == "R_GlobalEnv") {
                    fname3 <- fname
                } else {                # attach package name if other than Global Environment
                    fname2m <- sub("package:", "", fname2) # remove "package:" prefix. 
                    if (fname2m == "") {
                        fname3 <- paste0(fname)
                    } else {                         
                        fname3 <- paste0(fname2m, "::", fname) 
                    }
                }
            }
        }

        if (F) fun_calls(lm)            # for testing purpose only

        unique(c(fname3, unlist(lapply(f[-1], my.fun_calls), use.names = FALSE)))
    }
}
if (F) {                                # Unit Test
    my.fun_calls(lm)                    # NULL

    sort(my.fun_calls(my.fun_calls))
    ## "is.tryerror"     "my.fun_calls"    "pryr::fun_calls" "pryr::where"    
}


## Test for the try-error class (from "try" function)
is.tryerror <- function(x) inherits(x, "try-error")

Span: A Predicate Functional that finds the location of the longest sequential run of elements where the predicate is true

Span <- function(f, x)
{ 
    ## Purpose: A Predicate Functional that finds the location of the longest sequential run
    ##          of elements where the predicate is true. 
    ## Arguments:
    ##   f: a predicate (a function that returns a single TRUE or FALSE) 
    ##   x: a list or data frame
    ## Return: The location of the longest sequential run of elements where the predicate is true. 
    ## Author: Feiming Chen, Date: 28 Jun 2017, 09:45
    ## ________________________________________________

    y <- rle(Where(f, x))
    z <- y$lengths
    w <- which.max(z)          # position of the segment with longest sequential run of TRUE
    pos.end <- sum(z[1:w])
    pos.start <- pos.end - z[w] + 1
    c(start=pos.start, end=pos.end)
}
if (F) {                                # Unit Test
    x <- c(3, 1, NA, 4, NA, NA, NA, 5, 9, NA, NA)
    Span(is.na, x)
    ## start   end 
    ##     5     7 
}

Where <- function(f, x)
{ 
    ## Purpose: A Predicate Functional
    ## See other Predicate Functionals: Filter(), Find(), Position()
    ## See other Functionals: Map(), Reduce() 
    ## Arguments:
    ##   f: a predicate (a function that returns a single TRUE or FALSE) (e.g. is.character, all, is.NULL)
    ##   x: a list or data frame
    ## Return: a logical vector 
    ## Author: Feiming Chen, Date: 28 Jun 2017, 09:45
    ## ________________________________________________

    vapply(x, f, logical(1))
}
if (F) {                                # Unit Test
    df <- data.frame(x = 1:3, y = c("a", "b", "c"), stringsAsFactors = T)
    Where(is.factor, df)
    ## Compare with: 
    Filter(is.factor, df)
    Find(is.factor, df)
    Position(is.factor, df)
}

Draw a data frame as a R plot

my.table.plot0 <- function(x, 
                           highlight.matrix = NULL,
                           main = "Table", title2 = NULL, size = 20,
                           bold.lastrow = FALSE, bold.lastcol = FALSE
                           ) 
{
    ## PURPOSE: Draw a data frame as a R plot. Require R package "gridExtra". 
    ## ARGUMENT:
    ##    x: a data frame
    ##    highlight.matrix: if provided a logical matrix (same dimension as "x"). Then "TRUE" cells will be highlighted. 
    ##    main: title for the plot
    ##    title2: additional title with more verbose text
    ##    size: text size of table text
    ##    bold.lastrow: if T, make the last row bold font.
    ##    bold.lastcol: if T, make the last column bold font.
    ## RETURN: a plot
    ## DATE: 21 Nov 2016, 15:46
    ## -----------------------------------------------------

    x <- as.data.frame(x)
    n1 <- nrow(x)
    n2 <- ncol(x)
    cl <- matrix("black", n1, n2)
    cl[is.na(x)] <- "gray"

    ## Bold Total Column and Row
    cl2 <- cl
    cl2[] <- "plain"
    if (bold.lastrow) {
        cl2[n1,] <- "bold"
    }
    if (bold.lastcol) {
        cl2[, n2] <- "bold"
    }
    
    require(gridExtra)
    table_theme <- ttheme_default(base_size = size,
                                  core = list(fg_params=list(col=cl, fontface = cl2)))
    ## Highlight Cells
    if (!is.null(highlight.matrix)) {
        cl3 <- cl
        z <- ttheme_default()$core$bg_params$fill # default color
        z1 <- rep(z, length.out = nrow(cl3))
        for (i in 1:ncol(cl3)) cl3[,i] <- z1
        cl3[highlight.matrix] <- "yellow"
        table_theme$core$bg_params$fill <- cl3
    }

    plot.new()
    gridExtra::grid.table(as.data.frame(x), theme=table_theme)
    ## Title Text
    t2 <- ifelse(is.null(title2), "", paste0("\n", graph.title.split.lines(title2, sep=" ", num.chars = 40)))
    title(main = paste0(main, t2))

}
if (F) {                                # Unit Test 
    x <- data.frame(Type=c('Car', 'Plane'), Speed=c(NA, 200))
    my.table.plot0(x)
    my.table.plot0(x, main='Test', title2='a very complex test', size=30, bold.lastcol = T, highlight.matrix = matrix(c(NA, F, F, T) , 2, 2))
    x <- data.frame(Type=rep('Car', 20), Speed=rep(100, 20))
    my.table.plot0(x)
}

my.table.plot <- function(x, highlight.matrix = NULL, bold.lastrow = FALSE, n = 20, ...)
{ 
    ## Purpose: Split a data frame to fit in each page and call "my.table.plot0". 
    ## Arguments:
    ##   x: a data frame or matrix
    ##   highlight.matrix: if provided a logical matrix (same dimension as "x"). Then "TRUE" cells will be highlighted. 
    ##   bold.lastrow: if T, make the last row bold font.
    ##   n: how many rows to fit into each page.
    ##   ...: pass to "my.table.plot0". 
    ## Return: multiple plots to plot the data matrix. 
    ## Author: Feiming Chen, Date:  5 Jul 2017, 15:16
    ## ________________________________________________

    x <- as.data.frame(x)
    N <- nrow(x)
    if ( N <= n ) {
        my.table.plot0(x, highlight.matrix = highlight.matrix, bold.lastrow = bold.lastrow, ...)
    } else {
        s <- rep(seq.int(N %/% 20 + 1), each = n, length.out = N)
        xs <- split(x, s)
        
        ng <- length(xs)                # number of pages
        bold.lastrow.list <- c(rep(FALSE, ng-1), bold.lastrow)
        
        if (is.null(highlight.matrix)) {
            mapply(my.table.plot0, xs, bold.lastrow = bold.lastrow.list, MoreArgs = list(...))
        } else {
            ys <- split(highlight.matrix, s)
            mapply(my.table.plot0, xs, highlight.matrix = ys, bold.lastrow = bold.lastrow.list, MoreArgs = list(...))
        }
    }
}
if (F) {                                # Unit Test
     x <- data.frame(Type=rep('Car', 50), Speed=rep(100, 50))
     h <- matrix(rep(c(F, T), 50), ncol=2)
     my.table.plot(x, highlight.matrix = h, bold.lastrow = T)
}