Skip to content

Commit

Permalink
Assorted updates
Browse files Browse the repository at this point in the history 
- Updated functions for creating artifact distributions.

- Migraded moderator_info to the escalc column.
  • Loading branch information
@jadahlke
jadahlke committed May 26, 2018
1 parent 1ccb02e commit 68b9ed8
Show file tree
Hide file tree
Showing 18 changed files with 594 additions and 253 deletions.
389 changes: 362 additions & 27 deletions R/create_ad.R
View file

Large diffs are not rendered by default.

35 changes: 23 additions & 12 deletions R/create_ad_wrappers.R
View file
Expand Up @@ -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)
}
Expand Down Expand Up @@ -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.
#'
Expand All @@ -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))
Expand All @@ -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)
}


Expand Down Expand Up @@ -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,
Expand Down Expand Up @@ -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,
Expand All @@ -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
}
Expand Down
2 changes: 1 addition & 1 deletion R/filter_ma.R
View file
Expand Up @@ -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)
Expand Down
12 changes: 11 additions & 1 deletion R/get_stuff.R
View file
Expand Up @@ -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:
Expand Down Expand Up @@ -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"
Expand Down
72 changes: 25 additions & 47 deletions R/ma_r.R
View file
Expand Up @@ -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
}
Expand Down Expand Up @@ -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 #####
Expand Down Expand Up @@ -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)

Expand Down Expand Up @@ -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))
Expand Down Expand Up @@ -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)
Expand All @@ -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,
Expand Down

0 comments on commit 68b9ed8

Please sign in to comment.