fix_df <- function(df){
if(!is.data.frame(df)){
df
}else{
as.data.frame(lapply(as.list(df), function(x){
if(is.matrix(x) | is.data.frame(x)){
c(x)
}else{
x
}
}), stringsAsFactors = FALSE)
}
}
match_variables <- function(call, arg, data,
arg_name = NULL, as_array = FALSE, allow_multiple = FALSE) {
x <- tryCatch(eval(call, data, enclos=sys.frame(sys.parent())),
error = function(e) e)
if (inherits(x, "error")) {
stop(paste0("Column `", call, "` not present in `data`."), call. = FALSE)
}
if (!is.null(x)) {
if (is.character(x)) {
if (any(x %in% colnames(data)) & (length(x) == 1 | allow_multiple) & !anyDuplicated(x)) {
d <- tryCatch(data[,x], error = function(e) e)
if (inherits(d, "simpleError")) {
stop(paste("Columns",
paste0("`", x[!x %in% colnames(data)], "`", collapse = ", "),
"not present in `data`."))
} else {
d
}
} else {
if (!is.null(arg_name) & length(x) == 1) {
if(x == arg_name){
x <- NULL
} else {
x
}
}
x
}
} else {
if (as_array & is.null(dim(x))) {
setNames(as.data.frame(x, stringsAsFactors = FALSE),
as.character(call))
} else {
x
}
}
} else {
arg
}
}
## Under development
# match_variables2 <- function(arg, data, name, arg_name, as_df = FALSE){
#
# do_postprocess <- TRUE
# if(length(name) == 1 & !name[1] %in% colnames(data)){
# do_postprocess <- FALSE
# } else if (inherits(try(arg, silent = TRUE), "try-error")) {
# arg <- tryCatch(dplyr::select(data, {{arg}}),
# error = function(e) stop(paste0("The variable `", name, "` supplied as the `" , arg_name, "` argument is not in `data`."), call. = FALSE)
# )
# } else if (is.matrix(arg)) {
# if (is.null(colnames(arg))) {
# arg <- setNames(as.data.frame(`arg`,
# stringsAsFactors = FALSE),
# paste(name,
# 1:ncol(`arg`), sep = "_"))
# } else {
# arg <- as.data.frame(arg,
# stringsAsFactors = FALSE)
# }
# } else if (is.list(arg)) {
# if (is.null(names(arg))) {
# arg <- setNames(as.data.frame(arg,
# stringsAsFactors = FALSE),
# paste(name,
# 1:length(arg), sep = "_"))
# } else {
# arg <- as.data.frame(arg,
# stringsAsFactors = FALSE)
# }
# } else {
# if (length(arg) == nrow(data)) {
# arg <- setNames(as.data.frame(arg,
# stringsAsFactors = FALSE),
# name)
# } else {
# arg <- try(dplyr::select(data, name))
# if (inherits(arg, "try-error"))
# stop(paste0("`", arg_name, "` appears to reference variable(s) not included in `data`.\nIf providing the `", arg_name,"` argument as a vector, `length(", arg_name, ")` must match `nrow(data)`."), call. = FALSE)
# }
# }
#
# if(do_postprocess){
# if(!is.null(data))
# if (nrow(arg) != nrow(data))
# stop("`length(arg)` must match `nrow(data)`.", call. = FALSE)
#
# if(!as_df){
# if(ncol(arg) > 1) stop(paste0("Argument `", arg_name, "` must be a single variable."), call. = FALSE)
# arg <- setNames(c(unlist(arg)), NULL)
# }
# }
#
# return(arg)
# }
match_variables_df <- function(moderators, data, name) {
if (inherits(try(moderators, silent = TRUE), "try-error")) {
moderators <- tryCatch(dplyr::select(data, {{moderators}}),
error = function(e) stop("`moderators` included variables not included in `data`.", call. = FALSE)
)
} else if (is.matrix(moderators)) {
if (is.null(colnames(moderators))) {
moderators <- setNames(as.data.frame(moderators,
stringsAsFactors = FALSE),
paste(name,
1:ncol(moderators), sep = "_"))
} else {
moderators <- as.data.frame(moderators,
stringsAsFactors = FALSE)
}
} else if (is.list(moderators)) {
if (is.null(names(moderators))) {
moderators <- setNames(as.data.frame(moderators,
stringsAsFactors = FALSE),
paste(name,
1:length(moderators), sep = "_"))
} else {
moderators <- as.data.frame(moderators,
stringsAsFactors = FALSE)
}
} else {
if (length(moderators) == nrow(data)) {
moderators <- setNames(as.data.frame(moderators,
stringsAsFactors = FALSE),
name)
} else {
moderators <- try(dplyr::select(data, {{moderators}}))
if (inherits(moderators, "try-error"))
stop("`moderators` included variables not included in `data`.\n If providing moderator vectors directly, `length(moderators)` must match `nrow(data)`.", call. = FALSE)
}
}
if (nrow(moderators) != nrow(data))
stop("`length(moderators)` must match `nrow(data)`.", call. = FALSE)
return(moderators)
}
clean_moderators <- function(moderator_matrix, cat_moderators, es_vec,
moderator_levels = NULL, moderator_names = NULL,
presorted = FALSE){
.moderator_names <- moderator_names
if(!is.null(moderator_matrix)){
if(is.null(dim(moderator_matrix))) moderator_matrix <- data.frame(Moderator = moderator_matrix, stringsAsFactors = FALSE)
es_vec <- unlist(es_vec)
if(!presorted)
if(nrow(moderator_matrix) != length(es_vec))
stop("moderator_matrix must contain as many cases as there are effect sizes in the meta-analysis", call. = FALSE)
moderator_names <- colnames(moderator_matrix)
if(is.null(moderator_names)){
moderator_names <- paste("Moderator", 1:ncol(moderator_matrix), sep = "_")
}else{
moderator_names[moderator_names == ""] <- paste("Moderator", which(moderator_names == ""), sep = "_")
}
colnames(moderator_matrix) <- moderator_names
if(any(cat_moderators)){
cat_moderator_matrix <- moderator_matrix[,cat_moderators]
if(is.null(dim(cat_moderator_matrix))){
cat_moderator_matrix <- as.data.frame(cat_moderator_matrix, stringsAsFactors = FALSE)
colnames(cat_moderator_matrix) <- colnames(moderator_matrix)[cat_moderators]
}
if(!is.null(moderator_levels))
for(i in 1:ncol(cat_moderator_matrix))
cat_moderator_matrix[,i] <- factor(cat_moderator_matrix[,i], levels = moderator_levels[[i]])
moderator_matrix[,cat_moderators] <- cat_moderator_matrix
}else{
cat_moderator_matrix <- NULL
}
}else{
cat_moderator_matrix <- NULL
}
if(!is.null(.moderator_names)){
colnames(moderator_matrix) <- .moderator_names[["all"]]
colnames(cat_moderator_matrix) <- .moderator_names[["cat"]]
}
list(moderator_matrix = moderator_matrix,
cat_moderator_matrix = cat_moderator_matrix)
}
#' Organize a database of multi-construct or moderated information
#'
#' @param es_data Matrix of effect-size data to be used in meta-analyses.
#' @param sample_id Optional vector of identification labels for studies in the meta-analysis.
#' @param citekey Optional vector of bibliographic citation keys for samples/studies in the meta-analysis (if multiple citekeys pertain to a given effect size, combine them into a single string entry with comma delimiters (e.g., "citkey1,citekey2").
#' @param construct_x Vector of construct names for construct initially designated as X.
#' @param construct_y Vector of construct names for construct initially designated as Y.
#' @param facet_x Vector of facet names for construct initially designated as X.
#' @param facet_y Vector of facet names for construct initially designated as Y.
#' @param data_x Additional data (e.g., artifact information) specific to the variables originally designated as X.
#' @param data_y Additional data (e.g., artifact information) specific to the variables originally designated as Y.
#' @param moderators Matrix, dataframe, or vector of moderators.
#' @param use_as_x Vector of construct names to be categorized as X constructs - cannot overlap with the contents of 'use_as_y'.
#' @param use_as_y Vector of construct names to be categorized as Y constructs - cannot overlap with the contents of 'use_as_x'.
#' @param construct_order Vector indicating the order in which variables should be arranged, with variables listed earlier in the vector being preferred for designation as X.
#' @param cat_moderators Logical vector identifying whether each variable in moderators is a categorical variable (TRUE) or a continuous variable (FALSE).
#' @param moderator_levels Optional list of factor levels to be applied to the categorical moderators.
#'
#' @return A reorganized list of study data
#'
#' @keywords internal
organize_database <- function(es_data, sample_id = NULL, citekey = NULL,
construct_x = NULL, construct_y = NULL,
facet_x = NULL, facet_y = NULL,
measure_x = NULL, measure_y = NULL,
data_x = NULL, data_y = NULL, moderators = NULL,
use_as_x = NULL, use_as_y = NULL, construct_order = NULL, cat_moderators = TRUE, moderator_levels = NULL){
if(!is.null(citekey)) es_data <- cbind(citekey = citekey, es_data) %>% mutate(citekey = as.character(citekey))
if(!is.null(sample_id)) es_data <- cbind(sample_id = sample_id, es_data) %>% mutate(sample_id = as.character(sample_id))
if(!is.null(moderators)){
if(is.null(dim(moderators))){
moderators <- data.frame(Moderator_1 = moderators, stringsAsFactors = FALSE)
}
}
## Build a matrix of construct names
if(!is.null(construct_x) | !is.null(construct_y)){
if(is.null(construct_x)){
construct_x <- rep(NA, length(construct_y))
if(!is.null(use_as_x)){
warning("'construct_x' was NULL: use_as_x' is also being set to NULL", call. = FALSE)
use_as_x <- NULL
}
}
if(is.null(construct_y)){
construct_y <- rep(NA, length(construct_x))
if(!is.null(use_as_y)){
warning("'construct_y' was NULL: use_as_y' is also being set to NULL", call. = FALSE)
use_as_y <- NULL
}
}
construct_mat_orig <- cbind(construct_x, construct_y)
}else{
construct_mat_orig <- NULL
}
if(!is.null(construct_mat_orig)) if(all(is.na(construct_mat_orig))) construct_mat_orig <- NULL
if(!is.null(construct_x)) data_x$construct_x <- construct_x
if(!is.null(facet_x)) data_x$facet_x <- facet_x
if(!is.null(measure_x)) data_x$measure_x <- measure_x
data_x <- data.frame(data_x, stringsAsFactors = FALSE)
if(!is.null(construct_y)) data_y$construct_y <- construct_y
if(!is.null(facet_y)) data_y$facet_y <- facet_y
if(!is.null(measure_y)) data_y$measure_y <- measure_y
data_y <- data.frame(data_y, stringsAsFactors = FALSE)
## Create copies of data_x and data_y to manipulate
data_x_reorg <- data_x
data_y_reorg <- data_y
if(!is.null(construct_mat_orig)){
if(!is.null(construct_order)){
keep_id <- construct_mat_orig %in% construct_order
dim(keep_id) <- dim(construct_mat_orig)
if(all(is.na(construct_x)) | all(is.na(construct_y))){
if(all(is.na(construct_x))){
keep_id[,1] <- TRUE
if(!all(is.na(construct_y))){
is_x <- !keep_id[,2]
}
}
if(all(is.na(construct_y))){
keep_id[,2] <- TRUE
if(!all(is.na(construct_x))){
is_x <- keep_id[,1]
}
}
}else{
is_x <- match(construct_mat_orig[,1], construct_order) < match(construct_mat_orig[,2], construct_order)
}
is_x <- cbind(is_x, !is_x)
is_y <- !is_x
keep_id <- apply(keep_id, 1, all)
}else{
if(!is.null(use_as_x) | !is.null(use_as_y)){
if(!is.null(use_as_x) & !is.null(use_as_y)){
## Screen out attemps to mix and match constructs - all must have consistent X and Y designations
if(any(use_as_x %in% use_as_y)) stop("Construct names supplied to 'use_as_x' cannot also be supplied to 'use_as_y'", call. = FALSE)
if(any(use_as_y %in% use_as_x)) stop("Construct names supplied to 'use_as_y' cannot also be supplied to 'use_as_x'", call. = FALSE)
}
if(!is.null(use_as_x)){
## Determine which constructs in which columns should be designated X
is_x <- construct_mat_orig %in% use_as_x
dim(is_x) <- dim(construct_mat_orig)
if(is.null(use_as_y)) is_y <- !is_x
}
if(!is.null(use_as_y)){
## Determine which constructs in which columns should be designated Y
is_y <- construct_mat_orig %in% use_as_y
dim(is_y) <- dim(construct_mat_orig)
if(is.null(use_as_x)) is_x <- !is_y
}
keep_id <- apply(is_x, 1, sum) == 1 & apply(is_y, 1, sum) == 1
}else{
keep_id <- NULL
}
}
if(!is.null(keep_id)){
## Only keep studies that include the variable(s) of interest
es_data <- es_data[keep_id,]
construct_mat_orig <- construct_mat_orig[keep_id,]
is_x <- is_x[keep_id,]
is_y <- is_y[keep_id,]
if(!is.null(data_x)){
data_x <- data_x[keep_id,]
data_x_reorg <- data_x_reorg[keep_id,]
}
if(!is.null(data_y)){
data_y <- data_y[keep_id,]
data_y_reorg <- data_y_reorg[keep_id,]
}
if(!is.null(moderators)) moderators <- moderators[keep_id,]
## Determine which X variables need to be redesignated as Y variables (and vice-versa) and
## move data for all re-designated variables the the appropriate reorganized object
move_y2x <- is_x[,2]
move_x2y <- is_y[,1]
if(!is.null(data_x_reorg) & any(move_y2x)){
data_x_reorg[move_y2x,] <- data_y[move_y2x,]
}
if(!is.null(data_y_reorg) & any(move_x2y)){
data_y_reorg[move_x2y,] <- data_x[move_x2y,]
}
if(!is.null(data_x_reorg)) construct_x <- data_x_reorg$construct_x
if(!is.null(data_y_reorg)) construct_y <- data_y_reorg$construct_y
}
}
if(!is.null(data_x)) data_x$construct_x <- data_x_reorg$construct_x <- NULL
if(!is.null(data_y)) data_y$construct_y <- data_y_reorg$construct_y <- NULL
if(!is.null(construct_x)) construct_x <- as.character(construct_x)
if(!is.null(construct_y)) construct_y <- as.character(construct_y)
if(!is.null(construct_x)) if(all(is.na(construct_x))) construct_x <- NULL
if(!is.null(construct_y)) if(all(is.na(construct_y))) construct_y <- NULL
construct_mat <- cbind(construct_x, construct_y)
construct_dat <- as.data.frame(construct_mat, stringsAsFactors = FALSE)
if(!is.null(use_as_x)) use_as_x <- as.character(use_as_x)
if(!is.null(use_as_y)) use_as_y <- as.character(use_as_y)
if(is.null(construct_order)) construct_order <- c(use_as_x, use_as_y)
if(!is.null(construct_order)){
if(!is.null(construct_x)) construct_dat[,"construct_x"] <- factor(construct_dat[,"construct_x"], levels = construct_order)
if(!is.null(construct_y)) construct_dat[,"construct_y"] <- factor(construct_dat[,"construct_y"], levels = construct_order)
}
if(!is.null(moderators)){
if(is.null(dim(moderators))){
moderators <- data.frame(Moderator_1 = moderators, stringsAsFactors = FALSE)
}
}
## Build the temporary data matrix
temp_mat <- es_data
if(!is.null(data_x_reorg)) temp_mat <- cbind(temp_mat, data_x_reorg)
if(!is.null(data_y_reorg)) temp_mat <- cbind(temp_mat, data_y_reorg)
if(!is.null(moderators)) temp_mat <- cbind(moderators, temp_mat)
if(!is.null(construct_mat)) temp_mat <- cbind(construct_dat, temp_mat)
temp_mat <- as.data.frame(temp_mat, stringsAsFactors = FALSE)
## Pull out the re-organized data
es_data <- temp_mat[,colnames(es_data)]
if(!is.null(construct_dat)){
col_names <- colnames(construct_dat)
construct_mat <- temp_mat[,colnames(construct_dat)]
construct_mat <- as.data.frame(construct_mat, stringsAsFactors = FALSE)
colnames(construct_mat) <- col_names
}
if(!is.null(moderators)){
col_names <- colnames(moderators)
moderators <- temp_mat[,colnames(moderators)]
moderators <- as.data.frame(moderators, stringsAsFactors = FALSE)
colnames(moderators) <- col_names
}
if(!is.null(data_x_reorg)){
col_names <- colnames(data_x_reorg)
data_x_reorg <- temp_mat[,colnames(data_x_reorg)]
data_x_reorg <- as.data.frame(data_x_reorg, stringsAsFactors = FALSE)
colnames(data_x_reorg) <- col_names
}
if(!is.null(data_y_reorg)){
col_names <- colnames(data_y_reorg)
data_y_reorg <- temp_mat[,colnames(data_y_reorg)]
data_y_reorg <- as.data.frame(data_y_reorg, stringsAsFactors = FALSE)
colnames(data_y_reorg) <- col_names
}
facet_x <- facet_y <- measure_x <- measure_y <- NULL
if(!is.null(data_x_reorg))
if(any(colnames(data_x_reorg) == "facet_x")){
facet_x <- as.character(data_x_reorg[,"facet_x"])
data_x_reorg$facet_x <- NULL
}
if(!is.null(data_y_reorg))
if(any(colnames(data_y_reorg) == "facet_y")){
facet_y <- as.character(data_y_reorg[,"facet_y"])
data_y_reorg$facet_y <- NULL
}
if(!is.null(data_x_reorg))
if(any(colnames(data_x_reorg) == "measure_x")){
measure_x <- as.character(data_x_reorg[,"measure_x"])
data_x_reorg$measure_x <- NULL
}
if(!is.null(data_y_reorg))
if(any(colnames(data_y_reorg) == "measure_y")){
measure_y <- as.character(data_y_reorg[,"measure_y"])
data_y_reorg$measure_y <- NULL
}
if(ncol(data_x_reorg) == 0) data_x_reorg <- NULL
if(ncol(data_y_reorg) == 0) data_y_reorg <- NULL
if(!is.null(sample_id)){
sample_id <- as.character(es_data[,"sample_id"])
es_data <- es_data[,colnames(es_data) != "sample_id"]
}
if(!is.null(citekey)){
citekey <- as.character(es_data[,"citekey"])
es_data <- es_data[,colnames(es_data) != "citekey"]
}
moderators_cleaned <- clean_moderators(moderator_matrix = moderators, cat_moderators = cat_moderators, es_vec = es_data[,1], moderator_levels = moderator_levels)
## Return the reorganized data
list(es_data = es_data,
sample_id = sample_id,
citekey = citekey,
construct_x = construct_x,
construct_y = construct_y,
facet_x = facet_x,
facet_y = facet_y,
measure_x = measure_x,
measure_y = measure_y,
data_x = data_x_reorg,
data_y = data_y_reorg,
complete_moderators = moderators_cleaned$moderator_matrix,
categorical_moderators = moderators_cleaned$cat_moderator_matrix)
}
identify_global <- function(sample_id,
construct_x, construct_y,
facet_x, facet_y,
measure_x, measure_y){
valid_facet <- !is.na(facet_x) | !is.na(facet_y)
global_labels <- c("overall", "global", "total")
global_x <- tolower(facet_x) %in% global_labels
global_y <- tolower(facet_y) %in% global_labels
global_both <- global_x & global_y
global_either <- global_x | global_y
global_one <- global_either & !global_both
global <- global_either
if(is.null(measure_x)) measure_x <- rep(NA, length(construct_x))
.measure_x <- measure_x[global_x]
.measure_x[is.na(.measure_x)] <- "No measure specified"
measure_x[global_x] <- .measure_x
if(is.null(measure_y)) measure_y <- rep(NA, length(construct_y))
.measure_y <- measure_y[global_y]
.measure_y[is.na(.measure_y)] <- "No measure specified"
measure_y[global_y] <- .measure_y
construct_mat <- t(apply(cbind(construct_x, construct_y), 1, sort))
sample_construct_pairs <- paste(sample_id, construct_mat[,1], construct_mat[,2])
pairs_both <- sample_construct_pairs[global_both]
pairs_either <- sample_construct_pairs[global_either]
pairs_one <- sample_construct_pairs[global_one]
.pairs_one <- pairs_one[pairs_one %in% pairs_both]
global[sample_construct_pairs %in% .pairs_one & global_one] <- FALSE
pairs_global <- sample_construct_pairs[global]
eliminate <- rep(FALSE, length(global))
eliminate[sample_construct_pairs %in% pairs_global & !global_either] <- TRUE
list(global = global,
retain = !eliminate)
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.