R/util.R

In plotfunctions: Various Functions to Facilitate Visualization of Data and Analysis

#' Replacing separators (for example, decimal and thousand separators).
#' 
#' @export
#' @param filename String: filename (including path if necessary) of input file.
#' @param symbol1 String: symbol to replace by \code{newsymbol1}, for example 
#' decimal separator. 
#' @param symbol2 String: second symbol to replace by \code{newsymbol2}, 
#' for example thousand separator.  
#' @param newsymbol1 String: symbol to replace \code{symbol1}. 
#' @param newsymbol2 String: symbol to replace \code{symbol2}.
#' @param sep String: column separator. Could be also used to replace symbols 
#' in the header and data by \code{newsep}, regardless of columns.  
#' @param newsep String: symbol to replace \code{sep}. 
#' Only possible when \code{columns} is set to NULL.
#' @param header Logical: whether or not there is header line. \code{symbol1} 
#' and \code{symbol2} are not replaced in the header line. Default set to TRUE.
#' @param columns Vector with numerical values: indices of columns in which 
#' symbols need to be replaced.
#' @param outputfile String: name of outputfile.
#' @param fixed.s1 Logical: whether or not to treat \code{symbol1} as fixed 
#' text instead of regular expression. Default is set to TRUE 
#' (no regular expression).
#' @param fixed.s2 Logical: whether or not to treat \code{symbol2} as fixed 
#' text instead of regular expression. Default is set to TRUE 
#' (no regular expression).
#' @param fixed.sep Logical: whether or not to treat \code{sep} as fixed 
#' text instead of regular expression. Default is set to TRUE 
#' (no regular expression).
#' @param ... Additional parameters for \code{\link[utils]{read.table}} and 
#' \code{\link[utils]{write.table}}.
#' @author Jacolien van Rij
#' @examples
#' \dontrun{
#' # normally, the function call would look something like this:
#' convertFile('example1.csv', symbol1=',', symbol2='.', sep='\t', 
#'     newsymbol1='.', newsymbol2='')
#' # But as we are not sure that the file example1.csv is available,
#' # we need to do something a little more complicated to point to 
#' # the file 'example1.csv' that comes with the package:
#' 
#' # finding one of the example files from the package:
#' file1 <- system.file('extdata', 'example1.csv', package = 'plotfunctions')
#' 
#' # example 1: 
#' system.time({
#'     convertFile(file1, symbol1=',', symbol2='.', 
#'     newsymbol1='.', newsymbol2='', outputfile='example1_new.csv')
#' })
#' # example 2: type 'yes' to overwrite the previous output file, 
#' # or specify a different filename in outputfile.
#' system.time({
#'     convertFile(file1, symbol1=',', symbol2='.', sep='\t', 
#'     newsymbol1='.', newsymbol2='', columns=1:2, outputfile='example1_new.csv')
#' })
#' # Example 1 takes less  time, as it does not use read.table, 
#' # but just reads the file as text lines. However, the column 
#' # version could be useful when symbols should be replaced only 
#' # in specific columns.
#' # Note that Example 2 writes the output with quotes, but this is 
#' # not a problem for read.table:
#' dat <- read.table('example1_new.csv', header=TRUE, sep='\t', 
#'     stringsAsFactors=FALSE)
#' }
convertFile <- function(filename, symbol1 = NULL, symbol2 = NULL, newsymbol1 = "", newsymbol2 = "", sep = ";", 
    newsep = NULL, header = TRUE, columns = NULL, outputfile = gsub("^(.*)(\\.)([^\\.]*)$", "\\1_new.\\3", 
        filename), fixed.s1 = TRUE, fixed.s2 = TRUE, fixed.sep = TRUE, ...) {
    # some checks:
    if (filename == outputfile) {
        stop("Filename has no extension, please provide name for outputfile to avoid the original file to get overwritten.")
    }
    if (!is.null(columns)) {
        if (!is.numeric(columns)) {
            stop("Argument columns needs to be a vector with numeric values.")
        }
    }
    if (file.exists(outputfile)) {
        ans = ""
        while (!tolower(ans) %in% c("yes", "no", "y", "n")) {
            ans <- readline(sprintf("File %s already exists. Do you want to overwrite? [yes/no] ", outputfile))
        }
        if (ans %in% c("no", "n")) {
            stop("Please provide a new name for the outputfile.")
        }
    }
    rs1 <- tempfile(pattern = "&", tmpdir = "", fileext = "")
    rs2 <- tempfile(pattern = "&", tmpdir = "", fileext = "")
    rsep <- tempfile(pattern = "&", tmpdir = "", fileext = "")
    # first read in the data as text strings
    tmp <- readLines(filename, n = -1)
    colnames <- NULL
    if (header) {
        colnames <- tmp[1]
        tmp <- tmp[2:length(tmp)]
    }
    # Only specific columns:
    if (!is.null(columns)) {
        
        if ("colClasses" %in% names(list(...))) {
            tmp <- read.table(file = filename, header = header, sep = sep, ...)
        } else {
            tmp <- read.table(file = filename, header = header, sep = sep, colClasses = "character", ...)
        }
        
        # conversion stage 1:
        if (!is.null(symbol1)) {
            if (!is.null(symbol2)) {
                if (symbol1 == symbol2) {
                  warning("symbol1 equals symbol2. The string will be replaced by newsymbol1.")
                }
            }
            if (!is.null(sep)) {
                if (symbol1 == sep) {
                  warning("symbol1 equals sep. The string will be replaced by newsymbol1.")
                }
            }
            for (c in columns) {
                tmp[, c] <- gsub(symbol1, rs1, tmp[, c], fixed = fixed.s1)
            }
        }
        if (!is.null(symbol2)) {
            if (!is.null(sep)) {
                if (symbol2 == sep) {
                  warning("symbol2 equals sep. The string will be replaced by newsymbol2.")
                }
            }
            for (c in columns) {
                tmp[, c] <- gsub(symbol2, rs2, tmp[, c], fixed = fixed.s2)
            }
        }
        # conversion stage 2:
        if (!is.null(symbol1)) {
            for (c in columns) {
                tmp[, c] <- gsub(rs1, newsymbol1, tmp[, c], fixed = fixed.s1)
            }
        }
        if (!is.null(symbol2)) {
            for (c in columns) {
                tmp[, c] <- gsub(rs2, newsymbol2, tmp[, c], fixed = fixed.s2)
            }
        }
        
        write.table(tmp, file = outputfile, append = FALSE, sep = ifelse(is.null(newsep), sep, newsep), row.names = FALSE, 
            col.names = ifelse(header, TRUE, FALSE), ...)
        # In all columns (faster):
    } else {
        # conversion stage 1:
        if (!is.null(symbol1)) {
            if (!is.null(symbol2)) {
                if (symbol1 == symbol2) {
                  warning("symbol1 equals symbol2. The string will be replaced by newsymbol1.")
                }
            }
            if (!is.null(sep)) {
                if (symbol1 == sep) {
                  warning("symbol1 equals sep. The string will be replaced by newsymbol1.")
                }
            }
            tmp <- gsub(symbol1, rs1, tmp, fixed = fixed.s1)
        }
        if (!is.null(symbol2)) {
            if (!is.null(sep)) {
                if (symbol2 == sep) {
                  warning("symbol2 equals sep. The string will be replaced by newsymbol2.")
                }
            }
            tmp <- gsub(symbol2, rs2, tmp, fixed = fixed.s2)
        }
        if (!is.null(newsep)) {
            if (header) {
                colnames <- gsub(sep, rsep, colnames, fixed = fixed.sep)
            }
            tmp <- gsub(sep, rsep, tmp, fixed = fixed.sep)
        }
        # conversion stage 2:
        if (!is.null(symbol1)) {
            tmp <- gsub(rs1, newsymbol1, tmp, fixed = fixed.s1)
        }
        if (!is.null(symbol2)) {
            tmp <- gsub(rs2, newsymbol2, tmp, fixed = fixed.s2)
        }
        if (!is.null(newsep)) {
            if (header) {
                colnames <- gsub(rsep, newsep, colnames, fixed = fixed.sep)
            }
            tmp <- gsub(rsep, newsep, tmp, fixed = fixed.sep)
        }
        # write file:
        newfile <- file(outputfile, "w")
        if (header) {
            cat(colnames, tmp, sep = "\n", file = newfile)
        } else {
            cat(tmp, sep = "\n")
        }
        close(newfile)
    }
}





