#' \code{"Label<-"}
#'
#' Assign a "label" attribute to an object.
#' @param x An object or a list.
#' @param value A \code{character} object to set as a value or a vector of values.
#' @export
`Labels<-` <- function(x, value) {
if (is.list(x))
for (i in seq_along(x))
attr(x[[i]], "label") <- value[i]
else
attr(x, "label") <- value
x
}
#' \code{Labels}
#'
#' Replaces a list of given names or coefficient, with any underlying labels. If
#' @param x A \code{\link{data.frame}}.
#' @param names.to.lookup An optional list of the names of the variables or coefficients (e.g., Q2Cola for a factor).
#' @param show.name If \code{TRUE}, the name will prefix the extended label (where they are distinct). Ignored if
#' \code{names.to.lookup} is provided.
#' @return A \code{vector} of labels
#' @details First tries to find the "label" attribute, then "name", then "question", and lastly looks to the variable's name.
#' Where \code{names.to.lookup} is provided, Works for dummy variables as well as normal variables.
#' Trims backticks and whitespace. Returns names where labels cannot be found.
#' @importFrom flipU TrimWhitespace
#' @export
Labels <- function(x, names.to.lookup = NULL, show.name = FALSE)
{
.changeLabelForSingleVariableQuesetions <- function(qtype, question, label)
{
if (is.null(question) || is.null(qtype) || question == "" )
return(label)
if (qtype %in% c("PickOne", "Number", "Text", "Date"))
question else label
}
.createLabel <- function(name, label, question, x, show.name)
{
if (is.list(name))
{
for (i in seq_along(name))
name[[i]] <- .createLabel(name[[i]], label[[i]], question[[i]], x[[i]], show.name)
return(name)
}
if (is.null(label))
label <- question
else
{
if (!is.null(question) && !grepl(question, label, fixed = TRUE))
label <- paste0(question, ": ", label)
}
if (!show.name & !is.null(label))
return(label)
if (!show.name | is.null(label))
return(name)
if (is.null(name) & !is.null(label))
return(label)
paste0(label, " (", name, ")")
}
# Single variable case.
if(!is.list(x))
{
name <- attr(x, "name")
question <- attr(x, "question", exact = TRUE)
label <- attr(x, "label")
qtype <- attr(x, "questiontype")
label <- .changeLabelForSingleVariableQuesetions(qtype, question, label)
return(.createLabel(name, label, question, x, show.name))
}
# Data frame case.
if (is.null(names.to.lookup))
{
nms <- names(x)
for (i in 1:length(x))
{
if (is.null(attr(x[[i]], "name")))
attr(x[[i]], "name") <- nms[i]
}
result <- sapply(x, function(s) Labels(s, show.name = show.name))
names(result) <- nms
no.label <- result == "X[[i]]" | is.na(result)
result[no.label] <- names(x)[no.label]
return(result)
}
##### Creating a list of all the possible variable and coefficient names that can have labels.
# The labels
labels.list <- lapply(x, function(x) attr(x, "label"))
possible.names <- names(labels.list)
questions.list <- lapply(x, function(x) attr(x, "question", exact = TRUE))
qtypes.list <- lapply(x, function(x) attr(x, "questiontype"))
name.list <- as.list(names(x))
for (l in seq_along(labels.list))
{
new.label <- .changeLabelForSingleVariableQuesetions(qtypes.list[[l]], questions.list[[l]], labels.list[[l]])
if (!is.null(new.label))
labels.list[[l]] <- new.label
}
labels.list <- .createLabel(name.list,labels.list, questions.list, x, show.name)
# Removig the names of elements in the list, because unlist changes
# "name" to "name.name" and "`name`" to "'name'.name".
for (i in seq_along(labels.list))
{
if (!is.null(labels.list[[i]]))
names(labels.list[[i]]) <- NULL
}
possible.labels <- unlist(labels.list)
# # Fixing up the names, which hav been written as name.name by unlist.
x.possible <- x[, possible.names]
factors <- sapply(x.possible, is.factor)
possible.factor.levels <- lapply(x.possible, levels)
possible.factor.levels <- Filter(Negate(function(x) is.null(unlist(x))), possible.factor.levels) # Removing NULLs
possible.factor.names <- possible.names[factors]
possible.factor.labels <- possible.labels[factors]
name.factors <- NULL
label.factors <- NULL
for (i in seq_along(possible.factor.names))
{
nm <- possible.factor.names[i]
label <- possible.factor.labels[i]
levs <- possible.factor.levels[[nm]]
# Backticks sometimes appearing around variable names.
name.factors <- c(name.factors, c(paste0(nm, levs), paste0("`", nm, "`", levs)))
label.factors <- c(label.factors, rep(paste0(label, ": ", levs), 2))
}
# Putting it all together, including dealing with variables with back ticks.
possible.labels <- c(possible.labels, possible.labels, label.factors)
possible.names <- c(possible.names, paste0("`", possible.names, "`"), name.factors)
# Substituting.
matches <- match(names.to.lookup, possible.names)
names.to.lookup[!is.na(matches)] <- possible.labels[matches[!is.na(matches)]]
names.to.lookup <- removeBackTicks(names.to.lookup)
names.to.lookup <- TrimWhitespace(names.to.lookup)
names.to.lookup
}
# Removes any backticks surrouding a variable, if they are there.
removeBackTicks <- function(x)
{
have.backticks <- as.integer(substr(x, 1, 1) == "`")
lengths <- nchar(x)
substr(x, 1 + have.backticks, nchar(x) - have.backticks)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.