##########################################################
# To be removed when the iNZight tools package is working##
##########################################################
read_config <- function() {
lite_config <- Sys.getenv("LITE_CONFIG")
if (is.null(lite_config) || nchar(lite_config) <= 1) {
return()
}
# read from json
fromJSON(lite_config)
}
# Modified based off:
# https://github.com/dreamRs/shinylogs/blob/0195ac0a1f85d213c82143cfee712c9baddd1963/R/tracking.R#L134
init_lite_logs <- function(
log_path = tempdir(),
what = c("session", "input", "output", "error"),
exclude_input_regex = NULL,
exclude_input_id = NULL,
exclude_users = NULL,
session = getDefaultReactiveDomain()) {
return()
what <- match.arg(what, several.ok = TRUE)
LITE_SESSION_ID_ <<- substr(session$token, 1, 10)
if (!file.exists(log_path)) {
dir.create(log_path)
}
addResourcePath("logs", log_path)
print(list.files(log_path))
app_name <- "lite"
user <- shinylogs:::get_user_(session)
storage_mode <- store_json(path = log_path)
timestamp <- shinylogs:::get_timestamp(timestamp)
log_name <- paste0("lite_logs_", LITE_SESSION_ID_, ".json")
log_path <- file.path(log_path, log_name)
download_path <- file.path("logs", log_name)
timestamp <- Sys.time()
init_log <- data.frame(
session_id = LITE_SESSION_ID_,
app = app_name,
user = user,
server_connected = timestamp,
stringsAsFactors = FALSE
)
storage_mode$appname <- app_name
storage_mode$timestamp <- format(
bit64::as.integer64(nanotime::nanotime(timestamp)),
scientific = FALSE
)
insertUI(
selector = "body", where = "afterBegin",
ui = singleton(tags$script(
id = "shinylogs-tracking",
type = "application/json",
`data-for` = "shinylogs",
toJSON(shinylogs:::dropNulls(list(
what = what,
logsonunload = FALSE,
exclude_input_regex = exclude_input_regex,
exclude_input_id = exclude_input_id,
session_id = init_log$session_id,
log_path = log_path,
download_path = download_path
)), auto_unbox = TRUE, json_verbatim = TRUE)
)),
immediate = TRUE,
session = session
)
insertUI(
selector = "body", where = "afterBegin",
ui = htmltools::attachDependencies(
x = tags$div(),
value = list(
shinylogs:::shinylogs_dependencies()
)
),
immediate = FALSE,
session = session
)
if (isTRUE(storage_mode$console)) {
observe({
to_console(session$input$.shinylogs_browserData, init_log)
})
observe({
to_console(session$input$.shinylogs_lastInput)
})
}
onSessionEnded(
fun = function() {
init_log$server_disconnected <- shinylogs:::get_timestamp(Sys.time())
logs <- c(
isolate(session$input$.shinylogs_input),
isolate(session$input$.shinylogs_error),
isolate(session$input$.shinylogs_output)
)
browser_data <- isolate(session$input$.shinylogs_browserData)
if (!is.null(browser_data)) {
browser_data <- as.data.frame(browser_data)
logs$session <- cbind(init_log, browser_data)
} else {
logs$session <- init_log
}
if (isTRUE(!user %in% exclude_users)) {
# shinylogs:::write_logs(storage_mode, logs)
jsonlite::write_json(
x = logs,
path = log_path,
auto_unbox = TRUE
)
}
},
session = session
)
}
#' Reahapes the data that all columns are merged into two
#' column with the variable names in the first column and
#' the values in the second column.
#'
#' @param dafr The data.frame to convert
#'
#' @return The converted data.frame.
#'
#' @author Christoph Knapp
get.reshape.data <- function(dafr) {
temp <- do.call(rbind, lapply(1:ncol(dafr), function(index, d) {
name <- colnames(d)[index]
data.frame(groups = name, d[, index], stringsAsFactors = TRUE)
}, dafr))
colnames(temp)[2] <- "variables"
temp
}
#' add new columns to the original dataframe which replace "NA"
#' with "missing" so that the missing values could be displayed
#' in the plot..
#'
#' @param dafr The input data.frame.
#' @param The column names or indexes to be converted.
#'
#' @return A data.frame with the new columns added.
#'
#' @author Wilson Hu
display.missing.categorical <- function(dafr, columns) {
for (i in columns) {
temp <- dafr[, i]
if (is.factor(temp) || is.character(temp)) {
temp <- as.character(temp)
temp[is.na(temp)] <- "missing"
temp <- as.factor(temp)
original.level <- levels(temp)[levels(temp) != "missing"]
temp <- factor(temp, levels = c(original.level, "missing"))
} else {
index <- is.na(temp)
temp <- rep("observed", length(temp))
temp[index] <- "missing"
temp <- factor(temp, levels = c("observed", "missing"))
}
temp <- as.data.frame(temp, stringsAsFactors = TRUE)
colnames(temp) <- paste(i, "missing", sep = "_")
dafr <- data.frame(dafr, temp, stringsAsFactors = TRUE)
}
dafr
}
#' Simplifies the input data.frame by keeping only
#' columns where NA values are present. Function
#' used in get.combinations
#'
#' @param dafr A data.frame to be
#' simplified such that all columns
#' which do not contain NA values are
#' removed.
#'
#' @author Christoph Knapp
simplify.dafr <- function(dafr) {
ies <- c()
for (col in 1:ncol(dafr)) {
if (!any(is.na(dafr[, col]))) {
ies <- c(ies, col)
}
}
dafr <- dafr[, -ies]
if (ncol(dafr) == 0) {
dafr <- NULL
}
dafr
}
#' Converts a data.frame to a format where all
#' non NA are replaced by "observed" and all NA
#' values are repalced by "missing".
#'
#' @param dafr the data.frame to convert.
#'
#' @return The converted data.frame.
#'
#' @author Christoph Knapp
convert.dafr <- function(dafr) {
if (!is.null(dafr)) {
temp <- do.call(cbind, lapply(1:ncol(dafr), function(i, d) {
col <- rep("observed", nrow(d))
col[is.na(d[, i])] <- "missing"
col
}, dafr))
colnames(temp) <- colnames(dafr)
temp
} else {
dafr
}
}
#' Takes a data.frame as generated from the
#' \texttt(get.missing.categorical) function and converts it
#' into a data.frame of all unique rows and there counts in
#' the original data. It is a modified version of the
#' calmissing.data.frame method from the iNZightMR package.
#'
#' @param dafr A data.frmae to convert
#' @param simplify Returns the smallest number of possible
#' rows, ignoring columns which do not contain NA values if
#' TRUE, otherwise it processes the whole input.
#' @param convert TRUE if the input data.frame should be
#' converted into "missing" or observed format.
#'
#' @return A data.frame with all unique rows from dafr and
#' their counts in the last column.
#'
#' @author Christoph Knapp
get.combinations <- function(dafr, simplify = F) {
dafr <- data.frame(dafr, stringsAsFactors = TRUE)
index.column <- rep(T, ncol(dafr))
rm.na <- function(variable) {
sum(is.na(variable)) > 0
}
if (simplify) {
index.column <- sapply(dafr, rm.na)
}
x <- data.frame(dafr[, index.column], stringsAsFactors = TRUE)
if (ncol(x) == 0) {
return(NULL)
}
x1 <- as.numeric(apply(x, 2, function(x) length(which(is.na(x)))))
row4col.order <- order(x1)
x1 <- c(x1, nrow(x))
z1 <- ifelse(is.na(x), "missing", "observed")
tab <- table(apply(z1, 1, paste, collapse = ","))
tab <- tab[order(names(tab), decreasing = TRUE)]
tab <- data.frame(
combination = names(tab),
count = as.numeric(tab), stringsAsFactors = TRUE
)
tabp <- t(apply(tab, 1, function(x) {
unlist(strsplit(x, ",", fixed = TRUE))
}))
tabp <- data.frame(tabp, stringsAsFactors = F)
tabp <- tabp[, c(row4col.order, max(row4col.order) + 1)]
# x1[row4col.order] == numMiss
tabp <- rbind(tabp, x1[c(row4col.order, max(row4col.order) + 1)])
names(tabp) <- c(names(x)[row4col.order], "Total")
row.names(tabp) <- c(seq_len(nrow(tab)), "Total")
tabfinal <- tabp[-nrow(tabp), ]
tabfinal <- tabfinal[order(tabfinal$Total, decreasing = TRUE), ]
tabfinal <- rbind(tabfinal, tabp[nrow(tabp), ])
finaltable <- tabfinal
Name <- names(finaltable)
i <- nrow(finaltable)
j <- ncol(finaltable)
index <- order(x1[-j], decreasing = FALSE)
numMiss <- x1[c(index, j)]
percMiss <- round(numMiss / numMiss[j], 3)
finaltable <- rbind(finaltable, paste0(round(percMiss * 100, 2), "%"))
colnames(finaltable)[j] <- "Freq"
finaltable
}
##########################################################
# To be removed when the iNZight tools package is working##
##########################################################
#' Takes an input string of a formula involving colummn
#' names in the input data set and tries to evaluate it.
#' If this is not possible, NULL is returned and the error
#' is printed to standard out.
#'
#' @param dafr The data.frame containing the data needed
#' to evaluate the expression.
#' @param new.formula The character string holding the
#' expression to be evaluated.
#'
#' @return Null if the expression could not be evaluated,
#' otherwise the input data.frame with one additional
#' column. This column contains the results of the
#' expression.
#'
#' @author Christoph Knapp
get.create.variables <- function(dafr, new.formula, new.name = NULL) {
tryCatch(
{
colu <- eval(parse(text = new.formula), dafr)
if (length(colu) > nrow(dafr)) {
colu <- colu[1:nrow(dafr)]
}
temp <- cbind(dafr, colu)
if (is.null(new.name) || "" %in% new.name) {
new.name <- "new.name"
}
count <- 0
while (new.name %in% colnames(dafr)) {
count <- count + 1
new.name <- paste(new.name, count, sep = ".")
}
colnames(temp)[ncol(temp)] <- new.name
temp
},
error = function(cond) {
return(NULL)
},
warning = function(cond) {},
finally = {}
)
}
##########################################################
# To be removed when the iNZight tools package is working##
##########################################################
#' Collapses selected levels in factor vector
#'
#' @param column the vector where levels should be
#' collapsed into one.
#' @param to.collapse Vector of levels to collapse.
#'
#' @note Levels in to.collapse which are not in column
#' will be ignored.
#'
#' @author Christoph Knapp
get.collapsed.column <- function(column, to.collapse) {
column <- as.character(column)
new.level <- paste(to.collapse, collapse = ".")
indices <- which(column %in% to.collapse)
if (length(indices) > 0) {
column[indices] <- new.level
}
as.factor(column)
}
#' The iNZight version of the order function which lets you pass
#' in a list of vectors to order instead of the ... argument. It
#' is shortened and might be therefore not as stable as the
#' original order function.
#'
#' @param z a sequence of numeric, complex, character or logical
#' vectors, all of the same length, or a classed R object.
#' @param na.last for controlling the treatment of NAs. If TRUE,
#' missing values in the data are put last; if FALSE, they are
#' put first; if NA, they are removed (see ‘Note’.)
#' @param decreasing logical. Should the sort order be increasing
#' or decreasing?
#'
#' @note This function is only called in sort.data but needs to be
#' available to sort.data
#'
#' @author Christoph Knapp
order.overwrite <- function(z, na.last = TRUE, decreasing = FALSE) {
if (any(diff(l.z <- vapply(z, length, 1L)) != 0L)) {
stop("argument lengths differ")
}
ans <- vapply(z, is.na, rep.int(NA, l.z[1L]))
ok <- if (is.matrix(ans)) {
!apply(ans, 1, any)
} else {
!any(ans)
}
if (all(!ok)) {
return(integer())
}
z[[1L]][!ok] <- NA
ans <- do.call("order", c(z, decreasing = decreasing))
keep <- seq_along(ok)[ok]
ans[ans %in% keep]
}
#' Returns the names of all numeric columns in data
#'
#' @param dafr The input dataframe to be searched.
#'
#' @author Christoph Knapp
get.numeric.column.names <- function(dafr) {
colnames(dafr)[which(unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(as.data.frame(d, stringsAsFactors = TRUE)[, index])
}, dafr)))]
}
#' Returns the column names of the currently selected data which
#' can be converted into factors.
#'
#' @param dafr The input dataframe to be searched.
#'
#' @author Christoph Knapp
get.categorical.column.names <- function(dafr) {
colnames(dafr)[which(unlist(lapply(1:ncol(dafr), function(index, d) {
class(as.data.frame(d, stringsAsFactors = TRUE)[, index]) %in% "factor" ||
class(as.data.frame(d, stringsAsFactors = TRUE)[, index]) %in% "character"
}, dafr)))]
}
#' Returns TRUE if x can be converted to a numeric
#' value, FALSE if not.
#'
#' @param x any oblect to be tested
#'
#' @author Christoph Knapp
is.convertable.numeric <- function(x) {
!suppressWarnings(is.na(as.numeric(x)))
}
#' Tests whether a character variable is convertable to an
#' integer value.
#'
#' @param x a character or numeric value to test for.
#'
#' @author Christoph Knapp
is.convertable.integer <- function(x) {
temp <- is.convertable.numeric(x)
temp[temp] <- as.numeric(x[temp]) %% 1 == 0
temp
}
#' Prints a summary of the currently selected data set.
#'
#' @author Christoph Knapp
data.summary <- function(dafr) {
if (!is.null(dafr)) {
cat("Number of rows in data: ", nrow(dafr), "\n")
cat("Number of columns in data: ", ncol(dafr), "\n")
cat("\n")
for (col in 1:length(colnames(dafr))) {
cat(colnames(dafr)[col], "\n")
print(summary(dafr[, col]))
}
}
}
#' Creates a widget for moving through plots quickly.
#'
#' @param ID.forward inputID for the forward button in the player widget
#' @param ID.player inputID for the slider in the player widget
#' @param ID.backward inputID for the backward button in the player widget
#'
#' @author Christoph Knapp
get.player <- function(ID.forward, ID.player, ID.backward, maxi) {
fixedRow(column(
width = 8, offset = 2,
div(
class = "player",
fixedRow(
column(
width = 1, offset = 1,
div(
class = "seper",
actionButton(
inputId = ID.backward,
label = "", icon = icon("backward")
)
)
),
column(
width = 6, offset = 1,
sliderInput(
inputId = ID.player, label = "", min = 1, max = maxi, step = 1,
animate = animationOptions(interval = 500, loop = T, play = T),
width = "100%", value = 1, ticks = F
)
),
column(
width = 1, offset = 1,
div(
class = "seper",
actionButton(
inputId = ID.forward,
label = "", icon = icon("forward")
)
)
)
)
)
))
}
#' changes numeric columns to factor columns
#'
#' @param temp a matrix or data.frame with columns to change
#' @param columns a vector of column names for temp
#'
#' @return a data.frame where all numeric columns are
#' converted into character column
#'
#' @author Christoph Knapp
change.factor.transform <- function(temp, columns) {
temp <- as.data.frame(temp, stringsAsFactors = TRUE)
nums <- unlist(lapply(1:ncol(temp), function(index, temp.data, columns) {
if (is.numeric(temp.data[, index])) {
columns[index]
} else {
NULL
}
}, temp, columns))
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(temp), function(index, temp.data) {
if (is.numeric(temp.data[, index])) {
as.character(temp.data[, index])
} else {
NULL
}
}, temp)), stringsAsFactors = T
)
if (!is.null(temp) && ncol(temp) > 0 && nrow(temp) > 0) {
colnames(temp) <- paste("factors", nums, sep = "_")
temp
} else {
NULL
}
}
#' change the sign of numeric columns
#'
#' @param dafr a data frame with columns to transform
#' @param columns the column names of the columns in dafr
#'
#' @author Christoph Knapp
change.sign.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, dafr) {
if (is.numeric(dafr[, index])) {
as.matrix(dafr[, index] * (-1))
} else {
NULL
}
}, dafr))
)
if (!is.null(temp)) {
colnames(temp) <- paste("change_sign",
columns[unlist(lapply(1:ncol(dafr), function(i, d) {
is.numeric(d[, i])
}, dafr))],
sep = "."
)
}
temp
}
test.for.dates <- function(dafr) {
ret <- F
if (!is.null(dafr)) {
ret <- unlist(lapply(
1:ncol(dafr), function(index, d) {
tryCatch(
{
is.numeric(as.numeric(as.Date(d[, index], origin = "1900-01-01")))
},
error = function(cond) {
ret <- F
},
warning = function(cond) {
print(cond)
},
finally = {}
)
}, dafr
))
}
ret
}
copy.transform <- function(dafr, columns) {
data <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- paste("copy", columns, sep = ".")
data
}
reverse.coding.transform <- function(dafr, columns) {
data <- as.data.frame(dafr, stringsAsFactors = TRUE)
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
min(d[, index], na.rm = T) + max(d[, index], na.rm = T) - d[, index]
} else {
NULL
}
}, dafr))
)
if (!is.null(temp)) {
colnames(temp) <- paste("reverse_coding",
columns[unlist(lapply(
1:ncol(dafr),
function(i, d) {
is.numeric(d[, i])
}, dafr
))],
sep = "."
)
}
temp
}
median.split.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
nums <- unlist(lapply(1:ncol(dafr), function(index, dafr) {
is.numeric(dafr[, index])
}, dafr))
dafr <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
med <- median(d[, index], na.rm = T)
ret <- rep("high", length(d[, index]))
ret[which(d[, index] <= med)] <- "low"
ret
} else {
NULL
}
}, dafr)), stringsAsFactors = T
)
colnames(dafr) <- paste("median_split", columns[nums], sep = "_")
dafr
}
standardize.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
dafr <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
(d[, index] - mean(d[, index], na.rm = T)) / sd(d[, index], na.rm = T)
} else {
(as.numeric(factor(d[, index]))
- mean(as.numeric(factor(d[, index])), na.rm = T)) /
sd(as.numeric(factor(d[, index])), na.rm = T)
}
}, dafr))
)
colnames(dafr) <- paste("standardize", columns, sep = ".")
dafr
}
center.transform <- function(dafr, columns) {
data <- as.data.frame(dafr, stringsAsFactors = TRUE)
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
d[, index] - mean(d[, index])
} else {
as.numeric(factor(d[, index])) - mean(as.numeric(factor(d[, index])))
}
}, dafr))
)
colnames(temp) <- paste("center", columns, sep = ".")
temp
}
divide.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
if (is.null(dafr)) {
return(NULL)
} else {
if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)) == 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)
colnames(temp) <- colnames(data)[unlist(lapply(
1:ncol(dafr),
function(index, d) {
is.numeric(d[, index])
}, data
))]
} else if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, data))]
)) > 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
divide(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))])
)
colnames(temp) <- paste0(
"divide.",
paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))], collapse = ".")
)
} else {
return(NULL)
}
}
temp
}
divide <- function(dafr) {
dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
if (ncol(dafr) == 1) {
dafr[, 1]
} else {
start <- dafr[, 1]
for (col in 2:ncol(dafr)) {
start <- start / dafr[, col]
}
start
}
}
multiply.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
if (is.null(dafr)) {
return(NULL)
} else {
if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)) == 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)
colnames(temp) <- colnames(dafr)[unlist(lapply(
1:ncol(dafr),
function(index, d) {
is.numeric(d[, index])
}, dafr
))]
} else if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)) > 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
multiply(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))])
)
colnames(temp) <- paste0(
"multiply.",
paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))], collapse = ".")
)
} else {
return(NULL)
}
}
temp
}
multiply <- function(dafr) {
dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
if (ncol(dafr) == 1) {
dafr[, 1]
} else {
start <- dafr[, 1]
for (col in 2:ncol(dafr)) {
start <- start * dafr[, col]
}
start
}
}
subtract.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
if (is.null(dafr)) {
return(NULL)
} else {
if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)) == 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)
colnames(temp) <- colnames(dafr)[unlist(lapply(
1:ncol(dafr),
function(index, d) {
is.numeric(d[, index])
}, dafr
))]
} else if (ncol(as.data.frame(
stringsAsFactors = TRUE,
dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
)) > 1) {
temp <- as.data.frame(
stringsAsFactors = TRUE,
subtract(dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))])
)
colnames(temp) <- paste0(
"subtract.",
paste(colnames(dafr)[unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))], collapse = ".")
)
} else {
return(NULL)
}
}
temp
}
subtract <- function(dafr) {
dafr <- dafr[, unlist(lapply(1:ncol(dafr), function(index, d) {
is.numeric(d[, index])
}, dafr))]
dafr <- as.data.frame(
stringsAsFactors = TRUE,
dafr
)
if (ncol(dafr) == 1) {
dafr[, 1]
} else {
start <- dafr[, 1]
for (col in 2:ncol(dafr)) {
start <- start - dafr[, col]
}
start
}
}
add.transform <- function(temp, columns) {
temp <- as.data.frame(temp, stringsAsFactors = TRUE)
colnames(temp) <- columns
if (is.null(temp)) {
return(NULL)
} else {
ret <- as.data.frame(
stringsAsFactors = TRUE,
temp[, unlist(lapply(1:ncol(temp), function(index, d) {
is.numeric(d[, index])
}, temp))]
)
if (ncol(ret) > 1) {
ret <- as.data.frame(
stringsAsFactors = TRUE,
apply(ret, 1, function(row) {
sum(row)
})
)
colnames(ret) <- paste0("add_", paste(colnames(temp), collapse = "_"))
} else {
return(NULL)
}
}
ret
}
# returns the transformed columns and the original data as
# dataframe (cbind(data,<transformed columns>)).
transform.perform <- function(dafr, type, columns) {
temp <- transform.get.temp(dafr, type, columns)
if (!is.null(temp)) {
temp <- cbind(dafr, temp)
}
temp
}
# returns the transformed columns and the original columns as
# dataframe (cbind(<original columns>,<transformed columns>)).
transform.tempTable <- function(dafr, type, columns) {
temp1 <- as.data.frame(
stringsAsFactors = TRUE,
dafr[, which(colnames(dafr) %in% columns)]
)
colnames(temp1) <- columns
temp2 <- transform.get.temp(dafr, type, columns)
if (!is.null(temp2)) {
temp1 <- data.frame(stringsAsFactors = TRUE, temp1, temp2)
}
temp1
}
# transorms the columns named columns in data with the selected
# type (type) of transformation.
transform.get.temp <- function(dafr, type, columns) {
temp <- NULL
if (!is.null(columns) && type %in% "log") {
temp <- log.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "add") {
temp <- add.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "subtract") {
temp <- subtract.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "multiply") {
temp <- multiply.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "divide") {
temp <- divide.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "root") {
temp <- root.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "square") {
temp <- square.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "abs") {
temp <- abs.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "center") {
temp <- center.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "standardize") {
temp <- standardize.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "median split") {
temp <- median.split.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "reverse-coding") {
temp <- reverse.coding.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "copy") {
temp <- copy.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "change sign") {
temp <- change.sign.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% "change to factor") {
temp <- change.factor.transform(dafr[, columns], columns)
} else if (!is.null(columns) & type %in% " ") {
temp <- NULL
}
temp
}
log.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, dafr) {
if (is.numeric(dafr[, index])) {
log(dafr[, index])
} else {
NULL
}
}, dafr))
)
if (!is.null(temp) && dim(temp)[1] > 0 && dim(temp)[2] > 0) {
colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, dafr) {
if (is.numeric(dafr[, index])) {
paste0("log.", colnames(dafr)[index])
} else {
NULL
}
}, dafr))
temp
} else {
NULL
}
}
root.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
sqrt(d[, index])
} else {
NULL
}
}, dafr))
)
## temp = as.data.frame(temp)
if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
paste0("root.", colnames(d)[index])
} else {
NULL
}
}, dafr))
temp
} else {
NULL
}
}
square.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
d[, index]^2
} else {
NULL
}
}, dafr))
)
## temp = as.data.frame(temp)
if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
paste0("square.", colnames(d)[index])
} else {
NULL
}
}, dafr))
temp
} else {
NULL
}
}
abs.transform <- function(dafr, columns) {
dafr <- as.data.frame(dafr, stringsAsFactors = TRUE)
colnames(dafr) <- columns
temp <- as.data.frame(
stringsAsFactors = TRUE,
do.call(cbind, lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
abs(d[, index])
} else {
NULL
}
}, dafr))
)
if (dim(temp)[1] > 0 && dim(temp)[2] > 0) {
colnames(temp) <- unlist(lapply(1:ncol(dafr), function(index, d) {
if (is.numeric(d[, index])) {
paste0("abs.", colnames(d)[index])
} else {
NULL
}
}, dafr))
temp
} else {
NULL
}
}
delete.old.files <- function(data_dir, days) {
if (length(list.files(paste0(data_dir, "/Imported"))) > 0) {
unlink(list.files(paste0(data_dir, "/Imported"))[
difftime(Sys.time(),
file.info(list.files(
paste0(data_dir, "/Imported"),
full.name = T
))
[, "mtime"],
units = "days"
) > days
])
}
}
### A function for displaying help messages.
help.display <- function(title, id, file) {
HTML(paste("<div class='modal fade' id='", id,
"' tabindex='-1' role='dialog' aria-labelledby='basicModal'
aria-hidden='true'>
<div class='modal-dialog'>
<div class='modal-content'>
<div class='modal-header'>
<h4 class='modal-title' id='myModalLabel'>", title, "</h4>
</div>
<div class='modal-body'>",
mark_html(file = file, output = NULL, template = FALSE),
"</div>
<div class='modal-footer'>
</div>
</div>
</div>
</div>
<a href='#' class='btn btn-xs btn-success' data-toggle='modal'
data-target='#", id, "'>Help</a>",
sep = ""
))
}
## reads a data set from a filename in the data directory
load.data <- function(data_dir, fileID = NULL, path = NULL) {
temp <- NULL
full.name <- list.files(data_dir, full.names = T, recursive = T)
if (!is.null(fileID)) {
if (is.null(path)) {
indexes <- grep(paste(fileID, ".", sep = ""), full.name, fixed = T)
} else if (!is.null(path) & file.exists(path)) {
full.name <- path
indexes <- 1
} else {
return(list(NULL, NULL))
}
if (length(indexes[1]) > 0) {
ext <- strsplit(full.name[indexes[1]], ".", fixed = T)[[1]]
ext <- ext[length(ext)]
if (!(tolower(ext) %in% c(
"rds", "rda", "rdata", "csv", "txt", "xls", "xlsx"
))) {
ext <- strsplit(fileID, ".", fixed = T)[[1]]
ext <- ext[length(ext)]
}
if (!file.exists(full.name[indexes[1]])) {
return(list(NULL, NULL))
}
# catch possible problems with user data.
tryCatch({
if (tolower(ext) %in% "rds") {
temp <- readRDS(file = full.name[indexes[1]])
} else if (tolower(ext) %in% "rda" | tolower(ext) %in% "rdata") {
name <- load(full.name[indexes[1]])
temp <- get(name)
} else if (tolower(ext) %in% "csv") {
temp <- read.csv(full.name[indexes[1]],
comment.char = "#",
na.strings = c("NULL", "NA", "N/A", "#N/A", "", "<NA>"),
stringsAsFactors = TRUE
)
} else if (tolower(ext) %in% "txt") {
temp <- read.delim(full.name[indexes[1]],
comment.char = "#",
na.strings = c("NULL", "NA", "N/A", "#N/A", "", "<NA>"),
stringsAsFactors = TRUE
)
} else if (tolower(ext) %in% "xls") {
temp <- as.data.frame(
stringsAsFactors = TRUE,
read_excel(full.name[indexes[1]])
)
} else if (tolower(ext) %in% "xlsx") {
temp <- as.data.frame(
stringsAsFactors = TRUE,
read_excel(full.name[indexes[1]])
)
} else if (tolower(ext) %in% "sas7bdat") {
temp <- as.data.frame(
stringsAsFactors = TRUE,
read.sas7bdat(full.name[indexes[1]])
)
} else if (tolower(ext) %in% "dta") {
temp <- as.data.frame(
stringsAsFactors = TRUE,
read.dta(full.name[indexes[1]])
)
} else if (tolower(ext) %in% "sav") {
temp <- as.data.frame(
stringsAsFactors = TRUE,
read.spss(full.name[indexes[1]],
use.value.labels = FALSE, to.data.frame = TRUE
)
)
}
}, error = function(e) {
print(e)
}, finally = {})
}
}
if (is.null(fileID)) {
list(NULL, temp)
} else {
list(data.name = basename(fileID), data.set = temp)
}
}
## returns directories in the data directory
get.data.dirs <- function(data_dir) {
list.files(data_dir,
include.dirs = T,
full.names = T
)[file.info(paste(data_dir,
list.files(data_dir),
sep = "/"
))[, "isdir"]]
}
## returns a radioButton widget, for every filename in the dir.lable directory.
get.radio.list <- function(dir.label, idlabel) {
files <- c()
files <- list.files(dir.label,
recursive = T,
full.name = T
)[!(file.info(list.files(dir.label,
recursive = T,
full.names = T
))[, "isdir"])]
temp.files <- strsplit(files, "/")
files <- unlist(lapply(
temp.files,
function(x, label) {
paste(x[(which(x %in% label) + 1):length(x)], collapse = "==>")
},
strsplit(dir.label, "/", fixed = T)[[1]][
length(strsplit(dir.label, "/", fixed = T)[[1]])
]
))
ret <- NULL
if (length(files) > 0) {
columns <- lapply(
1:length(files),
function(i, ns) {
paste(strsplit(ns[i], ".", fixed = T)[[1]][
1:(length(strsplit(ns[i], ".", fixed = T)[[1]]) - 1)
], collapse = ".")
},
basename(files)
)
ret <- radioButtons(
inputId = paste(basename(dir.label), idlabel, sep = ""),
label = basename(dir.label), choices = columns,
selected = columns[1]
)
}
ret
}
change.file.ext <- function(name, new.ext) {
splity <- strsplit(name, ".", fixed = T)[[1]]
if (length(splity) > 1) {
splity <- paste(paste(splity[1:(length(splity) - 1)], collapse = "."),
new.ext,
sep = "."
)
} else {
splity <- paste0(splity, ".", new.ext)
}
splity
}
get.vars <- function(vars.path) {
lines <- c()
if (is.null(vars.path)) {
vars.path <- "VARS"
}
if (!file.exists(vars.path)) vars.path <- "VARS.default"
if (file.exists(vars.path)) {
lines <- scan(vars.path, what = "character", sep = "\n", quiet = T)
} else {
stop("The VARS file does not exist.")
}
if (length(lines) > 0) {
ret <- NULL
for (line in lines) {
if (!grepl("^#", line)) {
if (grepl("#", line)) {
line <- strsplit(line, "#")[[1]][1]
}
if (grepl("=", line) && length(strsplit(line, "=")[[1]]) > 1) {
if (is.null(ret)) {
ret <- list()
}
ret[[trim(strsplit(line, "=")[[1]][1])]] <-
trim(strsplit(line, "=")[[1]][2])
}
}
}
ret
}
}
#' Tests whether a directory has read write execute permissions.
#'
#' @param file The directory path to test
#'
#' @return TRUE if writable and the file exists, otherwise FALSE
#'
#' @note This is a Unix only function. On Windows and all other
#' OS where \code{.Platform$OS.type} is not unix the function
#' returns always TRUE. Extend this function if necessary. Only
#' relevant permission types have been added.
#'
#' @author Christoph Knapp
file.writable <- function(file, debug) {
tryCatch({
if (file.exists(file) &&
"unix" %in% .Platform$OS.type &&
"Linux" %in% Sys.info()["sysname"]) {
grepl(
"777",
strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
intern = T
), " ")[[1]][1]
) ||
grepl(
"775",
strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
intern = T
), " ")[[1]][1]
) ||
grepl(
"755",
strsplit(system(paste("stat -c \"%a %n\" ", file, sep = ""),
intern = T
), " ")[[1]][1]
)
} else {
FALSE
}
}, error = function(e) {
return(FALSE)
}, finally = {})
}
#' Wrapper function for \code{dir.create} which returns
#' whether information whether the directory was created.
#'
#' @param path a character vector containing a single
#' path name. Tilde expansion (see ?path.expand) is done.
#' @param showWarnings logical; should the warnings on
#' failure be shown?
#' @param recursive logical. Should elements of the path
#' other than the last be created? If true, like the Unix
#' command \code{mkdir -p}.
#' @param mode the mode to be used on Unix-alikes: it
#' will be coerced by \code{?as.octmode}. For
#' \code{Sys.chmod} it is recycled along paths.
#'
#' @note This function does most likely not work on a
#' windows System.
#'
#' @return TRUE if the directory was created, FALSE if
#' not.
#'
#' @author Christoph Knapp
dir.create.logical <- function(path,
showWarnings = TRUE,
recursive = FALSE,
mode = "0777") {
result <- tryCatch({
if (!file.exists(path)) {
dir.create(path, showWarnings, recursive, mode)
}
TRUE
}, warning = function(w) {
return(FALSE)
}, error = function(e) {
return(FALSE)
}, finally = {})
}
trim <- function(x) gsub("^\\s+|\\s+$", "", x)
get.quantiles <- function(subx) {
g1 <- rep("", length(subx))
if (is.numeric(subx)) {
quant <- quantile(subx, na.rm = T)
g1[which(subx >= quant[1] & subx < quant[2])] <-
paste(round(quant[1], 2), round(quant[2], 2), sep = "-")
g1[which(subx >= quant[2] & subx < quant[3])] <-
paste(round(quant[2], 2), round(quant[3], 2), sep = "-")
g1[which(subx >= quant[3] & subx < xquant[4])] <-
paste(round(quant[3], 2), round(quant[4], 2), sep = "-")
g1[which(subx >= quant[4] & subx <= quant[5])] <-
paste(round(quant[4], 2), round(quant[5], 2), sep = "-")
g1 <- as.factor(g1)
}
g1
}
#' Make Syntactically Valid Names
#'
#' @param names vector to be coerced to syntactically valid names.
#'
#' @description Replace spaces with underscores and any other
#' invalid characters to dots
#'
#' @return Character vector of valid names
make_names <- function(names) {
names <- gsub("\\s+", "_", names)
names <- make.names(names)
return(names)
}
#' Loads data from a specified URL
#'
#' @param URL A valid URL pointing to a data set
#' @param data.dir.import The directory the data set
#' should be downloaded to
#'
#' @return A list of two elements.
#' data.set = A data.frame object containing the loaded data.set
#' data.name = The name of the data set as retrieved from the URL
#'
#' @note This method is using the function download.file and the wget method.
#' This might not work in all possible cases.
#'
#' @author Christoph Knapp
parseQueryString <- function(str) {
if (grepl("docs.google.com", str)) {
return(list(
url = sub(".*?url=(.*?)&land.*", "\\1", str),
land = sub(".*?&land=(.*?)", "\\1", str)
))
} else {
shiny::parseQueryString(str)
}
}
# # deprecated
get.data.from.URL <- function(URL, data.dir.import) {
ret <- list()
URL <- URLencode(URL)
if (grepl("docs.google.com", URL)) {
url.index <- gregexpr("output=", URL)
url.index <- unlist(url.index)
file.type <- substr(URL, url.index + 7, nchar(URL))
temp.file.name <- tempfile()
temp.file.name.index <- gregexpr("file", temp.file.name)
temp.file.name.index <- unlist(temp.file.name.index)
file.name <- substr(
temp.file.name,
temp.file.name.index, nchar(temp.file.name)
)
name <- paste(file.name, file.type, sep = ".")
} else {
name <- strsplit(URL, "/")[[1]]
name <- strsplit(name[length(name)], "?", fixed = T)[[1]][1]
}
if (!file.exists(paste(data.dir.import, "/Imported", sep = "")) &&
file.writable(data.dir.import)) {
dir.create(paste(data.dir.import, "/Imported", sep = ""), recursive = TRUE)
}
tryCatch({
if (Sys.info()["sysname"] %in% c("Windows", "Linux")) {
download.file(
url = URL,
destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
)
} else {
download.file(
url = URL,
destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
)
}
temp <- load.data(data.dir.import,
fileID = name,
path = paste0(data.dir.import, "/Imported/", name)
)
if (!is.null(temp[[2]])) {
ret$data.set <- temp[[2]]
ret$data.name <- name
} else {
return(NULL)
}
ret
}, error = function(e) {
if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
unlink(paste0(data.dir.import, "Imported/", name))
}
print(e)
}, warning = function(w) {
print(w)
}, finally = {
if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
unlink(paste0(data.dir.import, "/Imported/", name))
}
})
}
get.data.name.from.URL <- function(URL) {
if (grepl("docs.google.com", URL)) {
url.index <- gregexpr("output=", URL)
url.index <- unlist(url.index)
file.type <- substr(URL, url.index + 7, nchar(URL))
temp.file.name <- tempfile()
temp.file.name.index <- gregexpr("file", temp.file.name)
temp.file.name.index <- unlist(temp.file.name.index)
file.name <- substr(
temp.file.name,
temp.file.name.index, nchar(temp.file.name)
)
name <- paste(file.name, file.type, sep = ".")
} else {
name <- strsplit(URL, "/")[[1]]
name <- strsplit(name[length(name)], "?", fixed = T)[[1]][1]
}
return(name)
}
# get data from google docs urls
get.data.from.googledocs <- function(URL, data.dir.import) {
ret <- list()
URL <- URLencode(URL)
url.index <- gregexpr("output=", URL)
url.index <- unlist(url.index)
file.type <- substr(URL, url.index + 7, nchar(URL))
temp.file.name <- tempfile()
temp.file.name.index <- gregexpr("file", temp.file.name)
temp.file.name.index <- unlist(temp.file.name.index)
file.name <- substr(
temp.file.name,
temp.file.name.index, nchar(temp.file.name)
)
name <- paste(file.name, file.type, sep = ".")
if (!file.exists(paste(data.dir.import, "/Imported", sep = "")) &&
file.writable(data.dir.import)) {
dir.create(paste(data.dir.import, "/Imported", sep = ""), recursive = TRUE)
}
tryCatch({
if (Sys.info()["sysname"] %in% c("Windows", "Linux")) {
download.file(
url = URL,
destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
)
} else {
download.file(
url = URL,
destfile = paste0(data.dir.import, "/Imported/", name), method = "auto"
)
}
temp <- load.data(data.dir.import,
fileID = name,
path = paste0(data.dir.import, "/Imported/", name)
)
if (!is.null(temp[[2]])) {
ret$data.set <- temp[[2]]
ret$data.name <- name
} else {
return(NULL)
}
ret
}, error = function(e) {
if (file.exists(paste0(data.dir.import, "/Imported/", name))) {
unlink(paste0(data.dir.import, "Imported/", name))
}
print(e)
}, warning = function(w) {
print(w)
}, finally = {})
}
#' Connerts transparency or alpha value to a
#' percentage integer.
#'
#' @param value Value to convert. Either a
#' value between 0 and 1 in steps of 0.01
#' (back = T) or a value between 0 and 100
#' (back = F).
#' @param back Wether to convert from
#' percentage into fraction (back = T) or
#' from fraction to percentage (back = F).
#'
convert.to.percent <- function(value, back = F) {
# percentage to numeric
if (is.null(value)) {
if (!back) {
x <- 0
} else {
x <- 1
}
} else {
if (back) {
x <- (100 - value) * 0.01
} else {
x <- (1 - value) * 100
}
}
x
}
get.transformation.string <- function(transform_select,
transform_variable_select,
arg3) {
transformation.string <- ""
if (transform_select %in% "log") {
transformation.string <- paste0(
"log(",
transform_variable_select,
")"
)
} else if (transform_select %in% "sqrt") {
transformation.string <- paste0(
"sqrt(",
transform_variable_select,
")"
)
} else if (transform_select %in% "by degree" &&
!arg3 %in% "") {
transformation.string <- paste0(
"I(",
transform_variable_select,
"^",
arg3,
")"
)
} else if (transform_select %in% "polynomial of degree" &&
!arg3 %in% "") {
transformation.string <- paste0(
"poly(",
transform_variable_select,
",", arg3, ")"
)
}
transformation.string
}
#' Searches a list recursivly for a name and
#' returns the value associated with the name
#'
#' @param list.seach A list to search
#' @param search.name A name to be found in a list.
#' If null, the whole simplified list is returned.
#'
#' @return The value found in the list associated with
#' search.name, NULL if not there.
#'
#' @note This function is used to change the
#' everchanging plot output from iNZightPlot.
#'
#' @author Christoph Knapp
search.name <- function(list.search, search.name = NULL) {
list.out <- list()
search <- function(input.list, nam = NULL) {
if (
# "list"%in%class(input.list)||
"inzplotoutput" %in% class(input.list) ||
"inzgrid" %in% class(input.list) ||
"inzpar.list" %in% class(input.list) ||
"inzdot" %in% class(input.list) ||
"inzhist" %in% class(input.list) ||
"inzscatter" %in% class(input.list) ||
"inzbar" %in% class(input.list)) {
for (i in 1:length(input.list)) {
if (!is.null(names(input.list)[i])) {
nam <- names(input.list)[i]
} else {
nam <- i
}
search(input.list[[nam]], nam)
}
} else {
if (is.null(nam)) {
nam <- length(list.out) + 1
}
if (!is.null(input.list)) {
if (nam %in% names(list.out)) {
temp <- list.out[[nam]]
list.out[[nam]][[length(list.out[[nam]]) + 1]] <<- input.list
} else {
list.out[[nam]] <<- list(input.list)
}
}
}
}
search(list.search)
if (is.null(search.name)) {
list.out
} else {
list.out[[search.name]]
}
}
modifyList <- function(x, val, keep.null = FALSE) {
stopifnot(is.list(x), is.list(val))
xnames <- names(x)
vnames <- names(val)
vnames <- vnames[vnames != ""]
if (keep.null) {
for (v in vnames) {
x[v] <- if (v %in% xnames && is.list(x[[v]]) && is.list(val[[v]])) {
list(modifyList(x[[v]], val[[v]], keep.null = keep.null))
} else {
val[v]
}
}
} else {
for (v in vnames) {
x[[v]] <- if (v %in% xnames && is.list(x[[v]]) &&
is.list(val[[v]])) {
modifyList(x[[v]], val[[v]], keep.null = keep.null)
} else {
val[[v]]
}
}
}
x
}
#' fit the regression model using n-way anova (n = 1,2,3)
#'
#' @param y response variable.
#' @param x covariates.
#' @param data Dataset
#' @param blocking blocking variable
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return A fitted model with 'code' attribute
anova.fit <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
# code.list = list()
fit.str <- NULL
if (!is.null(blocking)) {
fit.str <- sprintf("%s ~ %s", y, paste(x, collapse = " * "))
fit <- nlme::lme(as.formula(fit.str),
random = as.formula(sprintf("~1|%s", blocking)), data = data
)
attr(fit, "code") <- sprintf(
"%s = nlme::lme(%s ~ %s, random = ~1|%s, data = %s)",
name, y, paste(x, collapse = " * "), blocking, data.name
)
} else {
fit.str <- sprintf("%s ~ %s", y, paste(x, collapse = " * "))
fit <- lm(as.formula(fit.str), data = data)
attr(fit, "code") <- sprintf(
"%s = lm(%s ~ %s, data = %s)", name, y,
paste(x, collapse = " * "), data.name
)
}
fit
}
#' fit user's own mixed effect model which include a code attribute
#'
#' @param y response variable.
#' @param x fixed effect
#' @param data Dataset
#' @param blocking random effect
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return A fitted model with 'code' attribute
fit.own <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
fit.str <- NULL
if (!is.null(blocking)) {
fit.str <- sprintf("%s ~ %s", y, x)
fit <- nlme::lme(as.formula(fit.str),
random = as.formula(blocking), data = data
)
attr(fit, "code") <- sprintf(
"%s = nlme::lme(%s ~ %s, random = %s, data = %s)",
name, y, x, blocking, data.name
)
} else {
fit.str <- sprintf("%s ~ %s", y, x)
fit <- lm(as.formula(fit.str), data = data)
attr(fit, "code") <- sprintf(
"%s = lm(%s ~ %s, data = %s)", name, y,
x, data.name
)
}
fit
}
#' fit ANOVA (n = 1,2,3)
#'
#' @param y response variable.
#' @param x covariates.
#' @param data Dataset
#' @param blocking blocking variable
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return ANOVA with 'code' attribute
aov.fit <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
if (!is.null(blocking)) {
fit <- aov(as.formula(
sprintf("%s ~ %s + Error(%s)", y, paste(x, collapse = " * "), blocking)
), data = data)
attr(fit, "code") <- c(
sprintf(
"aov_%s = aov(%s ~ %s + Error(%s), data = %s)",
name, y, paste(x, collapse = " * "), blocking, data.name
),
sprintf("summary(%s)", paste0("aov_", name))
)
} else {
fit <- aov(as.formula(sprintf("%s ~ %s", y, paste(x, collapse = " * "))),
data = data
)
attr(fit, "code") <- c(sprintf(
"aov_%s = aov(%s ~ %s, data = %s)", name, y,
paste(x, collapse = " * "), data.name
), sprintf("summary(%s)", paste0("aov_", name)))
}
fit
}
#' ANOVA for customized which include a code attribute
#'
#' @param y response variable.
#' @param x fixed effect
#' @param data Dataset
#' @param blocking random effect
#' @param name name of fitted model
#' @param data.name name of data
#'
#' @return ANOVA with 'code' attribute
aov.own <- function(y, x, data = NULL, blocking = NULL, name, data.name) {
fit.str <- sprintf("%s ~ %s", y, x)
if (!is.null(blocking) && blocking != "") {
fit <- aov(
as.formula(sprintf("%s ~ %s + Error(%s)", y, x, blocking)),
data = data
)
attr(fit, "code") <- c(
sprintf(
"aov_%s = aov(%s ~ %s + Error(%s), data = %s)",
name, y, x, blocking, data.name
),
sprintf("summary(%s)", paste0("aov_", name))
)
} else {
fit <- aov(as.formula(sprintf("%s ~ %s", y, x)), data = data)
attr(fit, "code") <- c(sprintf(
"aov_%s = aov(%s ~ %s, data = %s)", name, y,
x, data.name
), sprintf("summary(%s)", paste0("aov_", name)))
}
fit
}
construct_call <- function(settings, model, vartypes,
data = quote(.dataset),
design = quote(.design),
what = c("plot", "summary", "inference")) {
if (is.null(model$dataDesign)) design <- NULL
iNZightPlots:::construct_call(settings, vartypes, data, design, what)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.