#' Return n neighbors around given indices.
#' 
#' @export
#' @import grDevices
#' @import graphics
#' @param el A numeric vector.
#' @param n Number indicating how many points around the elements of \code{el} 
#' need to be selected.
#' @param max The maximum value of the returned elements.
#' @return A vector with the elements of x surrounded by n points.
#' @examples
#' vectorIndices <- 1:1000
#' indOutliers <- c(2,10, 473, 359, 717, 519)
#' fn3 <- find_n_neighbors(indOutliers, n=3, max=max(vectorIndices))
#' fn20 <- find_n_neighbors(indOutliers, n=20, max=max(vectorIndices))
#'
#' # check fn3:
#' print(fn3)
#'
#' # Plot:
#' emptyPlot(c(-10,1000), c(-1,1), h0=0, v0=indOutliers)
#' points(fn3, rep(.5, length(fn3)), pch='*')
#' points(fn20, rep(-.5, length(fn20)), pch='*')
#' @author Jacolien van Rij
#' @family Utility functions
find_n_neighbors <- function(el, n, max) {
    if (length(el) > 0) {
        new_el <- sort(unique(unlist(lapply(el, FUN = function(x) {
            return(sort(unique(c(x, (x - n):x, x:(x + n)))))
        }))))
        new_el <- new_el[new_el >= 1 & new_el <= max]
        return(new_el)
    } else {
        return(NULL)
    }
}





