From 68b9ed894ab2634a4f04b273fe1008de9dd21b9e Mon Sep 17 00:00:00 2001 From: jadahlke Date: Sat, 26 May 2018 02:18:02 -0500 Subject: [PATCH] Assorted updates - Updated functions for creating artifact distributions. - Migraded moderator_info to the escalc column. --- R/create_ad.R | 389 ++++++++++++++++++++++++++-- R/create_ad_wrappers.R | 35 ++- R/filter_ma.R | 2 +- R/get_stuff.R | 12 +- R/ma_r.R | 72 ++--- R/ma_r_ic.R | 187 +++++-------- R/ma_wrappers.R | 27 +- R/metareg.R | 24 +- R/methods_dplyr_ma_psychmeta.R | 6 +- R/plotting.R | 4 +- R/wrangle_ads.R | 16 +- R/wrangle_data.R | 16 ++ data/data_r_gonzalezmule_2014.RData | Bin 1483 -> 1482 bytes man/create_ad.Rd | 25 +- man/create_ad_group.Rd | 14 +- man/create_ad_int_group.Rd | 10 +- man/create_ad_tsa_group.Rd | 2 +- man/get_stuff.Rd | 6 +- 18 files changed, 594 insertions(+), 253 deletions(-) diff --git a/R/create_ad.R b/R/create_ad.R index 7037a81..e746f63 100644 --- a/R/create_ad.R +++ b/R/create_ad.R @@ -3,23 +3,180 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_type = rep("alpha", length(rxxi)), k_items_rxxi = rep(NA, length(rxxi)), + rxxa = NULL, n_rxxa = NULL, wt_rxxa = n_rxxa, rxxa_type = rep("alpha", length(rxxa)), k_items_rxxa = rep(NA, length(rxxa)), - ux = NULL, ni_ux = NULL, wt_ux = ni_ux, - ut = NULL, ni_ut = NULL, wt_ut = ni_ut, + ux = NULL, ni_ux = NULL, na_ux = NULL, wt_ux = ni_ux, dep_sds_ux_obs = FALSE, + + ut = NULL, ni_ut = NULL, na_ut = NULL, wt_ut = ni_ut, dep_sds_ut_obs = FALSE, estimate_rxxa = TRUE, estimate_rxxi = TRUE, estimate_ux = TRUE, estimate_ut = TRUE, ...){ - ## TODO: Add standard-error estimates for different types of reliability statistics - + if(length(rxxi) > 0){ + + if(length(n_rxxi) == 0){ + n_rxxi <- rep(NA, length(rxxi)) + if(length(wt_rxxi) == 0){ + wt_rxxi <- rep(1, length(rxxi)) + }else{ + if(length(wt_rxxi) != length(rxxi)) + stop("When wt_rxxi is not NULL, the lengths of rxxi and wt_rxxi must be equal", call. = FALSE) + } + }else{ + if(length(n_rxxi) != length(rxxi)) + stop("When n_rxxi is not NULL, the lengths of rxxi and n_rxxi must be equal", call. = FALSE) + if(length(wt_rxxi) == 0) + wt_rxxi <- n_rxxi + } + + if(length(rxxi_type) == 0){ + rxxi_type <- rep("alpha", length(rxxi)) + k_items_rxxi <- rep(NA, length(rxxi)) + }else{ + if(length(rxxi_type) == 1) + rxxi_type <- rep(rxxi_type, length(rxxi)) + + if(length(rxxi_type) != length(rxxi)) + stop("When rxxi_type is not length 1, the lengths of rxxi and rxxi_type must be equal", call. = FALSE) + } + + if(length(k_items_rxxi) == 0){ + k_items_rxxi <- rep(NA, length(rxxi)) + }else{ + if(length(k_items_rxxi) == 1) + k_items_rxxi <- rep(k_items_rxxi, length(rxxi)) + + if(length(k_items_rxxi) != length(rxxi)) + stop("When k_items_rxxi is not length 1, the lengths of rxxi and k_items_rxxi must be equal", call. = FALSE) + } + }else{ + n_rxxi <- wt_rxxi <- rxxi_type <- k_items_rxxi <- NULL + } + + + if(length(rxxa) > 0){ + + if(length(n_rxxa) == 0){ + n_rxxa <- rep(NA, length(rxxa)) + if(length(wt_rxxa) == 0){ + wt_rxxa <- rep(1, length(rxxa)) + }else{ + if(length(wt_rxxa) != length(rxxa)) + stop("When wt_rxxa is not NULL, the lengths of rxxa and wt_rxxa must be equal", call. = FALSE) + } + }else{ + if(length(n_rxxa) != length(rxxa)) + stop("When n_rxxa is not NULL, the lengths of rxxa and n_rxxa must be equal", call. = FALSE) + if(length(wt_rxxa) == 0) + wt_rxxa <- n_rxxa + } + + if(length(rxxa_type) == 0){ + rxxa_type <- rep("alpha", length(rxxa)) + k_items_rxxa <- rep(NA, length(rxxa)) + }else{ + if(length(rxxa_type) == 1) + rxxa_type <- rep(rxxa_type, length(rxxa)) + + if(length(rxxa_type) != length(rxxa)) + stop("When rxxa_type is not length 1, the lengths of rxxa and rxxa_type must be equal", call. = FALSE) + } + + if(length(k_items_rxxa) == 0){ + k_items_rxxa <- rep(NA, length(rxxa)) + }else{ + if(length(k_items_rxxa) == 1) + k_items_rxxa <- rep(k_items_rxxa, length(rxxa)) + + if(length(k_items_rxxa) != length(rxxa)) + stop("When k_items_rxxa is not length 1, the lengths of rxxa and k_items_rxxa must be equal", call. = FALSE) + } + }else{ + n_rxxa <- wt_rxxa <- rxxa_type <- k_items_rxxa <- NULL + } + + if(length(ux) > 0){ + + if(length(ni_ux) == 0){ + ni_ux <- rep(NA, length(ux)) + if(length(wt_ux) == 0){ + wt_ux <- rep(1, length(ux)) + }else{ + if(length(wt_ux) != length(ux)) + stop("When wt_ux is not NULL, the lengths of ux and wt_ux must be equal", call. = FALSE) + } + }else{ + if(length(ni_ux) != length(ux)) + stop("When ni_ux is not NULL, the lengths of ux and ni_ux must be equal", call. = FALSE) + if(length(wt_ux) == 0) + wt_ux <- ni_ux + } + + if(length(na_ux) == 0){ + na_ux <- rep(NA, length(ux)) + }else{ + if(length(na_ux) != length(ux)) + stop("When na_ux is not NULL, the lengths of ux and na_ux must be equal", call. = FALSE) + } + + if(length(dep_sds_ux_obs) == 0){ + dep_sds_ux_obs <- rep(FALSE, length(ux)) + }else{ + if(length(dep_sds_ux_obs) == 1) + dep_sds_ux_obs <- rep(dep_sds_ux_obs, length(ux)) + + if(length(dep_sds_ux_obs) != length(ux)) + stop("When dep_sds_ux_obs is not length 1, the lengths of ux and dep_sds_ux_obs must be equal", call. = FALSE) + } + }else{ + ni_ux <- wt_ux <- na_ux <- dep_sds_ux_obs <- NULL + } + + if(length(ut) > 0){ + + if(length(ni_ut) == 0){ + ni_ut <- rep(NA, length(ut)) + if(length(wt_ut) == 0){ + wt_ut <- rep(1, length(ut)) + }else{ + if(length(wt_ut) != length(ut)) + stop("When wt_ut is not NULL, the lengths of ut and wt_ut must be equal", call. = FALSE) + } + }else{ + if(length(ni_ut) != length(ut)) + stop("When ni_ut is not NULL, the lengths of ut and ni_ut must be equal", call. = FALSE) + if(length(wt_ut) == 0) + wt_ut <- ni_ut + } + + if(length(na_ut) == 0){ + na_ut <- rep(NA, length(ut)) + }else{ + if(length(na_ut) != length(ut)) + stop("When na_ut is not NULL, the lengths of ut and na_ut must be equal", call. = FALSE) + } + + if(length(dep_sds_ut_obs) == 0){ + dep_sds_ut_obs <- rep(FALSE, length(ut)) + }else{ + if(length(dep_sds_ut_obs) == 1) + dep_sds_ut_obs <- rep(dep_sds_ut_obs, length(ut)) + + if(length(dep_sds_ut_obs) != length(ut)) + stop("When dep_sds_ut_obs is not length 1, the lengths of ut and dep_sds_ut_obs must be equal", call. = FALSE) + } + }else{ + ni_ut <- wt_ut <- na_ut <- dep_sds_ut_obs <- NULL + } + inputs <- list(rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = wt_rxxi, rxxi_type = rxxi_type, k_items_rxxi = k_items_rxxi, rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = wt_rxxa, rxxa_type = rxxa_type, k_items_rxxa = k_items_rxxa, - ux = ux, ni_ux = ni_ux, wt_ux = wt_ux, - ut = ut, ni_ut = ni_ut, wt_ut = wt_ut, + ux = ux, ni_ux = ni_ux, na_ux = na_ux, wt_ux = wt_ux, dep_sds_ux_obs = dep_sds_ux_obs, + ut = ut, ni_ut = ni_ut, na_ut = na_ut, wt_ut = wt_ut, dep_sds_ut_obs = dep_sds_ut_obs, ...) if(is.null(wt_rxxi)) wt_rxxi <- rep(1, length(rxxi)) @@ -68,17 +225,21 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, if(!is.null(ux)){ filtered_ux <- filter_u(u_vec = ux, wt_vec = wt_ux) if(!is.null(ni_ux)) ni_ux <- ni_ux[filtered_ux] + if(!is.null(na_ux)) na_ux <- na_ux[filtered_ux] + if(!is.null(dep_sds_ux_obs)) dep_sds_ux_obs <- dep_sds_ux_obs[filtered_ux] ux <- ux[filtered_ux] wt_ux <- wt_ux[filtered_ux] - if(length(ux) == 0) ux <- ni_ux <- wt_ux <- NULL + if(length(ux) == 0) ux <- ni_ux <- na_ux <- wt_ux <- dep_sds_ux_obs <- NULL } if(!is.null(ut)){ filtered_ut <- filter_u(u_vec = ut, wt_vec = wt_ut) if(!is.null(ni_ut)) ni_ut <- ni_ut[filtered_ut] + if(!is.null(na_ut)) na_ut <- na_ut[filtered_ut] + if(!is.null(dep_sds_ut_obs)) dep_sds_ut_obs <- dep_sds_ut_obs[filtered_ut] ut <- ut[filtered_ut] wt_ut <- wt_ut[filtered_ut] - if(length(ut) == 0) ut <- ni_ut <- wt_ut <- NULL + if(length(ut) == 0) ut <- ni_ut <- na_ut <- wt_ut <- dep_sds_ut_obs <- NULL } .replace_null <- function(x){ @@ -278,16 +439,28 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, } if(!is.null(ni_ux)){ + if(is.null(na_ux)) na_ux <- rep(NA, length(ni_ux)) + if(is.null(dep_sds_ux_obs)) dep_sds_ux_obs <- rep(FALSE, length(dep_sds_ux_obs)) + mean_ni_ux <- mean(ni_ux, na.rm = TRUE) var_e_ux <- var_error_u(u = ux_mean, n_i = mean_ni_ux) + + var_e_ux <- var_error_u(u = ux_mean, n_i = ni_ux, n_a = na_ux, dependent_sds = dep_sds_ux_obs) + var_e_ux <- wt_mean(x = var_e_ux, wt = ni_ux) }else{ mean_ni_ux <- NULL var_e_ux <- NA } if(!is.null(ni_ut)){ + if(is.null(na_ut)) na_ut <- rep(NA, length(ni_ut)) + if(is.null(dep_sds_ut_obs)) dep_sds_ut_obs <- rep(FALSE, length(dep_sds_ut_obs)) + mean_ni_ut <- mean(ni_ut, na.rm = TRUE) var_e_ut <- var_error_u(u = ut_mean, n_i = mean_ni_ut) + + var_e_ut <- var_error_u(u = ut_mean, n_i = ni_ut, n_a = na_ut, dependent_sds = dep_sds_ut_obs) + var_e_ut <- wt_mean(x = var_e_ut, wt = ni_ut) }else{ mean_ni_ut <- NULL var_e_ut <- NA @@ -751,16 +924,16 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, length(rxxi), length(rxxi), length(rxxa), length(rxxa), length(.ux), length(.ut)) - N_vec <- c(sum(n_rxxi), sum(n_rxxi), sum(n_rxxa), sum(n_rxxa), - sum(n_rxxi), sum(n_rxxi), sum(n_rxxa), sum(n_rxxa), - sum(ni_ux), sum(ni_ut)) + N_vec <- c(sum(n_rxxi, na.rm = TRUE), sum(n_rxxi, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), + sum(n_rxxi, na.rm = TRUE), sum(n_rxxi, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), + sum(ni_ux, na.rm = TRUE), sum(ni_ut, na.rm = TRUE)) if(estimate_rxxa){ k_vec <- k_vec + c(0, 0, length(rxxi), length(rxxi), 0, 0, length(rxxi), length(rxxi), 0, 0) - N_vec <- N_vec + c(0, 0, sum(n_rxxi), sum(n_rxxi), - 0, 0, sum(n_rxxi), sum(n_rxxi), + N_vec <- N_vec + c(0, 0, sum(n_rxxi, na.rm = TRUE), sum(n_rxxi, na.rm = TRUE), + 0, 0, sum(n_rxxi, na.rm = TRUE), sum(n_rxxi, na.rm = TRUE), 0, 0) } @@ -768,8 +941,8 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, k_vec <- k_vec + c(length(rxxa), length(rxxa), 0, 0, length(rxxa), length(rxxa), 0, 0, 0, 0) - N_vec <- N_vec + c(sum(n_rxxa), sum(n_rxxa), 0, 0, - sum(n_rxxa), sum(n_rxxa), 0, 0, + N_vec <- N_vec + c(sum(n_rxxa, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), 0, 0, + sum(n_rxxa, na.rm = TRUE), sum(n_rxxa, na.rm = TRUE), 0, 0, 0, 0) } @@ -777,14 +950,14 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, k_vec <- k_vec + c(rep(0, 8), length(.ut), 0) N_vec <- N_vec + c(rep(0, 8), - sum(ni_ut), 0) + sum(ni_ut, na.rm = TRUE), 0) } if(estimate_ut){ k_vec <- k_vec + c(rep(0, 8), 0, length(.ux)) N_vec <- N_vec + c(rep(0, 8), - 0, sum(ni_ux)) + 0, sum(ni_ux, na.rm = TRUE)) } mean_vec <- c(mean_qxi_irr, mean_qxi_drr, @@ -816,6 +989,9 @@ create_ad_int <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, sd = var_vec^.5, sd_e = vare_vec^.5, sd_res = var_res_vec^.5, rel_coef = rel_vec, rel_index = sqrt(rel_vec)) rownames(summary_mat) <- name_vec + summary_mat <- summary_mat[c("qxa_irr", "qxa_drr", "qxi_irr", "qxi_drr", + "rxxa_irr", "rxxa_drr", "rxxi_irr", "rxxi_drr", + "ux", "ut"),] summary_mat[is.na(summary_mat[,"mean"]),] <- NA out <- list(qxa_irr = .create_ad_int(art_vec = rxxa_vec_irr^.5, wt_vec = wt_rxxa_irr), @@ -892,9 +1068,164 @@ create_ad_tsa <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_typ estimate_rxxa = TRUE, estimate_rxxi = TRUE, estimate_ux = TRUE, estimate_ut = TRUE, var_unbiased = TRUE, ...){ - - ## TODO: Add standard-error estimates for different types of reliability statistics - + + if(length(rxxi) > 0){ + + if(length(n_rxxi) == 0){ + n_rxxi <- rep(NA, length(rxxi)) + if(length(wt_rxxi) == 0){ + wt_rxxi <- rep(1, length(rxxi)) + }else{ + if(length(wt_rxxi) != length(rxxi)) + stop("When wt_rxxi is not NULL, the lengths of rxxi and wt_rxxi must be equal", call. = FALSE) + } + }else{ + if(length(n_rxxi) != length(rxxi)) + stop("When n_rxxi is not NULL, the lengths of rxxi and n_rxxi must be equal", call. = FALSE) + if(length(wt_rxxi) == 0) + wt_rxxi <- n_rxxi + } + + if(length(rxxi_type) == 0){ + rxxi_type <- rep("alpha", length(rxxi)) + k_items_rxxi <- rep(NA, length(rxxi)) + }else{ + if(length(rxxi_type) == 1) + rxxi_type <- rep(rxxi_type, length(rxxi)) + + if(length(rxxi_type) != length(rxxi)) + stop("When rxxi_type is not length 1, the lengths of rxxi and rxxi_type must be equal", call. = FALSE) + } + + if(length(k_items_rxxi) == 0){ + k_items_rxxi <- rep(NA, length(rxxi)) + }else{ + if(length(k_items_rxxi) == 1) + k_items_rxxi <- rep(k_items_rxxi, length(rxxi)) + + if(length(k_items_rxxi) != length(rxxi)) + stop("When k_items_rxxi is not length 1, the lengths of rxxi and k_items_rxxi must be equal", call. = FALSE) + } + }else{ + n_rxxi <- wt_rxxi <- rxxi_type <- k_items_rxxi <- NULL + } + + + if(length(rxxa) > 0){ + + if(length(n_rxxa) == 0){ + n_rxxa <- rep(NA, length(rxxa)) + if(length(wt_rxxa) == 0){ + wt_rxxa <- rep(1, length(rxxa)) + }else{ + if(length(wt_rxxa) != length(rxxa)) + stop("When wt_rxxa is not NULL, the lengths of rxxa and wt_rxxa must be equal", call. = FALSE) + } + }else{ + if(length(n_rxxa) != length(rxxa)) + stop("When n_rxxa is not NULL, the lengths of rxxa and n_rxxa must be equal", call. = FALSE) + if(length(wt_rxxa) == 0) + wt_rxxa <- n_rxxa + } + + if(length(rxxa_type) == 0){ + rxxa_type <- rep("alpha", length(rxxa)) + k_items_rxxa <- rep(NA, length(rxxa)) + }else{ + if(length(rxxa_type) == 1) + rxxa_type <- rep(rxxa_type, length(rxxa)) + + if(length(rxxa_type) != length(rxxa)) + stop("When rxxa_type is not length 1, the lengths of rxxa and rxxa_type must be equal", call. = FALSE) + } + + if(length(k_items_rxxa) == 0){ + k_items_rxxa <- rep(NA, length(rxxa)) + }else{ + if(length(k_items_rxxa) == 1) + k_items_rxxa <- rep(k_items_rxxa, length(rxxa)) + + if(length(k_items_rxxa) != length(rxxa)) + stop("When k_items_rxxa is not length 1, the lengths of rxxa and k_items_rxxa must be equal", call. = FALSE) + } + }else{ + n_rxxa <- wt_rxxa <- rxxa_type <- k_items_rxxa <- NULL + } + + if(length(ux) > 0){ + + if(length(ni_ux) == 0){ + ni_ux <- rep(NA, length(ux)) + if(length(wt_ux) == 0){ + wt_ux <- rep(1, length(ux)) + }else{ + if(length(wt_ux) != length(ux)) + stop("When wt_ux is not NULL, the lengths of ux and wt_ux must be equal", call. = FALSE) + } + }else{ + if(length(ni_ux) != length(ux)) + stop("When ni_ux is not NULL, the lengths of ux and ni_ux must be equal", call. = FALSE) + if(length(wt_ux) == 0) + wt_ux <- ni_ux + } + + if(length(na_ux) == 0){ + na_ux <- rep(NA, length(ux)) + }else{ + if(length(na_ux) != length(ux)) + stop("When na_ux is not NULL, the lengths of ux and na_ux must be equal", call. = FALSE) + } + + if(length(dep_sds_ux_obs) == 0){ + dep_sds_ux_obs <- rep(FALSE, length(ux)) + }else{ + if(length(dep_sds_ux_obs) == 1) + dep_sds_ux_obs <- rep(dep_sds_ux_obs, length(ux)) + + if(length(dep_sds_ux_obs) != length(ux)) + stop("When dep_sds_ux_obs is not length 1, the lengths of ux and dep_sds_ux_obs must be equal", call. = FALSE) + } + }else{ + ni_ux <- wt_ux <- na_ux <- dep_sds_ux_obs <- NULL + } + + if(length(ut) > 0){ + + if(length(ni_ut) == 0){ + ni_ut <- rep(NA, length(ut)) + if(length(wt_ut) == 0){ + wt_ut <- rep(1, length(ut)) + }else{ + if(length(wt_ut) != length(ut)) + stop("When wt_ut is not NULL, the lengths of ut and wt_ut must be equal", call. = FALSE) + } + }else{ + if(length(ni_ut) != length(ut)) + stop("When ni_ut is not NULL, the lengths of ut and ni_ut must be equal", call. = FALSE) + if(length(wt_ut) == 0) + wt_ut <- ni_ut + } + + if(length(na_ut) == 0){ + na_ut <- rep(NA, length(ut)) + }else{ + if(length(na_ut) != length(ut)) + stop("When na_ut is not NULL, the lengths of ut and na_ut must be equal", call. = FALSE) + } + + if(length(dep_sds_ut_obs) == 0){ + dep_sds_ut_obs <- rep(FALSE, length(ut)) + }else{ + if(length(dep_sds_ut_obs) == 1) + dep_sds_ut_obs <- rep(dep_sds_ut_obs, length(ut)) + + if(length(dep_sds_ut_obs) != length(ut)) + stop("When dep_sds_ut_obs is not length 1, the lengths of ut and dep_sds_ut_obs must be equal", call. = FALSE) + } + }else{ + ni_ut <- wt_ut <- na_ut <- dep_sds_ut_obs <- NULL + } + inputs <- list(rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = wt_rxxi, rxxi_type = rxxi_type, k_items_rxxi = k_items_rxxi, mean_qxi = mean_qxi, var_qxi = var_qxi, k_qxi = k_qxi, mean_n_qxi = mean_n_qxi, qxi_dist_type = qxi_dist_type, mean_k_items_qxi = mean_k_items_qxi, mean_rxxi = mean_rxxi, var_rxxi = var_rxxi, k_rxxi = k_rxxi, mean_n_rxxi = mean_n_rxxi, rxxi_dist_type = rxxi_dist_type, mean_k_items_rxxi = mean_k_items_rxxi, @@ -930,9 +1261,13 @@ create_ad_tsa <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_typ valid_art <- valid_art & !is.na(wt_vec) if(!is.null(ni_vec)){ - valid_art <- valid_art & !is.na(ni_vec) & !is.infinite(ni_vec) & ni_vec > 0 - ni_vec <- ni_vec[valid_art] + if(any(!is.na(ni_vec))){ + ni_vec <- ni_vec[valid_art] + }else{ + ni_vec <- NULL + } } + if(!is.null(na_vec)) na_vec <- na_vec[valid_art] art_vec <- art_vec[valid_art] wt_vec <- wt_vec[valid_art] @@ -971,12 +1306,12 @@ create_ad_tsa <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_typ var_e <- wt_mean(x = var_e, wt = ni_vec) } }else{ - var_e <- var_error_u(u = art_desc_obs[,"mean"], n_i = mean(ni_vec)) + var_e <- var_error_u(u = art_desc_obs[,"mean"], n_i = mean(ni_vec, na.rm = TRUE)) } var_res <- as.numeric(art_desc_obs[,"var"] - var_e) } - art_desc_obs <- cbind(art_desc_obs, var_res = var_res, total_n = sum(ni_vec), n_wt = 1) + art_desc_obs <- cbind(art_desc_obs, var_res = var_res, total_n = sum(ni_vec, na.rm = TRUE), n_wt = 1) art_desc_obs[,"var_res"] <- ifelse(art_desc_obs[,"var_res"] < 0, 0, as.numeric(art_desc_obs[,"var_res"])) } }else{ @@ -1878,9 +2213,9 @@ create_ad_tsa <- function(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_typ length(rxxa[.valid_rxxa]), length(rxxa[.valid_rxxa]), length(rxxi[.valid_rxxi]), length(rxxi[.valid_rxxi]), length(ux[.valid_ux]), length(ut[.valid_ut])), - N_obs = c(sum(n_rxxa[.valid_rxxa]), sum(n_rxxa[.valid_rxxa]), sum(n_rxxi[.valid_rxxi]), sum(n_rxxi[.valid_rxxi]), - sum(n_rxxa[.valid_rxxa]), sum(n_rxxa[.valid_rxxa]), sum(n_rxxi[.valid_rxxi]), sum(n_rxxi[.valid_rxxi]), - sum(ni_ux[.valid_ux]), sum(ni_ut[.valid_ut])), + N_obs = c(sum(n_rxxa[.valid_rxxa], na.rm = TRUE), sum(n_rxxa[.valid_rxxa], na.rm = TRUE), sum(n_rxxi[.valid_rxxi], na.rm = TRUE), sum(n_rxxi[.valid_rxxi], na.rm = TRUE), + sum(n_rxxa[.valid_rxxa], na.rm = TRUE), sum(n_rxxa[.valid_rxxa], na.rm = TRUE), sum(n_rxxi[.valid_rxxi], na.rm = TRUE), sum(n_rxxi[.valid_rxxi], na.rm = TRUE), + sum(ni_ux[.valid_ux], na.rm = TRUE), sum(ni_ut[.valid_ut], na.rm = TRUE)), p_dists = c(length(c(mean_qxa, mean_rxxa)), length(c(mean_qxa, mean_rxxa)), length(c(mean_qxi, mean_rxxi)), length(c(mean_qxi, mean_rxxi)), length(c(mean_qxa, mean_rxxa)), length(c(mean_qxa, mean_rxxa)), length(c(mean_qxi, mean_rxxi)), length(c(mean_qxi, mean_rxxi)), diff --git a/R/create_ad_wrappers.R b/R/create_ad_wrappers.R index bc452ca..9323a1d 100644 --- a/R/create_ad_wrappers.R +++ b/R/create_ad_wrappers.R @@ -184,9 +184,9 @@ create_ad <- function(ad_type = c("tsa", "int"), out <- create_ad_int(rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = wt_rxxi, rxxi_type = rxxi_type, rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = wt_rxxa, rxxa_type = rxxa_type, - ux = ux, ni_ux = ni_ux, wt_ux = wt_ux, - ut = ut, ni_ut = ni_ut, wt_ut = wt_ut, - + ux = ux, ni_ux = ni_ux, na_ux = na_ux, wt_ux = wt_ux, dep_sds_ux_obs = dep_sds_ux_obs, + ut = ut, ni_ut = ni_ut, na_ut = na_ut, wt_ut = wt_ut, dep_sds_ut_obs = dep_sds_ut_obs, + estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi, estimate_ux = estimate_ux, estimate_ut = estimate_ut) } @@ -326,9 +326,12 @@ create_ad_array <- function(ad_list, name_vec = NULL){ #' All artifact distributions are optional; null distributions will be given an artifact value of 1 and a weight of 1 as placeholders. #' #' @param rGg Vector of correlations between observed-group status and latent-group status. +#' @param n_rGg Vector of sample sizes associated with the elements of rGg. #' @param wt_rGg Vector of weights associated with the elements in rxxi. #' @param pi Vector of incumbent/sample proportions of members in one of the two groups being compared (one or both of pi/pa can be vectors - if both are vectors, they must be of equal length). #' @param pa Vector of applicant/population proportions of members in one of the two groups being compared (one or both of pi/pa can be vectors - if both are vectors, they must be of equal length). +#' @param n_pi Vector of sample sizes associated with the elements in \code{pi}. +#' @param n_pa Vector of sample sizes associated with the elements in \code{pa}. #' @param wt_p Vector of weights associated with the collective element pairs in \code{pi} and pa. #' @param ... Further arguments. #' @@ -340,8 +343,8 @@ create_ad_array <- function(ad_list, name_vec = NULL){ #' @examples #' create_ad_int_group(rGg = c(.9, .8), wt_rGg = c(50, 150), #' pi = c(.9, .8), pa = c(.5, .5), wt_p = c(50, 150)) -create_ad_int_group <- function(rGg = NULL, wt_rGg = rep(1, length(rGg)), - pi = NULL, pa = NULL, wt_p = rep(1, length(pi)), +create_ad_int_group <- function(rGg = NULL, n_rGg = NULL, wt_rGg = n_rGg, + pi = NULL, pa = NULL, n_pi = NULL, n_pa = NULL, wt_p = n_pi, ...){ if(!is.null(pi)) @@ -363,7 +366,8 @@ create_ad_int_group <- function(rGg = NULL, wt_rGg = rep(1, length(rGg)), ux <- NULL } - create_ad_int(rxxi = rxxi, wt_rxxi = wt_rGg, rxxi_type = "group_treatment", ux = ux, wt_ux = wt_p) + create_ad_int(rxxi = rxxi, wt_rxxi = wt_rGg, rxxi_type = "group_treatment", + ux = ux, wt_ux = wt_p, ni_ux = n_pi, na_ux = n_pa) } @@ -403,7 +407,7 @@ create_ad_int_group <- function(rGg = NULL, wt_rGg = rep(1, length(rGg)), #' create_ad_tsa_group(rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), #' mean_rGg = .9, var_rGg = .05, #' k_rGg = 5, mean_n_rGg = 100, -#' pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = 300, +#' pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), #' var_unbiased = TRUE) create_ad_tsa_group <- function(rGg = NULL, n_rGg = NULL, wt_rGg = n_rGg, mean_rGg = NULL, var_rGg = NULL, k_rGg = NULL, mean_n_rGg = NULL, @@ -471,10 +475,16 @@ create_ad_tsa_group <- function(rGg = NULL, n_rGg = NULL, wt_rGg = n_rGg, #' @examples #' ## Example artifact distribution for a dichotomous grouping variable: #' create_ad_group(rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), -#' mean_rGg = .9, var_rGg = .05, -#' k_rGg = 5, mean_n_rGg = 100, -#' pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = 300, -#' var_unbiased = TRUE) +#' mean_rGg = .9, var_rGg = .05, +#' k_rGg = 5, mean_n_rGg = 100, +#' pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), +#' var_unbiased = TRUE) +#' +#' create_ad_group(ad_type = "int", rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), +#' mean_rGg = .9, var_rGg = .05, +#' k_rGg = 5, mean_n_rGg = 100, +#' pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), +#' var_unbiased = TRUE) create_ad_group <- function(ad_type = c("tsa", "int"), rGg = NULL, n_rGg = NULL, wt_rGg = n_rGg, pi = NULL, pa = NULL, n_pi = NULL, n_pa = NULL, wt_p = n_pi, @@ -494,7 +504,8 @@ create_ad_group <- function(ad_type = c("tsa", "int"), pi = pi, pa = pa, n_pi = n_pi, n_pa = n_pa, wt_p = wt_p, var_unbiased = var_unbiased) }else{ - out <- create_ad_int_group(rGg = rGg, wt_rGg = wt_rGg, pi = pi, pa = pa, wt_p = wt_p) + out <- create_ad_int_group(rGg = rGg,n_rGg = n_rGg, wt_rGg = wt_rGg, + pi = pi, pa = pa, n_pi = n_pi, n_pa = n_pa, wt_p = wt_p) } out } diff --git a/R/filter_ma.R b/R/filter_ma.R index d51d5a3..f79583d 100644 --- a/R/filter_ma.R +++ b/R/filter_ma.R @@ -165,7 +165,7 @@ screen_ma <- function(ma_obj){ correct_class <- "ma_psychmeta" %in% class(ma_obj) correct_attributes <- all(c("ma_metric", "ma_methods") %in% names(attributes(ma_obj))) - needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc", "moderator_info") + needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc") correct_cols <- needed_cols %in% colnames(ma_obj) if(!correct_class) diff --git a/R/get_stuff.R b/R/get_stuff.R index 3b9f448..1f5a638 100644 --- a/R/get_stuff.R +++ b/R/get_stuff.R @@ -23,6 +23,7 @@ #' } #' #' @param ma_obj A psychmeta meta-analysis object. +#' @param moderators Logical scalar that determines whether moderator information should be included in the escalc list (\code{TRUE}) or not (\code{FALSE}; default). #' @param follow_up Vector of follow-up analysis names (options are: "heterogeneity", "leave1out", "cumulative", "bootstrap", "metareg"). #' @param plot_types Vector of plot types (options are: "funnel", "forest", "leave1out", "cumulative"). #' @param analyses Which analyses to extract? Can be either \code{"all"} to extract references for all meta-analyses in the object (default) or a list containing one or more of the following arguments: @@ -81,11 +82,20 @@ #' @rdname get_stuff #' @export -get_metafor <- get_escalc <- function(ma_obj, analyses = "all", match = c("all", "any"), case_sensitive = TRUE, ...){ +get_metafor <- get_escalc <- function(ma_obj, moderators = FALSE, analyses = "all", match = c("all", "any"), case_sensitive = TRUE, ...){ ma_obj <- filter_ma(ma_obj = ma_obj, analyses = analyses, match = match, case_sensitive = case_sensitive, ...) out <- ma_obj$escalc + if(!moderators) + out <- map(out, function(x){ + if(any(names(x) == "moderator_info")){ + x$moderator_info <- NULL + x + }else{ + x + } + }) names(out) <- paste0("analysis_id: ", ma_obj$analysis_id) class(out) <- "get_escalc" diff --git a/R/ma_r.R b/R/ma_r.R index 159d8cc..d1f5ca2 100644 --- a/R/ma_r.R +++ b/R/ma_r.R @@ -885,7 +885,7 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, } if(!is.null(moderators)){ - .moderators <- data.frame(as_tibble(moderators)[!valid_r,][.valid_r_xy,]) + .moderators <- as.data.frame(as_tibble(moderators)[!valid_r,][.valid_r_xy,]) }else{ .moderators <- NULL } @@ -951,7 +951,7 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, rxyi <- rxyi[valid_r] n <- n[valid_r] n_adj <- n_adj[valid_r] - if(!is.null(moderators)) moderators <- data.frame(as_tibble(moderators)[valid_r,]) + if(!is.null(moderators)) moderators <- as.data.frame(as_tibble(moderators)[valid_r,]) if(!is.null(citekey)) citekey <- citekey[valid_r] ##### Organize database ##### @@ -1167,49 +1167,30 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, if(!is.null(.psychmeta_reserved_internal_mod_aabbccddxxyyzz)) colnames(.psychmeta_reserved_internal_mod_aabbccddxxyyzz) <- moderator_names[["all"]] - ad_obj_list_tsa <- create_ad_list(ad_type = "tsa", - n = "n", sample_id = "sample_id", - construct_x = "construct_x", construct_y = "construct_y", - rxx = "rxx", rxx_restricted = "rxx_restricted", rxx_type = "rxx_type", k_items_x = "k_items_x", - ryy = "ryy", ryy_restricted = "ryy_restricted", ryy_type = "ryy_type", k_items_y = "k_items_y", - ux = "ux", ux_observed = "ux_observed", - uy = "uy", uy_observed = "uy_observed", - control = control_psychmeta(var_unbiased = var_unbiased, - pairwise_ads = pairwise_ads, - moderated_ads = moderated_ads, - check_dependence = FALSE), - moderators = .psychmeta_reserved_internal_mod_aabbccddxxyyzz, - cat_moderators = cat_moderators, - moderator_type = moderator_type, - construct_order = construct_order, - data = data.frame(es_data, construct_x = construct_x, construct_y = construct_y, data_x, data_y), - control_only = TRUE, process_ads = FALSE, ...) + ad_obj_list <- create_ad_list(n = "n", sample_id = "sample_id", + construct_x = "construct_x", construct_y = "construct_y", + rxx = "rxx", rxx_restricted = "rxx_restricted", rxx_type = "rxx_type", k_items_x = "k_items_x", + ryy = "ryy", ryy_restricted = "ryy_restricted", ryy_type = "ryy_type", k_items_y = "k_items_y", + ux = "ux", ux_observed = "ux_observed", + uy = "uy", uy_observed = "uy_observed", + control = control_psychmeta(var_unbiased = var_unbiased, + pairwise_ads = pairwise_ads, + moderated_ads = moderated_ads, + check_dependence = FALSE), + moderators = .psychmeta_reserved_internal_mod_aabbccddxxyyzz, + cat_moderators = cat_moderators, + moderator_type = moderator_type, + construct_order = construct_order, + data = data.frame(es_data, construct_x = construct_x, construct_y = construct_y, data_x, data_y), + control_only = TRUE, process_ads = FALSE, ...) ad_obj_list_tsa <- join_adobjs(ad_type = "tsa", - primary_ads = ad_obj_list_tsa, + primary_ads = ad_obj_list, harvested_ads = harvested_ads, supplemental_ads = supplemental_ads) - ad_obj_list_int <- create_ad_list(ad_type = "int", - n = "n", sample_id = "sample_id", - construct_x = "construct_x", construct_y = "construct_y", - rxx = "rxx", rxx_restricted = "rxx_restricted", rxx_type = "rxx_type", k_items_x = "k_items_x", - ryy = "ryy", ryy_restricted = "ryy_restricted", ryy_type = "ryy_type", k_items_y = "k_items_y", - ux = "ux", ux_observed = "ux_observed", - uy = "uy", uy_observed = "uy_observed", - control = control_psychmeta(var_unbiased = var_unbiased, - pairwise_ads = pairwise_ads, - moderated_ads = moderated_ads, - check_dependence = FALSE), - moderators = .psychmeta_reserved_internal_mod_aabbccddxxyyzz, - cat_moderators = cat_moderators, - moderator_type = moderator_type, - construct_order = construct_order, - data = data.frame(es_data, construct_x = construct_x, construct_y = construct_y, data_x, data_y), - control_only = TRUE, process_ads = FALSE, ...) - ad_obj_list_int <- join_adobjs(ad_type = "int", - primary_ads = ad_obj_list_int, + primary_ads = ad_obj_list, harvested_ads = harvested_ads, supplemental_ads = supplemental_ads) @@ -1239,9 +1220,6 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, if(!is.null(construct_x)) data <- data.frame(data, construct_x = construct_x[i]) if(!is.null(construct_y)) data <- data.frame(data, construct_y = construct_y[i]) - - ad_x_tsa <- ad_y_tsa <- create_ad_tsa() - ad_x_int <- ad_y_int <- create_ad_tsa() .psychmeta_reserved_internal_mod_aabbccddxxyyzz <- complete_moderators_i if(!is.null(.psychmeta_reserved_internal_mod_aabbccddxxyyzz)) @@ -1284,8 +1262,7 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, ## Ellipsis arguments presorted_data = presorted_data_i, analysis_id_variables = analysis_id_variables, es_d = inputs$es_d, treat_as_d = inputs$treat_as_d, - d_orig = data$d, n1_d = data$n1, n2_d = data$n2, pi_d = data$pi, pa_d = data$pa, - ad_x_tsa = ad_x_tsa, ad_y_tsa = ad_y_tsa, ad_x_int = ad_x_int, ad_y_int = ad_y_int, as_worker = TRUE) + d_orig = data$d, n1_d = data$n1, n2_d = data$n2, pi_d = data$pi, pa_d = data$pa, as_worker = TRUE) if(!is.null(construct_y)) out <- bind_cols(construct_y = rep(construct_y[i][1], nrow(out)), out) if(!is.null(construct_x)) out <- bind_cols(construct_x = rep(construct_x[i][1], nrow(out)), out) @@ -1296,11 +1273,12 @@ ma_r <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, for(i in 1:length(out)) out[[i]] <- bind_cols(pair_id = rep(i, nrow(out[[i]])), out[[i]]) out <- as_tibble(rbindlist(out)) - + out <- join_maobj_adobj(ma_obj = out, ad_obj_x = ad_obj_list_tsa) - out <- rename_(out, ad_x_tsa = "ad_x", ad_y_tsa = "ad_y") + out <- out %>% rename(ad_x_tsa = "ad_x", ad_y_tsa = "ad_y") out <- join_maobj_adobj(ma_obj = out, ad_obj_x = ad_obj_list_int) - out <- rename_(out, ad_x_int = "ad_x", ad_y_int = "ad_y") + out <- out %>% rename(ad_x_int = "ad_x", ad_y_int = "ad_y") + out$ad <- apply(out, 1, function(x){ list(ic = list(ad_x_int = x$ad_x_int, ad_x_tsa = x$ad_x_tsa, diff --git a/R/ma_r_ic.R b/R/ma_r_ic.R index 297a221..d45ec81 100644 --- a/R/ma_r_ic.R +++ b/R/ma_r_ic.R @@ -51,7 +51,9 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, hs_override <- control$hs_override use_all_arts <- control$use_all_arts estimate_pa <- control$estimate_pa - + + control$pairwise_ads <- TRUE + if(hs_override){ wt_type <- "sample_size" error_type <- "mean" @@ -76,12 +78,7 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, as_worker <- additional_args$as_worker if(is.null(as_worker)) as_worker <- FALSE - - ad_x_tsa <- additional_args$ad_x_tsa - ad_y_tsa <- additional_args$ad_y_tsa - ad_x_int <- additional_args$ad_x_int - ad_y_int <- additional_args$ad_y_int - + inputs <- append(inputs, additional_args) presorted_data <- additional_args$presorted_data if(!is.null(additional_args$es_d)){ @@ -225,10 +222,24 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, k_items_x <- manage_arglength(x = k_items_x, y = rxyi) k_items_y <- manage_arglength(x = k_items_y, y = rxyi) - if(use_all_arts & any(!valid_r)){ + harvested_ads <- NULL + if(!as_worker & use_all_arts & any(!valid_r)){ .rxx_type <- rxx_type[!valid_r] .ryy_type <- ryy_type[!valid_r] + if(!is.null(sample_id)){ + .sample_id <- sample_id[!valid_r] + }else{ + .sample_id <- NULL + } + + if(!is.null(moderators)){ + if(!is.null(moderators)) colnames(moderators) <- moderator_names$all + .moderators <- as.data.frame(as_tibble(moderators)[!valid_r,]) + }else{ + .moderators <- NULL + } + .n <- n[!valid_r] .rxx <- manage_arglength(x = rxx, y = rxyi)[!valid_r] .rxx_restricted <- manage_arglength(x = rxx_restricted, y = rxyi)[!valid_r] @@ -242,27 +253,16 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, .k_items_x <- manage_arglength(x = k_items_x, y = rxyi)[!valid_r] .k_items_y <- manage_arglength(x = k_items_y, y = rxyi)[!valid_r] - .supplemental_ads <- create_ad_list(n = .n, + harvested_ads <- create_ad_list(n = .n, + sample_id = .sample_id, construct_x = rep("X", length(.n)), construct_y = rep("Y", length(.n)), rxx = .rxx, rxx_restricted = .rxx_restricted, rxx_type = .rxx_type, k_items_x = .k_items_x, ryy = .ryy, ryy_restricted = .ryy_restricted, ryy_type = .ryy_type, k_items_y = .k_items_y, ux = .ux, ux_observed = .ux_observed, - uy = .uy, uy_observed = .uy_observed, process_ads = FALSE) - .supplemental_ads_x <- .supplemental_ads$X - .supplemental_ads_y <- .supplemental_ads$Y - - if(is.null(supplemental_ads_x)){ - supplemental_ads_x <- .supplemental_ads_x - }else{ - supplemental_ads_x <- consolidate_ads(supplemental_ads_x, .supplemental_ads_x) - } - - if(is.null(supplemental_ads_y)){ - supplemental_ads_y <- .supplemental_ads_y - }else{ - supplemental_ads_y <- consolidate_ads(supplemental_ads_y, .supplemental_ads_y) - } + uy = .uy, uy_observed = .uy_observed, + moderators = .moderators, cat_moderators = cat_moderators, moderator_type = moderator_type, + control = control, process_ads = FALSE) } estimate_rxxa <- additional_args$estimate_rxxa @@ -296,81 +296,35 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, if(!is.null(sample_id)) sample_id <- sample_id[valid_r] if(!is.null(citekey)) citekey <- citekey[valid_r] - - ## Construct artifact distribution for X - rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){rxx[!rxx_restricted]}else{NULL}}else{NULL} - n_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){n[!rxx_restricted]}else{NULL}}else{NULL} - rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){rxx[rxx_restricted]}else{NULL}}else{NULL} - n_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){n[rxx_restricted]}else{NULL}}else{NULL} - .ux <- if(!is.null(ux)){if(any(ux_observed)){ux[ux_observed]}else{NULL}}else{NULL} - n_ux <- if(!is.null(ux)){if(any(ux_observed)){n[ux_observed]}else{NULL}}else{NULL} - ut <- if(!is.null(ux)){if(any(!ux_observed)){ux[!ux_observed]}else{NULL}}else{NULL} - n_ut <- if(!is.null(ux)){if(any(!ux_observed)){n[!ux_observed]}else{NULL}}else{NULL} - - rxxi_type <- if(!is.null(rxx)){if(any(rxx_restricted)){rxx_type[rxx_restricted]}else{NULL}}else{NULL} - rxxa_type <- if(!is.null(rxx)){if(any(!rxx_restricted)){rxx_type[!rxx_restricted]}else{NULL}}else{NULL} - k_items_rxxi <- if(!is.null(rxx)){if(any(rxx_restricted)){k_items_x[rxx_restricted]}else{NULL}}else{NULL} - k_items_rxxa <- if(!is.null(rxx)){if(any(!rxx_restricted)){k_items_x[!rxx_restricted]}else{NULL}}else{NULL} - - if(is.null(ad_x_int)) - ad_x_int <- suppressWarnings(create_ad_supplemental(ad_type = "int", - rxxa = rxxa, n_rxxa = n_rxxa, wt_rxxa = n_rxxa, rxxa_type = rxxa_type, k_items_rxxa = k_items_rxxa, - rxxi = rxxi, n_rxxi = n_rxxi, wt_rxxi = n_rxxi, rxxi_type = rxxi_type, k_items_rxxi = k_items_rxxi, - ux = .ux, ni_ux = n_ux, wt_ux = n_ux, - ut = ut, ni_ut = n_ut, wt_ut = n_ut, - var_unbiased = var_unbiased, - estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi, - estimate_ux = estimate_ux, estimate_ut = estimate_ut, - supplemental_ads = supplemental_ads_x)) - - if(is.null(ad_x_tsa)) - ad_x_tsa <- suppressWarnings(create_ad_supplemental(ad_type = "tsa", - rxxa = rxxa, n_rxxa = n_rxxa, rxxa_type = rxxa_type, k_items_rxxa = k_items_rxxa, - rxxi = rxxi, n_rxxi = n_rxxi, rxxi_type = rxxi_type, k_items_rxxi = k_items_rxxi, - ux = .ux, ni_ux = n_ux, - ut = ut, ni_ut = n_ut, - var_unbiased = var_unbiased, - estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi, - estimate_ux = estimate_ux, estimate_ut = estimate_ut, - supplemental_ads = supplemental_ads_x)) - - ## Construct artifact distribution for Y - ryya <- if(!is.null(ryy)){if(any(!ryy_restricted)){ryy[!ryy_restricted]}else{NULL}}else{NULL} - n_ryya <- if(!is.null(ryy)){if(any(!ryy_restricted)){n[!ryy_restricted]}else{NULL}}else{NULL} - ryyi <- if(!is.null(ryy)){if(any(ryy_restricted)){ryy[ryy_restricted]}else{NULL}}else{NULL} - n_ryyi <- if(!is.null(ryy)){if(any(ryy_restricted)){n[ryy_restricted]}else{NULL}}else{NULL} - .uy <- if(!is.null(uy)){if(any(uy_observed)){uy[uy_observed]}else{NULL}}else{NULL} - n_uy <- if(!is.null(uy)){if(any(uy_observed)){n[uy_observed]}else{NULL}}else{NULL} - up <- if(!is.null(uy)){if(any(!uy_observed)){uy[!uy_observed]}else{NULL}}else{NULL} - n_up <- if(!is.null(uy)){if(any(!uy_observed)){n[!uy_observed]}else{NULL}}else{NULL} - - ryyi_type <- if(!is.null(ryy)){if(any(ryy_restricted)){ryy_type[ryy_restricted]}else{NULL}}else{NULL} - ryya_type <- if(!is.null(ryy)){if(any(!ryy_restricted)){ryy_type[!ryy_restricted]}else{NULL}}else{NULL} - k_items_ryyi <- if(!is.null(ryy)){if(any(ryy_restricted)){k_items_y[ryy_restricted]}else{NULL}}else{NULL} - k_items_ryya <- if(!is.null(ryy)){if(any(!ryy_restricted)){k_items_y[!ryy_restricted]}else{NULL}}else{NULL} - - if(is.null(ad_y_int)) - ad_y_int <- suppressWarnings(create_ad_supplemental(ad_type = "int", - rxxa = ryya, n_rxxa = n_ryya, wt_rxxa = n_ryya, rxxa_type = ryya_type, k_items_rxxa = k_items_ryya, - rxxi = ryyi, n_rxxi = n_ryyi, wt_rxxi = n_ryyi, rxxi_type = ryyi_type, k_items_rxxi = k_items_ryyi, - ux = .uy, ni_ux = n_uy, wt_ux = n_uy, - ut = up, ni_ut = n_up, wt_ut = n_up, - var_unbiased = var_unbiased, - estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi, - estimate_ux = estimate_ux, estimate_ut = estimate_ut, - supplemental_ads = supplemental_ads_y)) - - if(is.null(ad_y_tsa)) - ad_y_tsa <- suppressWarnings(create_ad_supplemental(ad_type = "tsa", - rxxa = ryya, n_rxxa = n_ryya, rxxa_type = ryya_type, k_items_rxxa = k_items_ryya, - rxxi = ryyi, n_rxxi = n_ryyi, rxxi_type = ryyi_type, k_items_rxxi = k_items_ryyi, - ux = .uy, ni_ux = n_uy, - ut = up, ni_ut = n_up, - var_unbiased = var_unbiased, - estimate_rxxa = estimate_rxxa, estimate_rxxi = estimate_rxxi, - estimate_ux = estimate_ux, estimate_ut = estimate_ut, - supplemental_ads = supplemental_ads_y)) + if(!is.null(moderators)) colnames(moderators) <- moderator_names$all + if(!as_worker){ + if(is.null(sample_id)){ + .sample_id <- as.character(1:length(n)) + }else{ + .sample_id <- sample_id + } + ad_obj_list <- create_ad_list(n = n, + sample_id = .sample_id, + construct_x = rep("X", length(n)), + construct_y = rep("Y", length(n)), + rxx = rxx, rxx_restricted = rxx_restricted, rxx_type = rxx_type, k_items_x = k_items_x, + ryy = ryy, ryy_restricted = ryy_restricted, ryy_type = ryy_type, k_items_y = k_items_y, + ux = ux, ux_observed = ux_observed, + uy = uy, uy_observed = uy_observed, + moderators = moderators, cat_moderators = cat_moderators, moderator_type = moderator_type, + control = control, process_ads = FALSE) + + ad_obj_list_tsa <- join_adobjs(ad_type = "tsa", + primary_ads = ad_obj_list, + harvested_ads = harvested_ads, + supplemental_ads = list(X = supplemental_ads_x, Y = supplemental_ads_y)) + + ad_obj_list_int <- join_adobjs(ad_type = "int", + primary_ads = ad_obj_list, + harvested_ads = harvested_ads, + supplemental_ads = list(X = supplemental_ads_x, Y = supplemental_ads_y)) + } if(is.null(rxx)) rxx <- rep(1, length(rxyi)) if(is.null(ryy)) ryy <- rep(1, length(rxyi)) @@ -922,17 +876,32 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, presorted_data = additional_args$presorted_data, analysis_id_variables = additional_args$analysis_id_variables, moderator_levels = moderator_levels, moderator_names = moderator_names) - ad_list <- list(ad = NULL, - ic = list(ad_x_int = ad_x_int, ad_x_tsa = ad_x_tsa, ad_y_int = ad_y_int, ad_y_tsa = ad_y_tsa)) - out$ad <- rep(list(ad_list), nrow(out)) - neg_var_res <- sum(unlist(map(out$meta_tables, function(x) x$barebones$var_res < 0)), na.rm = TRUE) neg_var_rtpa <- sum(unlist(map(out$meta_tables, function(x) x$individual_correction$true_score$var_rho < 0)), na.rm = TRUE) neg_var_rxpa <- sum(unlist(map(out$meta_tables, function(x) x$individual_correction$validity_generalization_x$var_rho < 0)), na.rm = TRUE) neg_var_rtya <- sum(unlist(map(out$meta_tables, function(x) x$individual_correction$validity_generalization_y$var_rho < 0)), na.rm = TRUE) if(!as_worker){ - out <- bind_cols(analysis_id = 1:nrow(out), out) + out <- bind_cols(analysis_id = 1:nrow(out), + construct_x = rep("X", nrow(out)), + construct_y = rep("Y", nrow(out)), + out) + + out <- join_maobj_adobj(ma_obj = out, ad_obj_x = ad_obj_list_tsa) + out <- out %>% rename(ad_x_tsa = "ad_x", ad_y_tsa = "ad_y") + out <- join_maobj_adobj(ma_obj = out, ad_obj_x = ad_obj_list_int) + out <- out %>% rename(ad_x_int = "ad_x", ad_y_int = "ad_y") + out$ad <- apply(out, 1, function(x){ + list(ic = list(ad_x_int = x$ad_x_int, + ad_x_tsa = x$ad_x_tsa, + + ad_y_int = x$ad_y_int, + ad_y_tsa = x$ad_y_tsa), + ad = NULL) + }) + + out <- out %>% select(colnames(out)[!(colnames(out) %in% c("construct_x", "construct_y", "ad_x_int", "ad_x_tsa", "ad_y_int", "ad_y_tsa"))]) + attributes(out) <- append(attributes(out), list(call_history = list(call), inputs = inputs, ma_methods = c("bb", "ic"), @@ -1049,10 +1018,6 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, var_rho_tp_a <- sd_rho_tp_a <- NA se_rtpa <- sd_e_tp_a ci_tp_a <- confidence(mean = mean_rtpa, sd = var_e_tp_a^.5, k = 1, conf_level = conf_level, conf_method = "norm") - - # se_rtpa <- NA - # ci_tp_a <- cbind(NA, NA) - # colnames(ci_tp_a) <- paste("CI", c("LL", "UL"), round(conf_level * 100), sep = "_") }else{ se_rtpa <- sd_rtpa / sqrt(k) ci_tp_a <- confidence(mean = mean_rtpa, sd = var_rtpa^.5, k = k, conf_level = conf_level, conf_method = conf_method) @@ -1126,10 +1091,6 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, var_rho_xp_a <- sd_rho_xp_a <- NA se_rxpa <- sd_e_xp_a ci_xp_a <- confidence(mean = mean_rxpa, sd = var_e_xp_a^.5, k = 1, conf_level = conf_level, conf_method = "norm") - - # se_rxpa <- NA - # ci_xp_a <- cbind(NA, NA) - # colnames(ci_xp_a) <- paste("CI", c("LL", "UL"), round(conf_level * 100), sep = "_") }else{ se_rxpa <- sd_rxpa / sqrt(k) ci_xp_a <- confidence(mean = mean_rxpa, sd = var_rxpa^.5, k = k, conf_level = conf_level, conf_method = conf_method) @@ -1202,10 +1163,6 @@ ma_r_ic <- function(rxyi, n, n_adj = NULL, sample_id = NULL, citekey = NULL, var_rho_ty_a <- sd_rho_ty_a <- NA se_rtya <- sd_e_ty_a ci_ty_a <- confidence(mean = mean_rtya, sd = var_e_ty_a^.5, k = 1, conf_level = conf_level, conf_method = "norm") - - # se_rtya <- NA - # ci_ty_a <- cbind(NA, NA) - # colnames(ci_ty_a) <- paste("CI", c("LL", "UL"), round(conf_level * 100), sep = "_") }else{ se_rtya <- sd_rtya / sqrt(k) ci_ty_a <- confidence(mean = mean_rtya, sd = var_rtya^.5, k = k, conf_level = conf_level, conf_method = conf_method) diff --git a/R/ma_wrappers.R b/R/ma_wrappers.R index c2e0359..cb06e13 100644 --- a/R/ma_wrappers.R +++ b/R/ma_wrappers.R @@ -295,8 +295,6 @@ ma_wrapper <- function(es_data, es_type = "r", ma_type = "bb", ma_fun, es_colname <- colnames(es_data)[colnames(es_data) %in% c("d", "r", "rxyi")] - # moderator_matrix <- data.frame(as_tibble(moderator_matrix)[presorted_data$analysis_id == 1,]) - moderators <- clean_moderators(moderator_matrix = moderator_matrix, cat_moderators = cat_moderators, es_vec = es_data[presorted_data$analysis_id == 1,es_colname]) @@ -354,9 +352,30 @@ ma_wrapper <- function(es_data, es_type = "r", ma_type = "bb", ma_fun, results_df$meta_tables <- map(results_df$ma_out, function(x) x$meta) results_df$escalc <- map(results_df$ma_out, function(x) x$escalc) - results_df$moderator_info <- rep(list(NULL), nrow(results_df)) - results_df$moderator_info[[1]] <- append(moderators, list(data = results_df$escalc[[1]])) + + if(!is.null(moderators$moderator_matrix)) + moderators$moderator_matrix <- bind_cols(original_order = 1:nrow(moderators$moderator_matrix), moderators$moderator_matrix) + if(!is.null(moderators$cat_moderator_matrix)) + moderators$cat_moderator_matrix <- bind_cols(original_order = 1:nrow(moderators$cat_moderator_matrix), moderators$cat_moderator_matrix) + + results_df$escalc <- map(results_df$escalc, function(x1){ + map(x1, function(x2){ + if(length(x2) == 0){ + NULL + }else{ + if(is.data.frame(x2)){ + bind_cols(original_order = 1:nrow(x2), x2) + }else{ + map(x2, function(x3){ + bind_cols(original_order = 1:nrow(x3), x3) + }) + } + } + }) + }) + results_df$escalc[[1]] <- append(results_df$escalc[[1]], list(moderator_info = moderators)) + results_df$ma_out <- NULL if(es_type == "r" & ma_type == "ic"){ diff --git a/R/metareg.R b/R/metareg.R index 9d8383e..6747790 100644 --- a/R/metareg.R +++ b/R/metareg.R @@ -50,16 +50,16 @@ metareg <- function(ma_obj, formula_list = NULL, ...){ escalc <- ma_obj_i$escalc - moderator_matrix <- ma_obj_i$moderator_info$moderator_matrix - cat_moderator_matrix <- ma_obj_i$moderator_info$cat_moderator_matrix - es_data <- ma_obj_i$moderator_info$data$barebones + moderator_matrix <- escalc$moderator_info$moderator_matrix + cat_moderator_matrix <- escalc$moderator_info$cat_moderator_matrix if(!is.null(moderator_matrix)){ moderator_names <- colnames(moderator_matrix) - moderator_names <- gsub(x = moderator_names, pattern = " ", replacement = "_") colnames(moderator_matrix) <- moderator_names - + + moderator_names <- moderator_names[moderator_names != "original_order"] + if(is.null(formula_list)){ formula_list <- list(paste("~", paste(moderator_names, collapse = " + "))) interaction_list <- list() @@ -78,7 +78,7 @@ metareg <- function(ma_obj, formula_list = NULL, ...){ } if("bb" %in% ma_methods){ - data_bb <- bind_cols(moderator_matrix, escalc$barebones) + data_bb <- full_join(moderator_matrix, escalc$barebones, by = "original_order") metareg_bb <- map(formula_list, ~ rma(yi = yi, vi = vi, mods = .x, data = data_bb)) }else{ metareg_bb <- NULL @@ -86,14 +86,14 @@ metareg <- function(ma_obj, formula_list = NULL, ...){ if("ic" %in% ma_methods){ if(es_type == "r"){ - data_ts <- bind_cols(moderator_matrix, escalc$individual_correction$true_score) - data_vgx <- bind_cols(moderator_matrix, escalc$individual_correction$validity_generalization_x) - data_vgy <- bind_cols(moderator_matrix, escalc$individual_correction$validity_generalization_y) + data_ts <- full_join(moderator_matrix, escalc$individual_correction$true_score, by = "original_order") + data_vgx <- full_join(moderator_matrix, escalc$individual_correction$validity_generalization_x, by = "original_order") + data_vgy <- full_join(moderator_matrix, escalc$individual_correction$validity_generalization_y, by = "original_order") } if(es_type == "d"){ - data_ts <- bind_cols(moderator_matrix, escalc$individual_correction$latentGroup_latentY) - data_vgx <- bind_cols(moderator_matrix, escalc$individual_correction$observedGroup_latentY) - data_vgy <- bind_cols(moderator_matrix, escalc$individual_correction$latentGroup_observedY) + data_ts <- full_join(moderator_matrix, escalc$individual_correction$latentGroup_latentY, by = "original_order") + data_vgx <- full_join(moderator_matrix, escalc$individual_correction$observedGroup_latentY, by = "original_order") + data_vgy <- full_join(moderator_matrix, escalc$individual_correction$latentGroup_observedY, by = "original_order") } metareg_ts <- map(formula_list, ~ rma(yi = yi, vi = vi, mods = .x, data = data_ts)) diff --git a/R/methods_dplyr_ma_psychmeta.R b/R/methods_dplyr_ma_psychmeta.R index e9e28d9..4900921 100644 --- a/R/methods_dplyr_ma_psychmeta.R +++ b/R/methods_dplyr_ma_psychmeta.R @@ -13,7 +13,7 @@ select.ma_psychmeta <- function(.data, ...){ attributes(.data) <- .attributes class(.data) <- .class - needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc", "moderator_info") + needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc") correct_cols <- needed_cols %in% colnames(.data) if(!all(correct_cols)) warning("You have removed the following critical columns: ", paste(needed_cols[!correct_cols], collapse = ", "), call. = FALSE) @@ -125,7 +125,7 @@ subset.ma_psychmeta <- function (x, subset, select, drop = FALSE, ...){ attributes(x) <- .attributes class(x) <- .class - needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc", "moderator_info") + needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc") correct_cols <- needed_cols %in% colnames(x) if(!all(correct_cols)) warning("You have removed the following critical columns: ", paste(needed_cols[!correct_cols], collapse = ", "), call. = FALSE) @@ -181,7 +181,7 @@ ungroup.ma_psychmeta <- function (x, ...){ attributes(x) <- .attributes class(x) <- .class - needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc", "moderator_info") + needed_cols <- c("analysis_id", "analysis_type", "meta_tables", "escalc") correct_cols <- needed_cols %in% colnames(x) if(!all(correct_cols)) warning("You have removed the following critical columns: ", paste(needed_cols[!correct_cols], collapse = ", "), call. = FALSE) diff --git a/R/plotting.R b/R/plotting.R index 8f1e429..b576f40 100644 --- a/R/plotting.R +++ b/R/plotting.R @@ -35,7 +35,7 @@ plot_funnel <- function(ma_obj, analyses = "all", match = c("all", "any"), case_ ma_obj_filtered <- filter_ma(ma_obj = ma_obj, analyses = analyses, match = match, case_sensitive = case_sensitive, leave_as_master = TRUE) escalc_list <- get_escalc(ma_obj = ma_obj_filtered) if(show_filtered) ma_obj <- ma_obj_filtered - + ma_methods <- attributes(ma_obj)$ma_methods if("bb" %in% ma_methods){ @@ -45,8 +45,6 @@ plot_funnel <- function(ma_obj, analyses = "all", match = c("all", "any"), case_ barebones <- NULL } - is.data.frame(escalc_list$`analysis_id: 1`$barebones) - is.data.frame(escalc_list$`analysis_id: 1`$individual_correction) out <- map(escalc_list, function(x){ map(x, function(.x){ if(is.data.frame(.x)){ diff --git a/R/wrangle_ads.R b/R/wrangle_ads.R index 3447a02..d0d02c5 100644 --- a/R/wrangle_ads.R +++ b/R/wrangle_ads.R @@ -159,6 +159,7 @@ join_adobjs <- function(ad_type = c("tsa", "int"), primary_ads = NULL, harvested .ad_supplemental <- attributes(.ad_supplemental)$inputs .ad_info <- consolidate_ads(.ad_primary, .ad_harvested, .ad_supplemental) + lapply(.ad_info, length) if(ad_type == "tsa"){ out <- do.call(create_ad_tsa, .ad_info) @@ -219,11 +220,12 @@ join_maobj_adobj <- function(ma_obj, ad_obj_x, ad_obj_y = ad_obj_x){ match_names <- match_names[match_names != "analysis_type"] if(!is.null(ad_obj_x)){ - ad_obj_x <- select_(ad_obj_x, .dots = colnames(ad_obj_x)[colnames(ad_obj_x) != "analysis_type"]) + + ad_obj_x <- ad_obj_x %>% select(colnames(ad_obj_x)[colnames(ad_obj_x) != "analysis_type"]) if(!("construct_x" %in% colnames(ad_obj_x)) & "construct_y" %in% colnames(ad_obj_x)) - ad_obj_x <- rename_(ad_obj_x, construct_x = "construct_y") + ad_obj_x <- ad_obj_x %>% rename(construct_x = "construct_y") if(!("ad_x" %in% colnames(ad_obj_x)) & "ad_y" %in% colnames(ad_obj_x)) - ad_obj_x <- rename_(ad_obj_x, ad_x = "ad_y") + ad_obj_x <- ad_obj_x %>% rename(ad_x = "ad_y") if("ad_y" %in% colnames(ad_obj_x)) ad_obj_x$ad_y <- NULL @@ -237,12 +239,12 @@ join_maobj_adobj <- function(ma_obj, ad_obj_x, ad_obj_y = ad_obj_x){ } if(!is.null(ad_obj_y)){ - ad_obj_y <- select_(ad_obj_y, .dots = colnames(ad_obj_y)[colnames(ad_obj_y) != "analysis_type"]) + + ad_obj_y <- ad_obj_y %>% select(colnames(ad_obj_y)[colnames(ad_obj_y) != "analysis_type"]) if(!("construct_y" %in% colnames(ad_obj_y)) & "construct_x" %in% colnames(ad_obj_y)) - ad_obj_y <- rename_(ad_obj_y, construct_y = "construct_x") + ad_obj_y <- ad_obj_y %>% rename(construct_y = "construct_x") if(!("ad_y" %in% colnames(ad_obj_y)) & "ad_x" %in% colnames(ad_obj_y)) - ad_obj_y <- rename_(ad_obj_y, ad_y = "ad_x") - + ad_obj_y <- ad_obj_y %>% rename(ad_y = "ad_x") if("ad_x" %in% colnames(ad_obj_y)) ad_obj_y$ad_x <- NULL diff --git a/R/wrangle_data.R b/R/wrangle_data.R index ecff489..ebbfb90 100644 --- a/R/wrangle_data.R +++ b/R/wrangle_data.R @@ -1,3 +1,19 @@ +# This is an augmentation of dplyr::select_() that doesn't fail when variable names have spaces in them +smartselect_ <- function (.data, ..., .dots = list()) { + .cols <- colnames(.data) + cols_with_spaces <- .cols[grepl(x = .cols, pattern = " ")] + names(cols_with_spaces) <- gsub(x = cols_with_spaces, pattern = " ", replacement = "_") + colnames(.data) <- gsub(x = colnames(.data), pattern = " ", replacement = "_") + .dots <- gsub(x = .dots, pattern = " ", replacement = "_") + + .data <- select_(.data, ..., .dots = .dots) + + if(length(cols_with_spaces) > 0) + colnames(.data)[colnames(.data) %in% names(cols_with_spaces)] <- cols_with_spaces + + .data +} + fix_df <- function(df){ if(!is.data.frame(df)){ df diff --git a/data/data_r_gonzalezmule_2014.RData b/data/data_r_gonzalezmule_2014.RData index da807081b76a04bec09ca4e9fbfd742a2e9fbfa1..d9a7c5d8b41b2bbf74004df63e41712b2b61f850 100644 GIT binary patch delta 1195 zcmV;c1XTOW3(5Gb#hRWi8_o7UrRZR4coG>-$l$VDWZlrOU`%wn zWRJ+ZpDyV)kcs>iiS;AH@Yh7>np}I2YTx=)JNgaHnl@7^@>WZP9vdK;jHZ{Z@&g0J z&e9FuC#tk*z<?I2#TT6XjKZ@GV2cB2!u#6WD~OVaJjwVp+(bVTes?8Y1AT?3V8s z-jyJ_4mVoax^5pZ0yC^GcK1uy>N1@_4kW1pU+44=TFZ^~A3NwHi$eaU@J5Oz?L0EzbwZ4L zSQ1GhoGCM2y=C=P|2D}#745xJCI3AhI!xFo{46r72{&|jH$AN6>+dPS3jWKftB&phn02?cC|c;)OW`S9Y`1azUm zAJ{sKCK2XOSC~I=Pmw8ZFoe>Yo#W^KpnsNC0}!<-te6}@;AWJRMGxZJ5^v}hSfjG| zrE`5H-=O{0e)%eEyf_c)uhTwfP`-MWc5)>>Yk>GXsQ<-n{NyFp5dBQyUJ&{vroX`& zs-+CQM4UfT@tAzg`EC899fYvAq*DQM zXFQowbDCxOJjVKng+Mo?>Bw;76ziJ%6%}iGwrn)p`<0@Dso_avI3a_}Zjp7vfPyj6 z>5@Gn?*Y1Gz(6MQS0pxo48va&p=)yOJ*s`{Q|%ZqG;7*SsmNO`5qc~^G8s)TTjd85 z#Lm(U-Y2TGDPezTIcnCyMU4sDnjll=ghru-=jK7hvJ5-#_1j%h2{Av;m0JgG-BK0X zL~c!mtIdaqs++9RBF=_G#6)@3AAHLYvB;E`#soIuY1px3idYshXc%IXnuZ9tD!b)7 zhIjQ5U56X3Y+bhxt6uruC*sbdB+@%#V`YMrzwaAH308mfw7-g*>HV6v{5NG&QYEGr zrL!xb+8KWa?()EnB(VZJN3-?Tb))35q(vr>FD&7E+fg)CUen^;1$YL<{;IbVW#EW9sE4wpG;p#oQ=IWd&cGRrx#9+wf=rl=JWaJ{`~3rsQg2W3T96*`TIJgXx)n`8}2&kDL4X#!2(SN%@i+k31K^<9_DcggEDM2i{20q@70wyiSO5 z4@)9RgfnHvtGBGa>fa{$r=q=As^q`NLx%|)g`Y)cHQ|O1@1}>9eEmHoSiyfeb@fpd zkN$rx-7?&FVE1s`dF4B!gG^lKO!@}dtaeB%p!AB9z#=bR1veGMYx1|MOsdU%*lR$m z9O!D&TvNr@S(_>=)*sI5B5)^Cn6+1u`=`)PA&;E%uxB3j*n|Q$LA-Kym3(;dYXZ7Z z;16saMw1Bhrz^}KxTnYzHyA=`&Cc=je^7tRssV`F6jn@*AaFBE%AyDHZHYH@3#?ID z{L;C;l5fy{YrlMzHC~(t_19^iGbmp@OFOxeo;5&x9@PKhHh%IFYlwcPa4!h`64T#c z4b@VHULwvPsd!Aj=KQw)QS!^|#X5#V`?iIdQoL+E*K^Ksf}H!U#Dn$>Pt-T)hv$EN zD^OP+=OSwuudxRAW}rSij|J99a(gkS>9q+wQ72~it3)q>e~Z;a>>INab>#6fyPK?$ z=KFG;HPqZczh6Xt3{S+#^W^nn_?0;K$Ma_EM16l^`Toy0l)J}CcsX!_M4eA-?HNPK zp}>JtZ;+{W9puiT;~c=Dm*8i4dHH{Gz%XLwQHp(u19^yjk)v}d;5Nk8G^Gf}$T_>l zQ>tRXDTa81Sua%Xu~rplYY9iwEtFjwN@EEnP3+?stp#MGQu?prY)FysDv1C6%O8bC zdV4cr(z4SgnB diff --git a/man/create_ad.Rd b/man/create_ad.Rd index 15a1e14..368b3f0 100644 --- a/man/create_ad.Rd +++ b/man/create_ad.Rd @@ -10,8 +10,9 @@ create_ad_int(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, rxxi_type = rep("alpha", length(rxxi)), k_items_rxxi = rep(NA, length(rxxi)), rxxa = NULL, n_rxxa = NULL, wt_rxxa = n_rxxa, rxxa_type = rep("alpha", length(rxxa)), k_items_rxxa = rep(NA, - length(rxxa)), ux = NULL, ni_ux = NULL, wt_ux = ni_ux, ut = NULL, - ni_ut = NULL, wt_ut = ni_ut, estimate_rxxa = TRUE, + length(rxxa)), ux = NULL, ni_ux = NULL, na_ux = NULL, wt_ux = ni_ux, + dep_sds_ux_obs = FALSE, ut = NULL, ni_ut = NULL, na_ut = NULL, + wt_ut = ni_ut, dep_sds_ut_obs = FALSE, estimate_rxxa = TRUE, estimate_rxxi = TRUE, estimate_ux = TRUE, estimate_ut = TRUE, ...) create_ad_tsa(rxxi = NULL, n_rxxi = NULL, wt_rxxi = n_rxxi, @@ -79,14 +80,24 @@ create_ad(ad_type = c("tsa", "int"), rxxi = NULL, n_rxxi = NULL, \item{ni_ux}{Vector of incumbent sample sizes associated with the elements of \code{ux}.} +\item{na_ux}{Vector of applicant sample sizes that can be used in estimating the sampling error of supplied ux values. \code{NULL} by default. +Only used when ni_ux is not NULL. If supplied, must be either a scalar or the same length as \code{ni_ux}.} + \item{wt_ux}{Vector of weights associated with the elements of \code{ux} (by default, sample sizes will be used as weights).} +\item{dep_sds_ux_obs}{Logical scalar or vector determining whether supplied ux values were computed using dependent samples (\code{TRUE}) or independent samples (\code{FALSE}).} + \item{ut}{Vector of true-score u ratios.} \item{ni_ut}{Vector of incumbent sample sizes associated with the elements of \code{ut}.} +\item{na_ut}{Vector of applicant sample sizes that can be used in estimating the sampling error of supplied ut values. \code{NULL} by default. +Only used when ni_ut is not NULL. If supplied, must be either a scalar or the same length as \code{ni_ut}.} + \item{wt_ut}{Vector of weights associated with the elements of \code{ut} (by default, sample sizes will be used as weights).} +\item{dep_sds_ut_obs}{Logical scalar or vector determining whether supplied ut values were computed using dependent samples (\code{TRUE}) or independent samples (\code{FALSE}).} + \item{estimate_rxxa}{Logical argument to estimate rxxa values from other artifacts (\code{TRUE}) or to only used supplied rxxa values (\code{FALSE}). \code{TRUE} by default.} \item{estimate_rxxi}{Logical argument to estimate rxxi values from other artifacts (\code{TRUE}) or to only used supplied rxxi values (\code{FALSE}). \code{TRUE} by default.} @@ -129,11 +140,6 @@ create_ad(ad_type = c("tsa", "int"), rxxi = NULL, n_rxxi = NULL, \item{mean_n_rxxa}{Vector that can be used to supply the mean sample sizes of externally computed distributions of applicant reliabilities.} -\item{na_ux}{Vector of applicant sample sizes that can be used in estimating the sampling error of supplied ux values. \code{NULL} by default. -Only used when ni_ux is not NULL. If supplied, must be either a scalar or the same length as \code{ni_ux}.} - -\item{dep_sds_ux_obs}{Logical scalar or vector determining whether supplied ux values were computed using dependent samples (\code{TRUE}) or independent samples (\code{FALSE}).} - \item{mean_ux}{Vector that can be used to supply the means of externally computed distributions of observed-score u ratios.} \item{var_ux}{Vector that can be used to supply the variances of externally computed distributions of observed-score u ratios.} @@ -146,11 +152,6 @@ Only used when ni_ux is not NULL. If supplied, must be either a scalar or the sa \item{dep_sds_ux_spec}{Logical scalar or vector determining whether externally computed ux distributions were computed using dependent samples (\code{TRUE}) or independent samples (\code{FALSE}).} -\item{na_ut}{Vector of applicant sample sizes that can be used in estimating the sampling error of supplied ut values. \code{NULL} by default. -Only used when ni_ut is not NULL. If supplied, must be either a scalar or the same length as \code{ni_ut}.} - -\item{dep_sds_ut_obs}{Logical scalar or vector determining whether supplied ut values were computed using dependent samples (\code{TRUE}) or independent samples (\code{FALSE}).} - \item{mean_ut}{Vector that can be used to supply the means of externally computed distributions of true-score u ratios.} \item{var_ut}{Vector that can be used to supply the variances of externally computed distributions of true-score u ratios.} diff --git a/man/create_ad_group.Rd b/man/create_ad_group.Rd index e6ce996..e03507f 100644 --- a/man/create_ad_group.Rd +++ b/man/create_ad_group.Rd @@ -53,8 +53,14 @@ Allows consolidation of observed and estimated artifact information by cross-cor \examples{ ## Example artifact distribution for a dichotomous grouping variable: create_ad_group(rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), - mean_rGg = .9, var_rGg = .05, - k_rGg = 5, mean_n_rGg = 100, - pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = 300, - var_unbiased = TRUE) + mean_rGg = .9, var_rGg = .05, + k_rGg = 5, mean_n_rGg = 100, + pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), + var_unbiased = TRUE) + +create_ad_group(ad_type = "int", rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), + mean_rGg = .9, var_rGg = .05, + k_rGg = 5, mean_n_rGg = 100, + pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), + var_unbiased = TRUE) } diff --git a/man/create_ad_int_group.Rd b/man/create_ad_int_group.Rd index d4b10ab..27ad9e4 100644 --- a/man/create_ad_int_group.Rd +++ b/man/create_ad_int_group.Rd @@ -4,18 +4,24 @@ \alias{create_ad_int_group} \title{Generate an artifact distribution object for a dichotomous grouping variable for use in interactive artifact-distribution meta-analysis programs.} \usage{ -create_ad_int_group(rGg = NULL, wt_rGg = rep(1, length(rGg)), pi = NULL, - pa = NULL, wt_p = rep(1, length(pi)), ...) +create_ad_int_group(rGg = NULL, n_rGg = NULL, wt_rGg = n_rGg, pi = NULL, + pa = NULL, n_pi = NULL, n_pa = NULL, wt_p = n_pi, ...) } \arguments{ \item{rGg}{Vector of correlations between observed-group status and latent-group status.} +\item{n_rGg}{Vector of sample sizes associated with the elements of rGg.} + \item{wt_rGg}{Vector of weights associated with the elements in rxxi.} \item{pi}{Vector of incumbent/sample proportions of members in one of the two groups being compared (one or both of pi/pa can be vectors - if both are vectors, they must be of equal length).} \item{pa}{Vector of applicant/population proportions of members in one of the two groups being compared (one or both of pi/pa can be vectors - if both are vectors, they must be of equal length).} +\item{n_pi}{Vector of sample sizes associated with the elements in \code{pi}.} + +\item{n_pa}{Vector of sample sizes associated with the elements in \code{pa}.} + \item{wt_p}{Vector of weights associated with the collective element pairs in \code{pi} and pa.} \item{...}{Further arguments.} diff --git a/man/create_ad_tsa_group.Rd b/man/create_ad_tsa_group.Rd index f7d10ea..d54e135 100644 --- a/man/create_ad_tsa_group.Rd +++ b/man/create_ad_tsa_group.Rd @@ -55,7 +55,7 @@ All artifact distributions are optional; null distributions will be given a mean create_ad_tsa_group(rGg = c(.8, .9, .95), n_rGg = c(100, 200, 250), mean_rGg = .9, var_rGg = .05, k_rGg = 5, mean_n_rGg = 100, - pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = 300, + pi = c(.6, .55, .3), pa = .5, n_pi = c(100, 200, 250), n_pa = c(300, 300, 300), var_unbiased = TRUE) } \keyword{internal} diff --git a/man/get_stuff.Rd b/man/get_stuff.Rd index a5ae133..545dfe8 100644 --- a/man/get_stuff.Rd +++ b/man/get_stuff.Rd @@ -15,8 +15,8 @@ \alias{get_plots} \title{Extract results from a psychmeta meta-analysis object} \usage{ -get_metafor(ma_obj, analyses = "all", match = c("all", "any"), - case_sensitive = TRUE, ...) +get_metafor(ma_obj, moderators = FALSE, analyses = "all", match = c("all", + "any"), case_sensitive = TRUE, ...) get_metatab(ma_obj, analyses = "all", match = c("all", "any"), case_sensitive = TRUE, ma_methods = c("bb", "ic", "ad"), @@ -55,6 +55,8 @@ get_plots(ma_obj, plot_types = c("funnel", "forest", "leave1out", \arguments{ \item{ma_obj}{A psychmeta meta-analysis object.} +\item{moderators}{Logical scalar that determines whether moderator information should be included in the escalc list (\code{TRUE}) or not (\code{FALSE}; default).} + \item{analyses}{Which analyses to extract? Can be either \code{"all"} to extract references for all meta-analyses in the object (default) or a list containing one or more of the following arguments: \itemize{ \item{construct:}{ A list or vector of construct names to search for.}