#' Match table to elements in the reference table
#'
#' @param x A vector or table containing values to be matched against \code{ref.table}
#' @param ref.table The reference table which determines the order of the output vector
#' @param ref.maindim Row or column.
#' @param ref.names Alternatively, a vector of names can be provide instead of \code{ref.table} and \code{ref.maindim}.
#' @param x.table.name Name used in the error messages.
#' @param ref.table.name Name used in the error messages.
#' @param as.matrix Converts \code{x} to a matrix. This will force all values to be of the same type.
#' @param trim.whitespace Whether to trim leading and trailing whitespace when matching row or column names.
#' @param ignore.case Logical; whether matching of names should ignore upper/lower case differences.
#' @param silent.remove.duplicates Removes duplicates with giving warnings. This is particulary useful when dealing with banners.
#' @importFrom flipFormat ExtractChartData
#' @importFrom verbs Sum
#' @export
MatchTable <- function(x,
ref.table = NULL,
ref.maindim = "rows",
ref.names = NULL,
x.table.name = "",
ref.table.name = "input data",
as.matrix = TRUE,
trim.whitespace = TRUE,
ignore.case = TRUE,
silent.remove.duplicates = FALSE)
{
if (nchar(x.table.name) > 0)
x.table.name <- paste0(x.table.name, ": ")
# Convert x into a table-like structure
x <- ExtractChartData(x)
if (as.matrix)
{
x <- as.matrix(x)
if (!is.matrix(x))
stop(x.table.name, "Values should be supplied as a table.")
}
if (is.null(ref.names) && !is.null(ref.table))
{
# Extract names from x and reference table
if (grepl("col", ref.maindim, fixed = TRUE) && length(dim(ref.table)) == 2)
{
ref.names <- colnames(ref.table)
ref.len <- NCOL(ref.table)
}
else
{
ref.names <- rownames(ref.table)
ref.len <- NROW(ref.table) # this works even if rownames is null
}
if (is.null(ref.names) && !is.null(names(ref.table)))
ref.names <- names(ref.table)
} else
ref.len <- length(ref.names)
ref.len <- max(1, ref.len)
x.names <- rownames(x)
if (is.null(x.names) && !is.null(names(x)))
x.names <- names(x)
# Check length and names
if (length(ref.names) == 0 && !is.null(x.names))
{
warning(x.table.name, "Names were ignored as input data is unnamed")
x.names <- NULL
}
if (is.null(x.names) && NCOL(x) == 1)
{
if (length(x) > ref.len)
warning(x.table.name, "Values (", length(x), ") were truncated to match input data (", ref.len, ").")
if (length(x) < ref.len)
warning(x.table.name, "Values (", length(x), ") were recycled to match input data (", ref.len, ").")
return(rep(x, length = ref.len))
}
if (!is.null(x.names))
{
# Sorting color values to match the row names of the reference table.
if (trim.whitespace)
{
ref.names <- TrimWhitespace(ref.names)
x.names <- TrimWhitespace(x.names)
}
ref.names.with.case <- ref.names
x.names.with.case <- x.names
if (ignore.case)
{
ref.names <- tolower(ref.names)
x.names <- tolower(x.names)
}
if (any(duplicated(x.names)))
{
if (!silent.remove.duplicates)
{
dup.names <- unique(x.names.with.case[duplicated(x.names)])
dup.n <- length(dup.names)
if (dup.n == 1)
warning(x.table.name, "Only the value from the first duplicate of '",
dup.names, "' was used. ")
else if (dup.n > 1)
warning(x.table.name, "Only the values from the first duplicate of '",
paste(dup.names[-dup.n], collapse = "', '"),
"' and '", dup.names[dup.n], "' were used.")
}
x.names <- make.unique(x.names)
}
order = match(ref.names, x.names)
ind.na <- which(is.na(order))
n.na <- length(ind.na)
if (n.na == 1)
stop(x.table.name, "The value for '", ref.names.with.case[ind.na], "' is missing.")
if (n.na > 1)
stop(x.table.name, "The values for '", paste(ref.names.with.case[ind.na[-n.na]], collapse = "', '"),
"' and '", ref.names.with.case[ind.na[n.na]], "' are missing.")
} else
order <- 1:ref.len
if (length(dim(x)) < 2)
x <- x[order]
else
x <- x[order,,drop=FALSE]
# Optionally match columns (NOT main dimension) if both x and ref.table contain enough info
if (NCOL(x) > 1 && !is.null(ref.table) && ref.maindim == "rows")
{
if (ncol(x) < ncol(ref.table))
{
# if the number of columns is x less than ref.table then we can only extract a single column
# take the last column as this will usually be NET
column.used.name <- if (!is.null(colnames(x))) paste0("column '", colnames(x)[ncol(x)], "'") else "the last column"
warning(x.table.name, "Only ", column.used.name, " was used.")
x <- x[,ncol(x)]
}
else if(is.null(colnames(ref.table)) || is.null(colnames(x)))
x <- x[,1:NCOL(ref.table),drop = FALSE]
else
{
col.ref.names <- colnames(ref.table)
col.x.names <- colnames(x)
if (trim.whitespace)
{
col.ref.names <- TrimWhitespace(col.ref.names)
col.x.names <- TrimWhitespace(col.x.names)
}
col.ref.names.with.case <- col.ref.names
if (ignore.case)
{
col.ref.names <- tolower(col.ref.names)
col.x.names <- tolower(col.x.names)
}
order <- match(col.ref.names, col.x.names)
if (any(is.na(order)))
stop(x.table.name, "Values should either be a single-column table or have the same column names as the input data. ",
if (Sum(is.na(order)) == 1) "Column for '" else "Columns for '",
paste(col.ref.names.with.case[is.na(order)], collapse = "', '"), "' ",
if (Sum(is.na(order)) == 1) "is" else "are",
" missing.")
x <- x[,order,drop=FALSE]
}
}
return(x)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.