#' Return the value (or the element with the value) closest to zero. 
#' 
#' @export
#' @import stats
#' @param x A numeric vector.
#' @param element Logical: whether or not to return the value (FALSE, default) 
#' or the index (TRUE).
#' @return The value or index of the element closest to zero (absolute 
#' minimum).
#' @examples
#' (test <- seq(-25,25, by=3))
#' min(test[test>0])
#' max(test[test<0])
#' min(abs(test))
#' findAbsMin(test)
#' @author Jacolien van Rij
#' @family Utility functions
findAbsMin <- function(x, element = FALSE) {
    abs_x <- abs(x)
    el <- max(which(abs_x == min(abs_x)))
    if (element) {
        return(el)
    } else {
        return(x[el])
    }
}





#' Capitalize first letter of a string.
#' 
#' @export
#' @param x Text string
#' @return Text string
#' @family Utility functions
firstLetterCap <- function(x) {
    s <- strsplit(x, split = "")
    s <- unlist(lapply(s, function(y) {
        y[1] = toupper(y[1])
        return(paste(y, collapse = ""))
    }))
    return(s)
}





#' Retrieve the color scheme for contour plots.
#' 
#' @export
#' @import grDevices
#' @param color A string, or vector of strings, indicating a color palette. 
#' Includes: 'topo', 'heat', 'bwr', 'cm', 'terrain', 'bpy', 'gray', 'bw',
#' or user defined colors.
#' @param nCol The number of colors to use in color schemes. 
#' @param col Color of contour lines for the contour plots. 
#' If NULL (default), a color is determined, depending on the color palette.
#' @return Color palette.
#' @examples 
#' pal <- get_palette('terrain', nCol=10)
#' names(pal)
#' image(matrix(1:10, ncol=10), col=pal$color, axes=FALSE)
#' # user defined color palette:
#' pal <- get_palette(c('green', 'orange', 'red'))
#' image(matrix(1:10, ncol=10), col=pal$color, axes=FALSE)
#' 
#' @family Utility functions
#' @seealso \code{\link{plotsurface}}, \code{\link{gradientLegend}}
#' 
get_palette = function(color, nCol = 50, col = NULL) {
    con.col <- 1
    pal <- c()
    if (color[1] == "heat") {
        pal <- heat.colors(nCol)
        con.col <- 3
    } else if (color[1] == "topo") {
        pal <- topo.colors(nCol)
        con.col <- 2
    } else if (color[1] == "bwr") {
        pal <- colorRampPalette(c("blue", "white", "red"))(nCol)
        con.col <- 2
    } else if (color[1] == "cm") {
        pal <- cm.colors(nCol)
        con.col <- 1
    } else if (color[1] == "terrain") {
        pal <- terrain.colors(nCol)
        con.col <- 2
    } else if (color[1] == "bpy") {
        if (requireNamespace("sp", quietly = TRUE)) {
            pal <- sp::bpy.colors(nCol)
            con.col <- 1
        } else {
            warning("Package 'sp' needed for bpy color palette. Using topo.colors instead (default).")
            color <- "terrain"
            pal <- terrain.colors(nCol)
            con.col <- 2
        }
    } else if (color[1] == "gray" || color[1] == "bw") {
        pal <- gray(seq(0.1, 0.9, length = nCol))
        con.col <- 1
    } else {
        if (all(plotfunctions::isColor(color))) {
            pal <- colorRampPalette(color)(nCol)
            con.col <- 1
        } else {
            stop("color scheme not recognised")
        }
    }
    if (!is.null(col)) {
        con.col <- col[1]
    }
    return(list(color = pal, col = con.col))
}





