R/tools.R

In sequinstandards/RAnaquin: Statistical analysis of sequins

.m2str <- function(m)
{
    eq <- substitute(italic(y) == a + b * italic(x)*','~~italic(r)^2~'='~r2, 
                     list(a  = format(coef(m)[1], digits = 2), 
                          b  = format(coef(m)[2], digits = 2), 
                          r2 = format(summary(m)$r.squared, digits = 3)))
    as.character(as.expression(eq));
}

.lm2str <- function(data)
{
    return (.m2str(lm(y~x, data)))
}

.setPanelSize <- function(p=NULL,
                          g=ggplotGrob(p),
                          file=NULL, 
                          margin = unit(1,"mm"),
                          width=unit(4, "cm"), 
                          height=unit(4, "cm"))
{
    panels <- grep("panel", g$layout$name)
    panel_index_w<- unique(g$layout$l[panels])
    panel_index_h<- unique(g$layout$t[panels])
    nw <- length(panel_index_w)
    nh <- length(panel_index_h)

    if (getRversion() < "3.3.0") {
        # the following conversion is necessary
        # because there is no `[<-`.unit method
        # so promoting to unit.list allows standard list indexing
        g$widths <- grid:::unit.list(g$widths)
        g$heights <- grid:::unit.list(g$heights)
        
        g$widths[panel_index_w] <-  rep(list(width),  nw)
        g$heights[panel_index_h] <- rep(list(height), nh)
    } else {
        g$widths[panel_index_w] <-  rep(width,  nw)
        g$heights[panel_index_h] <- rep(height, nh)
    }
    
    if (!is.null(file))
        ggsave(file, g, 
               width = convertWidth(sum(g$widths) + margin, 
                                    unitTo = "in", valueOnly = TRUE),
               height = convertHeight(sum(g$heights) + margin,  
                                      unitTo = "in", valueOnly = TRUE))
    
    invisible(g)
}

.env <- function(x) { x <- switch(Sys.getenv(x) != '', Sys.getenv(x), NULL); x }

.transformPlot <- function(p, square=TRUE)
{
    env <- function(x) { x <- switch(Sys.getenv(x) != '', Sys.getenv(x), NULL); x }

    family <- env('family')

    p <- p + theme(plot.title=element_text(face='bold', family=family, size=env('title.size')))
    p <- p + theme(strip.text=element_text(family=family, size=env('strip.size')))
    p <- p + theme(axis.text=element_text(family=family, size=env('axis.text')))
    
    if (!is.null(env('legend.position'))) { p <- p + theme(legend.position=env('legend.position')) }
    
    p <- p + theme(legend.direction=env('legend.direction'))
    p <- p + theme(legend.text=element_text(family=family, size=env('legend.text.size')))
    p <- p + theme(legend.title=element_text(family=family, face='bold', size=env('legend.title.size')))
    p <- p + theme(axis.title.x=element_text(face='bold', family=family, size=env('axis.size')))

    if (!is.null(env('axis.title.y.r')))
    {
        p <- p + theme(axis.title.y=element_text(margin=margin(r=env('axis.title.y.r')), face='bold', family=family, size=env('axis.size')))
    }
    else
    {
        p <- p + theme(axis.title.y=element_text(face='bold', family=family, size=env('axis.size')))
    }
    
    p <- p + theme(panel.border=element_rect(colour='black', fill=NA, size=1))
    p <- p + theme(legend.key=element_blank())
    
    if (square)
    {
        build <- ggplot_build(p)
        
        minX <- build$layout$panel_ranges[[1]]$x.range[[1]]
        maxX <- build$layout$panel_ranges[[1]]$x.range[[2]]
        minY <- build$layout$panel_ranges[[1]]$y.range[[1]]
        maxY <- build$layout$panel_ranges[[1]]$y.range[[2]]
        
        if (is.null(minX) && is.null(maxX) && is.null(minY) && is.null(maxY))
        {
            minX <- build$layout$panel_params[[1]]$x.range[[1]]
            maxX <- build$layout$panel_params[[1]]$x.range[[2]]
            minY <- build$layout$panel_params[[1]]$y.range[[1]]
            maxY <- build$layout$panel_params[[1]]$y.range[[2]]
        }
        
        stopifnot(!is.null(minX))
        stopifnot(!is.null(maxX))
        stopifnot(!is.null(minY))
        stopifnot(!is.null(maxY))    
        
        xrange <- maxX - minX
        yrange <- maxY - minY
        
        p <- p + coord_fixed(ratio=xrange/yrange)
    }
    
    if (!is.null(env('panelS')) && !is.null(env('panelF')))
    {
        .setPanelSize(p, file=env('panelF'),
                        width=unit(env('panelS'), "cm"),
                       height=unit(env('panelS'), "cm"))
    }
    
    return (p)
}

emptyPlot <- function(xl, yl, title)
{
    p <- ggplot() + xlab(xl) + ylab(yl) + ggtitle(title) + theme_bw() + theme(plot.title = element_text(hjust = 0.5))
    suppressWarnings(print(.transformPlot(p)))
}

# https://stackoverflow.com/questions/5173692/how-to-return-number-of-decimal-places-in-r
decs <- function(x)
{
    if ((x %% 1) != 0)
    {
        nchar(strsplit(sub('0+$', '', as.character(x)), ".", fixed=TRUE)[[1]][[2]])
    }
    else
    {
        return(0)
    }
}

# Fixed decimals (https://stackoverflow.com/questions/3443687/formatting-decimal-places-in-r/12135122)
fixedDec <- function(x, k) trimws(format(round(x, k), nsmall=k))

as.numeric.factor <- function(x) { if (is.factor(x)) { suppressWarnings(as.numeric(levels(x))[x]) } else { x } }