#' Converts coordinates in current plot region to device positions (in inch).
#'
#' @export
#' @param x Numeric: x coordinate(s)
#' @param y Numeric: y coordinate(s)
#' @param units Coordinates (default) or proportions with respect to 
#' plot region.
#' @param dev x and y position are measured with respect to the 
#' plot region (default), figure panel, or device.
#' @return list 
#' @family Utility functions
getArrowPos <- function(x, y, units = c("coords", "prop"), dev = c("plot", "figure", "panel")) {
    # process input
    dev = tolower(dev[1])
    if (!dev %in% c("plot", "fig", "dev")) {
        warning(sprintf("Incorrect device (dev) '%s'. Must be 'plot', 'fig' (figure), or 'dev' (device). By default 'plot' is selected.", 
            dev))
        dev = "plot"
    }
    units = tolower(units[1])
    if (!units %in% c("prop", "coords", "proportions", "coordinates", "p", "c")) {
        warning(sprintf("Incorrect units '%s'. Must be 'prop'/'p' (proportions), or 'coords'/'c' (coordinates). By default 'coords' is selected.", 
            units))
        units = "coords"
    } else {
        if (tolower(substr(units, 1, 1)) == "p") {
            units = "prop"
        } else if (tolower(substr(units, 1, 1)) == "c") {
            units = "coords"
        }
    }
    if ((dev != "plot") & units == "coords") {
        warning(sprintf("Units will be set to 'prop' (proportions), because dev is set to '%s'. So x and y are proportions of the %s region.", 
            dev))
        units = "prop"
    }
    
    # convert input din = device dimensions, fin = figure dimensions, pin = plot dimensions plt = A vector of
    # the form c(x1, x2, y1, y2) giving the coordinates of the plot region as fractions of the current figure
    # region.  fig = fig A numerical vector of the form c(x1, x2, y1, y2) which gives the (NDC) coordinates of
    # the figure region in the display region of the device.  usr = A vector of the form c(x1, x2, y1, y2)
    # giving the extremes of the user coordinates of the plotting region.
    x2 <- NULL
    y2 <- NULL
    d <- par()$din
    f <- par()$fin
    p <- par()$pin
    if (dev == "plot") {
        # convert coords to proportions of plot region
        if (units == "coords") {
            pr <- par()$usr
            x <- (x - pr[1])/(pr[2] - pr[1])
            y <- (y - pr[3])/(pr[4] - pr[3])
        }
        # convert to coords of fig region (inches):
        pr <- par()$plt
        x2 <- x * p[1] + pr[1] * f[1]
        y2 <- y * p[2] + pr[3] * f[2]
        # convert to coords of dev region (inches):
        pr <- par()$fig
        x2 <- x2 + d[1] * pr[1]
        y2 <- y2 + d[2] * pr[3]
    } else if (dev == "fig") {
        # convert to coords of dev region (inches):
        pr <- par()$fig
        x2 <- x * f[1] + d[1] * pr[1]
        y2 <- y * f[2] + d[2] * pr[3]
    } else if (dev == "dev") {
        # convert to coords of dev region (inches):
        pr <- par()$fig
        x2 <- x * d[1]
        y2 <- y * d[2]
    }
    return(list(x = x2, y = y2))
}





#' Return the number of decimal places.
#' 
#' @export
#' @import stats
#' @param x A numeric vector.
#' @return Number of decimals
#' @examples
#' getDec(c(10,10.432, 11.01, .000001))
#' @author Based on http://stackoverflow.com/questions/5173692/how-to-return-number-of-decimal-places-in-r, but improved
#' @family Utility functions
#' 
getDec <- function(x) {
    dec <- 0
    dec <- sapply(x, function(a) {
        if ((a%%1) != 0) {
            chnum <- as.character(a)
            if (grepl("e\\+", chnum)) {
                return(0)
            } else if (grepl("e\\-", chnum)) {
                return(as.numeric(gsub("^([0-9]+)(e\\-)([0-9]+)$", "\\3", chnum)))
            } else {
                return(nchar(unlist(strsplit(sub("0+$", "", chnum), ".", fixed = TRUE))[[2]]))
            }
        } else {
            return(0)
        }
    })
    return(dec)
}





#' Function for rounding and/or segmenting a range.
#' 
#' @export
#' @import stats
#' @param x A numeric vector.
#' @param dec Number of decimal points for rounding using function 
#' \code{\link[base]{round}}. Applied after argument 
#' \code{step}. If NULL (default), no rounding is applied.
#' @param step Round the 
#' @param n.seg Numeric value, number of values in the equally spaced sequence. 
#' Default is 2 (min, max).
#' @return vector, range of equally spaced sequence.
#' @examples
#' zlim <- c(-2.5, 3.01)
#' # does not change anything:
#' getRange(zlim)
#' # create a range of 5 numbers: 
#' # (basically just using seq )
#' getRange(zlim, n.seg=5)
#' # rounds the numbers:
#' getRange(zlim, dec=0)
#' getRange(zlim, n.seg=5, dec=0)
#' # extreme values are multiplications of 5
#' # that contains zlim values:
#' getRange(zlim, step=5)
#' getRange(zlim, step=5, n.seg=5)
#' # similar, but not the same:
#' getRange(zlim, n.seg=5, dec=0)
#' getRange(zlim, n.seg=5, step=1)
#' # combining:
#' getRange(zlim, n.seg=5, step=1, dec=0)
#' 
#' @author Jacolien van Rij
#' @family Utility functions
#' 
getRange <- function(x, dec = NULL, step = NULL, n.seg = 2) {
    vals <- seq(min(x), max(x), length = n.seg)
    if (!is.null(step)) {
        vals <- seq(floor(min(x)/step) * step, ceiling(max(x)/step) * step, length = n.seg)
    }
    if (!is.null(dec)) {
        vals <- round(vals, dec)
    }
    return(vals)
}





#' Move a vector n elements forward or backward.
#' 
#' @export
#' @param ratio Numeric, height : width ratio. If \code{ratio} > 1, the width is 
#' larger than the height, if \code{ration} < 1, the height is 
#' larger than the width.
#' @param width The desired width in plot coordinates or proportions. 
#' If not specified (NULL), 
#' the maximal width fitting in the plot region is returned.
#' @param height The desired height in plot coordinates or proportions. 
#' If not specified (NULL), 
#' the maximal height fitting in the plot region is returned.
#' @param input Unit of input width and height, 'coords' (plot coordinates, default),
#' or 'prop' (proportions of plot region).
#' @param ... Optional arguments: \code{xcenter}, \code{xleft}, or 
#' \code{xright}, and \code{ycenter}, \code{ybottom}, or 
#' \code{ytop} could be specified. If not specified, the width and height are 
#' centered around the center of the plot. 
#' @return A list with 5 elements:
#' \itemize{
#' \item \code{width}: width of the element in x-axis coordinates;
#' \item \code{height}: height of the element in y-axis coordinates;
#' \item \code{ratio}: provided ratio (for confirmation);
#' \item \code{x}: two-number vector with x-coordinates of 
#' left and right sides;
#' \item \code{y}: two-number vector with y-coordinates of 
#' bottom and top sides.
#' }
#' @examples
#' data(img)
#' emptyPlot(100, c(50, 100), h0=0, v0=0)
#' # calculate height : width ratio of image:
#' im.r <- dim(img$image)[1]/dim(img$image)[2]
#' p <- getRatioCoords(ratio=im.r, width=20)
#' # inspect p:
#' p
#' # No position specified, so centered:
#' plot_image(img, type='image', add=TRUE,
#'     xrange=p$x, yrange=p$y)
#' # ... or we could provide a position:
#' p <- getRatioCoords(ratio=im.r, width=20,
#'     xleft=20, ybottom=60)
#' plot_image(img, type='image', add=TRUE,
#'     xrange=p$x, yrange=p$y)
#' 
#' # Using proportions of plot region:
#' p <- getRatioCoords(ratio=im.r, height=.5,
#'     xleft=0, ytop=1, input='prop')
#' plot_image(img, type='image', add=TRUE,
#'     xrange=p$x, yrange=p$y)
#' 
#' # Changing the ratio to square:
#' p <- getRatioCoords(ratio=1, height=.5,
#'     xright=1, ybottom=0, input='prop')
#' plot_image(img, type='image', add=TRUE,
#'     xrange=p$x, yrange=p$y)
#' # ... and to a long rectangle:
#' p <- getRatioCoords(ratio=.5, height=1,
#'     xright=1, ybottom=0, input='prop')
#' plot_image(img, type='image', add=TRUE,
#'     xrange=p$x, yrange=p$y, 
#'     replace.colors=list('#B.+'='#FF000033'),
#'     border='red')
#' 
#' @author Jacolien van Rij
#' @family Utility functions
getRatioCoords <- function(ratio, width = NULL, height = NULL, input = c("coords", "prop"), ...) {
    # global variables:
    out.width = NULL
    out.height = NULL
    gfc = getFigCoords("p")
    pin.c = c(gfc[2] - gfc[1], gfc[4] - gfc[3])  # in coordinates
    pin.i = par()$pin  # in inches
    pin.f = pin.c/pin.i  # recalculating c/in
    xleft = NULL
    ybottom = NULL
    # check input
    if (length(input) > 1) {
        input = input[1]
    }
    if (!input %in% c("coords", "prop")) {
        stop(sprintf("Input '%s' not valid - should be one of 'coords' or 'prop'.", input))
    }
    if (is.null(width) & is.null(height)) {
        if (ratio > 1) {
            height = gfc[4] - gfc[3]
        } else {
            width = gfc[2] - gfc[1]
        }
    }
    # first convert height to inches
    if (is.null(width)) {
        if (input == "prop") {
            height = height * pin.c[2]
        }
        out.height = height * (1/pin.f[2])
        out.width = ratio * out.height
    } else {
        if (!is.null(height)) {
            warning("Both width and height are provided. Height is recalculated based on ratio.")
        }
        if (input == "prop") {
            width = width * pin.c[1]
        }
        out.width = width * (1/pin.f[1])
        out.height = ratio * out.width
    }
    # then calculate back to coordinates
    out.height = out.height * pin.f[2]
    out.width = out.width * pin.f[1]
    par = list(...)
    if (input == "coords") {
        if ("xcenter" %in% names(par)) {
            xleft = par[["xcenter"]] - (0.5 * out.width)
        } else if ("xleft" %in% names(par)) {
            xleft = par[["xleft"]]
        } else if ("xright" %in% names(par)) {
            xleft = par[["xright"]] - out.width
        } else {
            xleft = gfc[1] + pin.c[1]/2 - (0.5 * out.width)
        }
        if ("ycenter" %in% names(par)) {
            ybottom = par[["ycenter"]] - (0.5 * out.height)
        } else if ("ybottom" %in% names(par)) {
            ybottom = par[["ybottom"]]
        } else if ("ytop" %in% names(par)) {
            ybottom = par[["ytop"]] - out.height
        } else {
            ybottom = gfc[3] + pin.c[2]/2 - (0.5 * out.height)
        }
    } else {
        if ("xcenter" %in% names(par)) {
            xleft = gfc[1] + par[["xcenter"]] * pin.c[1] - (0.5 * out.width)
        } else if ("xleft" %in% names(par)) {
            xleft = gfc[1] + par[["xleft"]] * pin.c[1]
        } else if ("xright" %in% names(par)) {
            xleft = gfc[1] + par[["xright"]] * pin.c[1] - out.width
        } else {
            xleft = gfc[1] + pin.c[1]/2 - (0.5 * out.width)
        }
        if ("ycenter" %in% names(par)) {
            ybottom = gfc[3] + par[["ycenter"]] * pin.c[2] - (0.5 * out.height)
        } else if ("ybottom" %in% names(par)) {
            ybottom = gfc[3] + par[["ybottom"]] * pin.c[2]
        } else if ("ytop" %in% names(par)) {
            ybottom = gfc[3] + par[["ytop"]] * pin.c[2] - out.height
        } else {
            ybottom = gfc[3] + pin.c[2]/2 - (0.5 * out.height)
        }
    }
    return(list(width = out.width, height = out.height, ratio = ratio, x = c(xleft, xleft + out.width), y = c(ybottom, 
        ybottom + out.height)))
}





#' Sort split by grouping predictor.
#' 
#' @export
#' @description Function uses \code{\link[base]{sort.list}} to return indices
#' of of a vector, sorted per group.
#' @param x A vector to be sorted.
#' @param group A names list that specify the different groups to split the 
#' data.
#' @param decreasing Logical: whether or not the sort order should be 
#' decreasing.
#' @return Indices indicating the order of vector x per group.
#' @author Jacolien van Rij
#' @examples
#' # example InsectSprays from R datasets
#' InsectSprays$Type <- ifelse(InsectSprays$spray %in% c('A','B', 'F'), 1, 2)
#' 
#' ind <- group_sort(InsectSprays$count, 
#'     group=list(Spray=InsectSprays$spray, Type=InsectSprays$Type))
#' InsectSprays[ind,]
#' InsectSprays
#' @seealso \code{\link[base]{sort.list}}
#' @family Utility functions
group_sort <- function(x, group = NULL, decreasing = FALSE) {
    if (is.null(group)) {
        return(sort.list(as.numeric(x), decreasing = decreasing))
    } else {
        el <- which(is.na(x))
        tmp <- data.frame(x = x, i = 1:length(x))
        x.split <- split(tmp, f = group, drop = TRUE)
        x.split <- as.vector(unlist(lapply(x.split, function(x) {
            x[sort.list(as.numeric(x$x), decreasing = decreasing), "i"]
        })))
        if (length(el) > 0) {
            x.split <- c(x.split, el[!el %in% x.split])
        }
        return(x.split)
    }
}





#' Convert device position (inch) to coordinates in current plot region.
#'
#' @export
#' @param xpos x position in device, inches between position and left side 
#' of device.
#'  When defined as two-number vector, x- and y-position as measured from 
#' bottomleft corner of device.
#' @param ypos y position (in inches) from bottom of device.
#' @param simplify Logical: whether or not to output a vector instead of a list.
#' @return list or 2-number vector
#' @family Utility functions
#' 
inch2coords <- function(xpos, ypos = NULL, simplify = FALSE) {
    # convert position in device to currect plot region
    x <- NULL
    y <- NULL
    if (!is.null(ypos)) {
        x <- xpos
        y <- ypos
        if (length(x) != length(y)) {
            stop("pos and ypos need to have the same length.")
        }
    } else {
        if (length(xpos) < 2) {
            stop("If ypos is not specified, xpos needs to be a two-element vector c(x,y).")
        }
        if (is.list(xpos)) {
            x <- xpos[[1]]
            y <- xpos[[2]]
        } else {
            x <- xpos[1]
            y <- xpos[2]
        }
        
    }
    x2 <- NULL
    y2 <- NULL
    d <- par()$din
    f <- par()$fin
    p <- par()$pin
    # 1. calc proportion of dev
    x <- x/d[1]
    y <- y/d[2]
    # 2. calc prop region as proportion of dev
    pr <- par()$fig
    curfig <- c(pr[1], pr[1] + f[1]/d[1], pr[3], pr[3] + f[2]/d[2])
    pr <- par()$plt
    curplot <- c(pr[1] * (f[1]/d[1]) + curfig[1], pr[2] * (f[1]/d[1]) + curfig[1], pr[3] * (f[2]/d[2]) + curfig[3], 
        pr[4] * (f[2]/d[2]) + curfig[3])
    # 3. convert new position to coords:
    pr <- par()$usr
    x2 <- (x - curplot[1])/(curplot[2] - curplot[1])
    x2 <- x2 * (pr[2] - pr[1]) + pr[1]
    y2 <- (y - curplot[3])/(curplot[4] - curplot[3])
    y2 <- y2 * (pr[4] - pr[3]) + pr[3]
    if (simplify) {
        if (length(x2) == 1) {
            return(c(x2, y2))
        }
    }
    return(list(x = x2, y = y2))
}





#' Check whether color specifications exists.
#'
#' @export
#' @import grDevices
#' @description Function to check whether all specified colors are 
#' actual colors.
#' @param x Vector of any of the three kinds of R color specifications, 
#' i.e., either a color name (as listed by 
#' \code{\link[grDevices]{palette}colors()}), a hexadecimal string of the form 
#' '#rrggbb' or '#rrggbbaa' (see rgb), or a positive integer i meaning 
#' \code{\link[grDevices]{palette}()[i]}.
#' @param return.colors Logical: logical values (FALSE, default) or 
#' returning colors (TRUE)
#' @author Jacolien van Rij
#' @return Logical value (or colors)
#' @family Utility functions
#' @examples
#' # correct color definitions:
#' isColor(c('#FF0000FF', '#00FF00FF', '#0000FFFF'))
#' isColor(c('red', 'steelblue', 'green3'))
#' isColor(c(1,7,28))
#' # mixtures are possible too:
#' isColor(c('#FF0000FF', 'red', 1, '#FF0000', rgb(.1,0,0)))
#' 
#' # return colors:
#' # note that 28 is converted to 4...
#' isColor(c(1,7,28), return.colors=TRUE) 
#' isColor(c('#FF0000CC', 'red', 1, '#FF0000'), return.colors=TRUE)
#' 
#' # 4 incorrect colors, 1 correct:
#' test <- c('#FH0000', 3, '#FF00991', 'lavendel', '#AABBCCFFF')
#' isColor(test)
#' isColor(test, return.colors=TRUE)
#' 
isColor <- function(x, return.colors = FALSE) {
    # numeric colors, max 8
    if (is.numeric(x)) {
        if (!return.colors) {
            return(x > 0 & (x%%1 == 0))
        } else {
            return(palette()[(x - 1)%%8 + 1])
        }
    }
    # convert any numeric values:
    if (any(grepl("^[0-9]+$", x))) {
        x[grepl("^[0-9]+$", x)] <- palette()[(as.numeric(x[grepl("^[0-9]+$", x)]) - 1)%%8 + 1]
    }
    
    # color names and hexadecimal colors
    y <- grepl("^\\#[a-fA-F0-9]{6}$", x) | grepl("^\\#[a-fA-F0-9]{8}$", x) | (x %in% colors())
    if (!return.colors) {
        return(y)
    } else {
        x[!y] <- NA
        return(x)
    }
}





#' Combine list values as string.
#'
#' @export
#' @param x A vector with the names or numbers of list elements to be combined.
#' @param inputlist A (named) list with information, e.g., graphical parameter settings.
#' @return String
#' @examples
#' test <- list(a=c(1,2,3), b='a', c=c(TRUE, FALSE), d='test')
#' list2str(c('a','c', 'd'), test) 
#' @family Utility functions
list2str <- function(x, inputlist) {
    out <- c()
    for (i in x) {
        name.i <- NULL
        val.i <- NULL
        if (is.numeric(i)) {
            if (i > 0 & i <= length(inputlist)) {
                name.i <- sprintf("el%.0f", i)
                val.i <- inputlist[[i]]
            }
        } else if (i %in% names(inputlist)) {
            name.i <- i
            val.i <- inputlist[[i]]
        }
        if (!is.null(name.i)) {
            if (inherits(val.i, c("numeric", "logical"))) {
                out <- c(out, sprintf("%s=c(%s)", name.i, paste(val.i, collapse = ",")))
            } else if (inherits(val.i, c("character", "factor"))) {
                out <- c(out, sprintf("%s=c(%s)", name.i, paste(sprintf("'%s'", val.i), collapse = ",")))
            } else {
                warning(sprintf("Class %s is not supported, element %s is ignored.", class(name.i)[1], name.i))
            }
        }
    }
    return(paste(out, collapse = ", "))
}





#' Move a vector n elements forward or backward.
#' 
#' @export
#' @param x A vector.
#' @param n Number indicating how many steps the vector should shift forward 
#' (N > 0) or backward (n < 0).
#' @param na_value The value to replace the empty cells with (e.g., the first 
#' or last points). Defaults to NA.
#' @return A vector with the same length of \code{x}, all moved \code{n} steps.
#' @examples
#' (x <- -10:30)
#' prev <- move_n_point(x)
#' change <- x - prev
#' post5 <- move_n_point(x, n=-5)
#'
#' emptyPlot(length(x), range(x))
#' lines(x)
#' lines(prev, col='red')
#' lines(post5, col='blue')
#'
#' @author Jacolien van Rij
#' @family Utility functions
move_n_point <- function(x, n = 1, na_value = NA) {
    x <- as.vector(x)
    
    if (length(x) > abs(n)) {
        if (n > 0) {
            return(c(rep(na_value, n), x[1:(length(x) - n)]))
        } else {
            return(c(x[(abs(n) + 1):(length(x))], rep(na_value, abs(n))))
        }
    } else if (length(x) == abs(n)) {
        return(NA)
    } else {
        return(NULL)
    }
}





#' Calculate standard error of the mean.
#' 
#' @import datasets
#' @import grDevices
#' @import utils
#' @export
#' @param x A vector.
#' @param na.rm Logical: whether or not to remove NA values (default set to 
#' FALSE - including NAs).
#' @return Standard Error of the mean.
#' @family Utility functions
#' @examples
#' # load example data:
#' data(chickwts)
#' str(chickwts)
#' 
#' # first calculate means per feeding type:
#' avg <- with(chickwts, tapply(weight, list(feed), mean))
#' par(cex=1.25)
#' b <- barplot(avg, beside=TRUE, names.arg=FALSE, ylim=c(0,450))
#' text(b, rep(0, length(b)), labels=names(avg), srt=90, adj=-.25)
#' 
#' # calculate mean collapsing over feeding types:
#' abline(h=mean(avg), lwd=1.5, col='red1')
#' # add SE reflecting variation between feeding types:
#' abline(h=mean(avg)+c(-1,1)*se(avg), lty=2, col='red1')
#' text(getCoords(.5), mean(avg)+se(avg), 
#'     labels=expression('mean' %+-% '1SE'), pos=3, col='red1')
#' 
#' # Note that SE makes more sense for experiments with 
#' # different groups or participants.
#' 
se <- function(x, na.rm = FALSE) {
    if (na.rm == TRUE) {
        x <- x[!is.na(x)]
    }
    s <- sd(x)
    if (is.na(s)) {
        warning("Problem in calculating SD.")
        return(NA)
    } else {
        return(sd(x)/sqrt(length(x)))
    }
}