diff --git a/Analysis/Data exploration app/common functions.R b/Analysis/Data exploration app/common functions.R
deleted file mode 100644
index 7a34b66..0000000
--- a/Analysis/Data exploration app/common functions.R
+++ /dev/null
@@ -1,142 +0,0 @@
-
-# Aesthetic functions and presets
-{
- GeomSplitViolin <- ggproto("GeomSplitViolin", GeomViolin,
- draw_group = function(self, data, ..., draw_quantiles = NULL) {
- data <- transform(data, xminv = x - violinwidth * (x - xmin), xmaxv = x + violinwidth * (xmax - x))
- grp <- data[1, "group"]
- newdata <- plyr::arrange(transform(data, x = if (grp %% 2 == 1) xminv else xmaxv), if (grp %% 2 == 1) y else -y)
- newdata <- rbind(newdata[1, ], newdata, newdata[nrow(newdata), ], newdata[1, ])
- newdata[c(1, nrow(newdata) - 1, nrow(newdata)), "x"] <- round(newdata[1, "x"])
-
- if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) {
- stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <=
- 1))
- quantiles <- ggplot2:::create_quantile_segment_frame(data, draw_quantiles)
- aesthetics <- data[rep(1, nrow(quantiles)), setdiff(names(data), c("x", "y")), drop = FALSE]
- aesthetics$alpha <- rep(1, nrow(quantiles))
- both <- cbind(quantiles, aesthetics)
- quantile_grob <- GeomPath$draw_panel(both, ...)
- ggplot2:::ggname("geom_split_violin", grid::grobTree(GeomPolygon$draw_panel(newdata, ...), quantile_grob))
- }
- else {
- ggplot2:::ggname("geom_split_violin", GeomPolygon$draw_panel(newdata, ...))
- }
- })
-
- geom_split_violin <- function(mapping = NULL, data = NULL, stat = "ydensity", position = "identity", ...,
- draw_quantiles = NULL, trim = TRUE, scale = "area", na.rm = FALSE,
- show.legend = NA, inherit.aes = TRUE) {
- layer(data = data, mapping = mapping, stat = stat, geom = GeomSplitViolin,
- position = position, show.legend = show.legend, inherit.aes = inherit.aes,
- params = list(trim = trim, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, ...))
- }
- # Color palette
- {
- palette_weezer_blue <- c("#00a2e7","#dee5cd","#010c09","#083259","#b2915f","#d7b1b7","#00374b","#124e80", "#001212")
- palette_weezer_pinkerton <- c("#d5bf98","#14140b","#70624b","#8a8d82","#304251","#465656","#945a2d","#708090")
- palette_weezer_green <- c("#bece30","#020100","#4f6238","#cac986","#981f2c","#c13f33","#461005")
- palette_weezer_maladroit <- c("#e0dcce","#575b61","#b69e44","#953d31","#e5b066","#343729","#3e3131")
- palette_weezer_make_believe <- c("#000000","#EAECEB","#C2C2C2","#A0A0A0","#313131")
- palette_weezer_red <- c("#ED1B34","#8A817C","#141311","#8B8D9C","#332E28")
- palette_weezer_raditude <- c("#EC2221","#FBFFFB","#FDF600","#CEB181","#4E1110")
- palette_weezer_everything <- c("#E8A662","#F4F5F1","#463D47","#7F3009","#35180E","F6F3CF")
- palette_weezer_white <- c("#FDFDFD","#242424","#E3E3E3","#B6B6B6","#EEEDED")
- palette_weezer_pacific_daydream <- c("#1E3555","#5C6455","#FBE4BC","#1D1F1E","#69797B","#F8E6CF","#F8E6CF")
- palette_weezer_teal <- c("#1DBBBE","#D6A8CD","#F8F8F8","#182633","#90C5DF")
- palette_weezer_black <- c("#2D2B2C","#060606","#E9E7E8","#0E0E0E")
- palette_weezer_ok_human <- c("#B2A17A","#B3B470","#B1A78F","#D1BE8F","#726D5C","#B8B6A6","#5B4F3F")
- palette_weezer_van_weezer <- c("#B2023E","#E933D3","#770265","#170032","#FDF8FF","#170032","#5329F9","#F3FED5")
-
- palette_score_charts <- c(palette_weezer_blue[1],
- palette_weezer_red[1],
- palette_weezer_green[1],
- palette_weezer_teal[1],
-
- palette_weezer_pinkerton[1],
- palette_weezer_van_weezer[3]
- )
- }
-}
-
-# Statistical functions
-{
- bootstrap.clust <- function(data=NA,FUN=NA,clustervar=NA,
- alpha=.05,tails="two-tailed",iters=200){
- # Set up cluster designations
- if(anyNA(clustervar)){ data$cluster.id <- 1:nrow(data)
- } else { data$cluster.id <- data[[clustervar]] }
- cluster.set <- unique(data$cluster.id)
- # Generate original target variable
- point.estimate <- FUN(data)
- # Create distribution of bootstrapped samples
- estimates.bootstrapped <- replicate(iters,{
- # Generate sample of clusters to include
- clust.list <- sample(cluster.set,length(cluster.set),replace = TRUE)
- # Build dataset from cluster list
- data.clust <- do.call(rbind,lapply(1:length(clust.list), function(x) {
- data[data$cluster.id == clust.list[x],]
- }))
- # Run function on new data
- tryCatch(FUN(data.clust),finally=NA)
- },
- simplify=TRUE)
- # Outcomes measures
- if(is.matrix(estimates.bootstrapped)){
- n_estimates <- nrow(estimates.bootstrapped)
- SE <- unlist(lapply(1:n_estimates,function(x) {sd(estimates.bootstrapped[x,],na.rm = TRUE)}))
- if (tails == "two-tailed"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], alpha/2,na.rm = TRUE)}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], 1-alpha/2,na.rm = TRUE)}))
- } else if (tails == "one-tailed, upper"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {NA}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], 1-alpha,na.rm = TRUE)}))
- } else if (tails == "one-tailed, lower"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], alpha,na.rm = TRUE)}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {NA}))
- }
- } else {
- SE <- sd(estimates.bootstrapped,na.rm = TRUE)
- if (tails == "two-tailed"){
- CI.lb <- quantile(estimates.bootstrapped, alpha/2,na.rm = TRUE)
- CI.ub <- quantile(estimates.bootstrapped, 1-alpha/2,na.rm = TRUE)
- } else if (tails == "one-tailed, upper"){
- CI.lb <- NA
- CI.ub <- quantile(estimates.bootstrapped, 1-alpha,na.rm = TRUE)
- } else if (tails == "one-tailed, lower"){
- CI.lb <- quantile(estimates.bootstrapped, alpha,na.rm = TRUE)
- CI.ub <- NA
- }
- }
-
- # Outputs
- return(list("point.estimate"=point.estimate,"SE"=SE,
- "CI.lb"=CI.lb,"CI.ub"=CI.ub,"estimates.bootstrapped"=estimates.bootstrapped))
- }
-
- # Probability/Risk ratio
- probability.ratio <- function(data=NA,exposure,outcome,weight=NA){
- # Generate dataset
- if (is.na(data)){
- exposure <- as.numeric(exposure)
- outcome <- as.numeric(outcome)
- data <- data.frame(exposure,outcome)
- if(anyNA(weight)){
- data$weight <- 1
- } else {
- data$weight <- weight
- }
- } else {
- data$expsoure <- as.numeric(data[[exposure]])
- data$outcome <- as.numeric(data[[exposure]])
- data$weight <- as.numeric(data[[weight]])
- }
-
- prob.exposed <- weighted.mean(data[data$exposure==1,]$outcome,data[data$exposure==1,]$weight,na.rm = TRUE)
- prob.unexposed <- weighted.mean(data[data$exposure==0,]$outcome,data[data$exposure==0,]$weight,na.rm = TRUE)
- probability.ratio <- prob.exposed/prob.unexposed
-
- return(probability.ratio)
- }
-}
-
diff --git a/Analysis/Data exploration app/data exploration app.R b/Analysis/Data exploration app/data exploration app.R
index ee7ce14..a1898ee 100644
--- a/Analysis/Data exploration app/data exploration app.R
+++ b/Analysis/Data exploration app/data exploration app.R
@@ -1,4 +1,3 @@
-
# Setup
{
# Libraries
@@ -10,64 +9,77 @@
library(ggExtra)
library(DT)
library(tidyr)
- library(pbapply)
-
}
# Data loading
{
- if (file.exists("repli_outcomes.RData")) {
- load(file="repli_outcomes.RData")
- } else {
- load(file="Analysis/Data exploration app/repli_outcomes.RData")
- }
-
- if (file.exists("orig_dataset.RData")) {
- load(file="orig_dataset.RData")
- } else {
- load(file="Analysis/Data exploration app/orig_dataset.RData")
- }
-
- if (file.exists("common functions.R")) {
- source("common functions.R")
- } else {
- source(file="Analysis/Data exploration app/common functions.R")
- }
-
+ load(file="repli_outcomes.RData")
+ # Temporary for data cleaning
+ repli_outcomes$generalizability <- ifelse(repli_outcomes$paper_id %in% c("Br0x", "EQxa", "J4W9", "plLK", "rjb", "zlm2"),
+ TRUE,FALSE)
+ repli_outcomes$claim_id_unique <- paste0(repli_outcomes$paper_id,"_",repli_outcomes$claim_id)
+ repli_outcomes$rr_type_internal <- NULL
}
# Data manipulation and other setup
{
# RR UI and selection options data
{
- select_repli_type_set <- c("new data","secondary data")
- select_repli_type_labels <- c("New data","Secondary data")
- select_repli_type_selected_default <- c("new data","secondary data")
-
- select_repli_version_of_record_set <- c(TRUE,FALSE)
- select_repli_version_of_record_labels <- c("VoR","Not VoR")
- select_repli_version_of_record_selected_default <- c(TRUE)
+ select_rr_type_set <- c("Direct Replication","Data Analytic Replication","Hybrid")
+ select_rr_type_labels <- c("Direct Replication","Data Analytic Replication","Hybrid")
+ select_rr_type_selected_default <- c("Direct Replication")
- select_repli_is_generalizability_set <- c(FALSE,TRUE)
- select_repli_is_generalizability_labels <- c("Standard","Generalizability study")
- select_repli_is_generalizability_selected_default <- c(FALSE)
+ select_generalizability_set <- c(FALSE,TRUE)
+ select_generalizability_labels <- c("Standard","Generalizability study")
+ select_generalizability_selected_default <- c(FALSE)
- select_is_manylabs_set <- c(FALSE,TRUE)
- select_is_manylabs_labels <- c("Not ManyLabs","ManyLabs")
- select_is_manylabs_selected_default <- c(FALSE)
+ select_rr_is_manylabs_set <- c("non_ml","ml_count","ml_instance_primary","ml_aggregation")
+ select_rr_is_manylabs_labels <- c("Not ManyLabs","Count","Primary","Aggregation")
+ select_rr_is_manylabs_selected_default <- c("non_ml")
- select_power_for_effect_size_set <- c("50% for 100%","90% for 50%","90% for 75% lab power analysis","not performed")
- select_power_for_effect_size_labels <- c("50% for 100%","90% for 50%","90% for 75% lab power analysis","Not performed")
- select_power_for_effect_size_selected_default <- select_power_for_effect_size_set
+ select_rr_analytic_sample_stage_set <- c("stage 1","stage 2","threshold","no target","lab target")
+ select_rr_analytic_sample_stage_labels <- c("Stage 1","Stage 2","Threshold","No target","Lab target")
+ select_rr_analytic_sample_stage_selected_default <- c("stage 1")
}
}
}
+# Aesthetic functions
+{
+ GeomSplitViolin <- ggproto("GeomSplitViolin", GeomViolin,
+ draw_group = function(self, data, ..., draw_quantiles = NULL) {
+ data <- transform(data, xminv = x - violinwidth * (x - xmin), xmaxv = x + violinwidth * (xmax - x))
+ grp <- data[1, "group"]
+ newdata <- plyr::arrange(transform(data, x = if (grp %% 2 == 1) xminv else xmaxv), if (grp %% 2 == 1) y else -y)
+ newdata <- rbind(newdata[1, ], newdata, newdata[nrow(newdata), ], newdata[1, ])
+ newdata[c(1, nrow(newdata) - 1, nrow(newdata)), "x"] <- round(newdata[1, "x"])
+
+ if (length(draw_quantiles) > 0 & !scales::zero_range(range(data$y))) {
+ stopifnot(all(draw_quantiles >= 0), all(draw_quantiles <=
+ 1))
+ quantiles <- ggplot2:::create_quantile_segment_frame(data, draw_quantiles)
+ aesthetics <- data[rep(1, nrow(quantiles)), setdiff(names(data), c("x", "y")), drop = FALSE]
+ aesthetics$alpha <- rep(1, nrow(quantiles))
+ both <- cbind(quantiles, aesthetics)
+ quantile_grob <- GeomPath$draw_panel(both, ...)
+ ggplot2:::ggname("geom_split_violin", grid::grobTree(GeomPolygon$draw_panel(newdata, ...), quantile_grob))
+ }
+ else {
+ ggplot2:::ggname("geom_split_violin", GeomPolygon$draw_panel(newdata, ...))
+ }
+ })
+
+ geom_split_violin <- function(mapping = NULL, data = NULL, stat = "ydensity", position = "identity", ...,
+ draw_quantiles = NULL, trim = TRUE, scale = "area", na.rm = FALSE,
+ show.legend = NA, inherit.aes = TRUE) {
+ layer(data = data, mapping = mapping, stat = stat, geom = GeomSplitViolin,
+ position = position, show.legend = show.legend, inherit.aes = inherit.aes,
+ params = list(trim = trim, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, ...))
+ }
+}
-ui <- {
-
-fluidPage(title = "SCORE data visualization playground",
+ui <- fluidPage(
tabsetPanel(
tabPanel("Replications",
page_sidebar(
@@ -76,284 +88,113 @@ fluidPage(title = "SCORE data visualization playground",
sidebar = sidebar(
h3("Dataset selection"),
checkboxGroupInput(
- "select_repli_type_selected", "Replication type (repli_type)",
- choiceNames = unique(select_repli_type_labels),
- choiceValues = unique(select_repli_type_set),
- selected = c(select_repli_type_selected_default)
+ "select_rr_type_selected", "Replication type (rr_type)",
+ choiceNames = unique(select_rr_type_labels),
+ choiceValues = unique(select_rr_type_set),
+ selected = c(select_rr_type_selected_default)
),
checkboxGroupInput(
- "select_repli_version_of_record_selected", "Version of Record (repli_version_of_record)",
- choiceNames = unique(select_repli_version_of_record_labels),
- choiceValues = unique(select_repli_version_of_record_set),
- selected = c(select_repli_version_of_record_selected_default)
+ "select_generalizability_selected", "Generalizability (generalizability)",
+ choiceNames = unique(select_generalizability_labels),
+ choiceValues = unique(select_generalizability_set),
+ selected = c(select_generalizability_selected_default)
),
checkboxGroupInput(
- "select_repli_is_generalizability_selected", "Generalizability (repli_is_generalizability)",
- choiceNames = unique(select_repli_is_generalizability_labels),
- choiceValues = unique(select_repli_is_generalizability_set),
- selected = c(select_repli_is_generalizability_selected_default)
+ "select_rr_is_manylabs_selected", "Many Labs (rr_is_manylabs)",
+ choiceNames = unique(select_rr_is_manylabs_labels),
+ choiceValues = unique(select_rr_is_manylabs_set),
+ selected = c(select_rr_is_manylabs_selected_default)
),
checkboxGroupInput(
- "select_is_manylabs_selected", "Many Labs (is_manylabs)",
- choiceNames = unique(select_is_manylabs_labels),
- choiceValues = unique(select_is_manylabs_set),
- selected = c(select_is_manylabs_selected_default)
- ),
- checkboxGroupInput(
- "select_power_for_effect_size_selected", "Replication type (power_for_effect_size)",
- choiceNames = unique(select_power_for_effect_size_labels),
- choiceValues = unique(select_power_for_effect_size_set),
- selected = c(select_power_for_effect_size_selected_default)
+ "select_rr_analytic_sample_stage_selected", "Replication type (rr_analytic_sample_stage)",
+ choiceNames = unique(select_rr_analytic_sample_stage_labels),
+ choiceValues = unique(select_rr_analytic_sample_stage_set),
+ selected = c(select_rr_analytic_sample_stage_selected_default)
),
),
navbarPage("",
- tabPanel("Data properties",
- htmlOutput("repli_data_text")
- ),
- tabPanel("Dataset",
- DTOutput("repli_data_table")
- ),
- tabPanel("Key stats",
- p("takes a bit to load..."),
- htmlOutput("repli_success_text")
- ),
- tabPanel("Chart: repli vs original ES",
-
+ tabPanel("Replication stats vs original",
+ # checkboxGroupInput(
+ # "rr_stat_outcomes_selected", "Outcome stats types",
+ # choiceNames = c("Pearson's R",unique(repli_outcomes$rr_effect_size_type_reported)),
+ # choiceValues = c("Pearson's R",unique(repli_outcomes$rr_effect_size_type_reported)),
+ # selected = c("Pearson's R")
+ # ),
plotOutput("repli_outcomes_vs_orig"),
- h4("Options:"),
- fluidRow(
- column(4,
- #checkboxGroupInput(
- radioButtons(
- "rr_stat_outcomes_selected", "Effect size stats types",
- choiceNames = c("Pearson's R",unique(as.character(repli_outcomes$repli_effect_size_type))),
- choiceValues = c("Pearson's R",unique(as.character(repli_outcomes$repli_effect_size_type))),
- selected = c("Pearson's R"),
- inline=FALSE
- )
- ),
- column(1),
- column(7,
- p("Chart elements; add:"),
- checkboxInput("repli_outcomes_vs_orig_smoothed_dist",
- "Smoothed distributions",TRUE),
- checkboxInput("repli_outcomes_vs_orig_points",
- "Raw data points",TRUE),
- checkboxInput("repli_outcomes_vs_orig_lines",
- "Lines",TRUE),
- checkboxInput("repli_outcomes_vs_orig_points_jitter",
- "Jittered raw data points",FALSE),
- checkboxInput("repli_outcomes_vs_orig_dotplot",
- "Dot plot",FALSE),
-
- p("Chart extent limits"),
- fluidRow(
- column(6,numericInput("repli_outcomes_vs_orig_lb",
- "Lower bound",0)),
- column(6,numericInput("repli_outcomes_vs_orig_ub",
- "Upper bound",1))
- ),
- numericInput("repli_outcomes_vs_orig_null",
- "Null value",0),
- checkboxInput("repli_outcomes_vs_orig_abs",
- "Take absolute value of effect size",FALSE)
-
- )
- )
- )
+ ),
+ tabPanel("Tab 2"),
+ tabPanel("Tab 3")
+
)
)
),
tabPanel("Reproductions")
)
)
-}
server <- function(input, output, session) {
- # Replication
- # Data generation
- df_repli_subsetted <- reactive({
- df <- repli_outcomes
-
- df <- df[df$repli_type %in% input$select_repli_type_selected,]
- df <- df[df$repli_version_of_record %in% input$select_repli_version_of_record_selected,]
- df <- df[df$repli_is_generalizability %in% input$select_repli_is_generalizability_selected,]
- # note: change bottom ones to:
- # df <- df[df$repli_is_manylabs %in% input$select_is_manylabs_selected,]
- # df <- df[df$repli_power_for_effect_size %in% input$select_power_for_effect_size_selected,]
- df <- df[df$is_manylabs %in% input$select_is_manylabs_selected,]
- df <- df[df$power_for_effect_size %in% input$select_power_for_effect_size_selected,]
+ df.repli.subsetted <- reactive({
+ df <- repli_outcomes
+
+ df <- df[df$rr_type %in% input$select_rr_type_selected,]
+ df <- df[df$generalizability %in% input$select_generalizability_selected,]
+ df <- df[df$rr_is_manylabs %in% input$select_rr_is_manylabs_selected,]
+ df <- df[df$rr_analytic_sample_stage %in% input$select_rr_analytic_sample_stage_selected,]
+
+ df
- df
- })
- # Objects / charts / figures
- output$repli_outcomes_vs_orig <- renderPlot({
- df.chart <- df_repli_subsetted()
- df.chart.orig <- orig_dataset
-
- # Merge in orig data
- #df.chart <- merge(df.chart,df.chart.orig,by.x="claim_id",by.y="unique_claim_id",all.x=TRUE,all.y=FALSE)
- df.chart <- merge(df.chart,df.chart.orig,by="claim_id",all.x=TRUE,all.y=FALSE)
-
- df.chart$orig_pearsons_r <- as.numeric(df.chart$original_pearsons_r_numeric)
- df.chart$orig_effect_size_value <- as.numeric(df.chart$original_effect_size_value_reported)
-
- # Gather up new vs originals
- # Pearsons
- df.chart.pearsons <- df.chart[c("repli_pearsons_r_value","orig_pearsons_r")]
- df.chart.pearsons$stat_type <- "Pearson's R"
- colnames(df.chart.pearsons) <- c("Replication","Original","stat_type")
-
- # All others
- df.chart.others <- df.chart[c("repli_effect_size_value","orig_effect_size_value","repli_effect_size_type")]
- colnames(df.chart.others) <- c("Replication","Original","stat_type")
-
- # Combine and select
- df.chart <- rbind(df.chart.pearsons,df.chart.others)
- df.chart$pair <- as.character(1:nrow(df.chart))
- df.chart <- na.omit(df.chart)
- df.chart <- df.chart %>% pivot_longer(!"stat_type" & !"pair", names_to = "comparison", values_to = "ES_value")
-
- df.chart$comparison <- factor(df.chart$comparison,
- labels=c("Replication","Original"),
- levels=c("Replication","Original"))
- df.chart <- df.chart[df.chart$stat_type %in% input$rr_stat_outcomes_selected,]
-
- # Add options
- if (input$repli_outcomes_vs_orig_abs==TRUE){
- df.chart$ES_value <- abs(df.chart$ES_value)
- }
-
- # Chart generation
- p <- ggplot(data=df.chart,aes(y=ES_value,x=reorder(comparison, desc(comparison)),fill=reorder(comparison, desc(comparison)))) +
- theme_bw()+
- scale_fill_manual(values=palette_score_charts)+
- geom_hline(aes(yintercept =input$repli_outcomes_vs_orig_null),linetype=3,color="#454545")+
- theme(
- legend.position = "bottom",
- panel.grid = element_blank(),
- axis.line = element_line(color="#393939"),
- legend.title=element_blank(),
- axis.title.x = element_blank(),
- panel.border = element_blank()
- )+
- scale_y_continuous(limits=c(input$repli_outcomes_vs_orig_lb,input$repli_outcomes_vs_orig_ub))+
- #scale_x_discrete(expand = c(4, 0))+
- theme(aspect.ratio = 1)+
- #xlab("Statistic type")+
- ylab("Effect size value")
-
- pd = position_dodge(width=0.4)
- if (input$repli_outcomes_vs_orig_lines == TRUE){
- p <- p + geom_line(aes(group=pair),color="grey",show.legend=FALSE)
- }
- if (input$repli_outcomes_vs_orig_smoothed_dist == TRUE){
- p <- p + geom_split_violin(show.legend=FALSE)
- }
-
- if (input$repli_outcomes_vs_orig_points_jitter == TRUE){
- p <- p + geom_point(position=position_jitterdodge(),size=1,show.legend=FALSE)
- }
- if (input$repli_outcomes_vs_orig_points == TRUE){
- p <- p + geom_point(position=pd,size=1,show.legend=FALSE)
- }
- if (input$repli_outcomes_vs_orig_dotplot == TRUE){
- p <- p+geom_dotplot(binaxis = "y",
- stackdir = "center",
- dotsize = 0.5,show.legend=FALSE)
- }
-
- p
- })
+ })
- output$repli_data_table <- renderDT(df_repli_subsetted(), options = list(lengthChange = FALSE))
-
- output$repli_data_text <- renderText({
- df <- df_repli_subsetted()
-
- text <- paste0("Replications (n): ",nrow(df))
- text <- paste0(text,"
","Papers (n): ",length(unique(df$paper_id)))
- text <- paste0(text,"
","Claims (n): ",length(unique(df$claim_id)))
- HTML(text)
- })
-
- output$repli_success_text <- renderText({
- df <- df_repli_subsetted()
-
- text <- ""
- # Replication criteria
-
- mean.repli.success <- bootstrap.clust(data=df[c("paper_id","claim_id","repli_pattern_criteria_met")],FUN=
- function(data) {
- mean(data$repli_pattern_criteria_met,na.rm=TRUE)
- },
- alpha=.05,tails="two-tailed")
-
- mean.repli.success.weighted <- bootstrap.clust(data=df[c("paper_id","claim_id","repli_pattern_criteria_met")],FUN=
- function(data) {
- data <- data %>% add_count(paper_id)
- data$weight <- 1/data$n
- weighted.mean(data$repli_pattern_criteria_met,data$weight,na.rm=TRUE)
- },
- clustervar = "paper_id", alpha=.05,tails="two-tailed")
-
- text <- paste0(text,"Percent meeting replication criteria: ")
- text <- paste0(text,"(n=",length(na.omit(df$repli_pattern_criteria_met)),")")
- text <- paste0(text,"
")
- text <- paste0(text,"Unweighted/unclustered: ",round(mean.repli.success$point.estimate,3)*100,"%")
- text <- paste0(text," (95% CI: ",round(mean.repli.success$CI.lb,3)*100," - ", round(mean.repli.success$CI.ub,3)*100,"%)")
- text <- paste0(text,"
")
-
- text <- paste0(text,"Clustered/weighted at the paper level: ",round(mean.repli.success.weighted$point.estimate,3)*100,"%")
- text <- paste0(text," (95% CI: ",round(mean.repli.success.weighted$CI.lb,3)*100," - ", round(mean.repli.success.weighted$CI.ub,3)*100,"%)")
- text <- paste0(text,"
")
- text <- paste0(text,"
")
-
- mean.repli.success <- bootstrap.clust(data=df[c("paper_id","claim_id","repli_interpret_supported")],FUN=
- function(data) {
- mean(data$repli_interpret_supported=="yes",na.rm=TRUE)
- },
- alpha=.05,tails="two-tailed",iters=100)
-
- mean.repli.success.weighted <- bootstrap.clust(data=df[c("paper_id","claim_id","repli_interpret_supported")],FUN=
- function(data) {
- data <- data %>% add_count(paper_id)
- data$weight <- 1/data$n
- weighted.mean(data$repli_interpret_supported=="yes",data$weight,na.rm=TRUE)
- },
- clustervar = "paper_id", alpha=.05,tails="two-tailed")
-
- text <- paste0(text,"Percent interpretation supported (subjective assessment by lab): ")
- text <- paste0(text,"(n=",length(na.omit(df$repli_interpret_supported)),")")
- text <- paste0(text,"
")
- text <- paste0(text,"Unweighted/unclustered: ",round(mean.repli.success$point.estimate,3)*100,"%")
- text <- paste0(text," (95% CI: ",round(mean.repli.success$CI.lb,3)*100," - ", round(mean.repli.success$CI.ub,3)*100,"%)")
- text <- paste0(text,"
")
-
- text <- paste0(text,"Clustered/weighted at the paper level: ",round(mean.repli.success.weighted$point.estimate,3)*100,"%")
- text <- paste0(text," (95% CI: ",round(mean.repli.success.weighted$CI.lb,3)*100," - ", round(mean.repli.success.weighted$CI.ub,3)*100,"%)")
- text <- paste0(text,"
")
- text <- paste0(text,"
")
-
- rr.success.repli.type.weighted <- bootstrap.clust(data=df[c("paper_id","claim_id","repli_pattern_criteria_met","repli_type")],FUN=
- function(data) {
- data <- data %>% add_count(paper_id)
- data$weight <- 1/data$n
- probability.ratio(exposure = data$repli_type=="new data",
- outcome = data$repli_pattern_criteria_met,
- weight = data$weight)
- },
- clustervar = "paper_id", alpha=.05,tails="two-tailed")
-
- text <- paste0(text,"Relative proportion replication success by data type: ",round(rr.success.repli.type.weighted$point.estimate,3))
- text <- paste0(text," (95% CI: ",round(rr.success.repli.type.weighted$CI.lb,3)," - ", round(rr.success.repli.type.weighted$CI.ub,3),")")
- text <- paste0(text,"
")
- text <- paste0(text,"Interpretation: Replication attempts using new data were ",round(rr.success.repli.type.weighted$point.estimate,3),
- " times as likely to have replication criteria met compared with those replications using pre-existing/secondary data.")
- text <- paste0(text,"
")
+ output$repli_outcomes_vs_orig <- renderPlot({
+ df.chart <- df.repli.subsetted()
+
+ # TEMPORARY FOR MADE UP DATA
+ df.chart$rr_pearsons_r_value_reference <- df.chart$rr_pearsons_r_value*1.1
+
+ # Gather up new vs originals
+ # Pearsons
+ df.chart.pearsons <- df.chart[c("rr_pearsons_r_value","rr_effect_size_value_reference")]
+ df.chart.pearsons$stat_type <- "Pearson's R"
+ colnames(df.chart.pearsons) <- c("Replication","Original","stat_type")
+
+ # All others
+ df.chart.others <- df.chart[c("rr_statistic_value_reported","rr_effect_size_value_reference","rr_effect_size_type_reported")]
+ colnames(df.chart.others) <- c("Replication","Original","stat_type")
+ types_to_keep <- c("ser_method")
+ df.chart.others <- df.chart.others[df.chart.others$stat_type %in% types_to_keep,]
+
+ # Combine
+ df.chart <- rbind(df.chart.pearsons,df.chart.others)
+ df.chart <- df.chart %>% pivot_longer(!"stat_type", names_to = "comparison", values_to = "ES_value")
+ df.chart <- na.omit(df.chart)
+ df.chart$stat_type <- factor(df.chart$stat_type,
+ labels=c("Pearson's R","SER"),
+ levels=c("Pearson's R","ser_method"))
+ df.chart$comparison <- factor(df.chart$comparison,
+ labels=c("Replication","Original"),
+ levels=c("Replication","Original"))
+
+ ggplot(data=df.chart,aes(y=ES_value,x=stat_type,fill=comparison)) +
+ geom_split_violin()+
+ #geom_histogram(fill="#2B2484",alpha=.4)+
+ #geom_density(fill="#2B2484",alpha=.8)+
+ #scale_x_continuous(expand=c(0,0))+
+ #scale_y_continuous(expand=c(0,0))+
+ theme_minimal()+
+ theme(
+ legend.position = "bottom",
+ panel.grid = element_blank(),
+ axis.line = element_line(color="#393939")
+ )+
+ xlab("Statistic type")+
+ ylab("Effect size value")
- HTML(text)
- })
+ })
+
+ output$data.table.temp = renderDT(
+ df.repli.subsetted(), options = list(lengthChange = FALSE)
+ )
+
}
shinyApp(ui, server)
\ No newline at end of file
diff --git a/Analysis/Data exploration app/orig_dataset.RData b/Analysis/Data exploration app/orig_dataset.RData
deleted file mode 100644
index 7766a5a..0000000
Binary files a/Analysis/Data exploration app/orig_dataset.RData and /dev/null differ
diff --git a/Analysis/Data exploration app/repli_outcomes.RData b/Analysis/Data exploration app/repli_outcomes.RData
index 7465dca..ac33b5d 100644
Binary files a/Analysis/Data exploration app/repli_outcomes.RData and b/Analysis/Data exploration app/repli_outcomes.RData differ
diff --git a/Analysis/Data exploration app/rsconnect/documents/data exploration app.R/shinyapps.io/noahhaber-cos/data_exploration_app.dcf b/Analysis/Data exploration app/rsconnect/documents/data exploration app.R/shinyapps.io/noahhaber-cos/data_exploration_app.dcf
index 4c8d868..3711367 100644
--- a/Analysis/Data exploration app/rsconnect/documents/data exploration app.R/shinyapps.io/noahhaber-cos/data_exploration_app.dcf
+++ b/Analysis/Data exploration app/rsconnect/documents/data exploration app.R/shinyapps.io/noahhaber-cos/data_exploration_app.dcf
@@ -5,7 +5,7 @@ account: noahhaber-cos
server: shinyapps.io
hostUrl: https://api.shinyapps.io/v1
appId: 10223971
-bundleId: 8022432
+bundleId: 7815897
url: https://noahhaber-cos.shinyapps.io/data_exploration_app/
version: 1
asMultiple: FALSE
diff --git a/Analysis/code whiteboard.R b/Analysis/code whiteboard.R
index 27ca160..868ecb8 100644
--- a/Analysis/code whiteboard.R
+++ b/Analysis/code whiteboard.R
@@ -11,37 +11,16 @@
library(ggsankey)
library(plotly)
library(viridis)
-
}
# tar_make() # run this to pull new targets
-
-#tar_load("repli_export")
-#tar_load("repli_primary")
+tar_load("repli_export")
+tar_load("repli_primary")
tar_load("repli_outcomes")
-#tar_load("orig_statistics_dataset_p1")
-
-# #tar_load("repli_export")
-# #tar_load("repli_primary")
-# tar_load("repli_outcomes")
-# #tar_load("orig_statistics_dataset_p1")
-# tar_load("orig_dataset")
-
-
-# Update app data
-if (FALSE){
- tar_load("repli_outcomes")
- save(repli_outcomes,file="Analysis/Data exploration app/repli_outcomes.RData")
-
- tar_load("orig_dataset")
- save(orig_dataset,file="Analysis/Data exploration app/orig_dataset.RData")
-
- tar_load("repro_export")
-
-
-}
+tar_load("orig_statistics_dataset_p1")
+save(repli_outcomes,file="Analysis/Data exploration app/repli_outcomes.RData")
# UI and selection options data
{
@@ -60,7 +39,7 @@ if (FALSE){
# Generate selection data functions
{
- df_repli_subsetted <- function(select_rr_type_selection_ui = c(TRUE,FALSE,FALSE),
+ generate_selected_repli_data <- function(select_rr_type_selection_ui = c(TRUE,FALSE,FALSE),
select_generalizability_selection_ui = c(TRUE,FALSE),
select_rr_is_manylabs_selection_ui = c(TRUE,FALSE,FALSE,FALSE),
select_rr_analytic_sample_stage_selection_ui = c(TRUE,TRUE,FALSE,FALSE,FALSE)){
@@ -128,267 +107,110 @@ if (FALSE){
position = position, show.legend = show.legend, inherit.aes = inherit.aes,
params = list(trim = trim, scale = scale, draw_quantiles = draw_quantiles, na.rm = na.rm, ...))
}
- # Color palette
- {
- palette_weezer_blue <- c("#00a2e7","#dee5cd","#010c09","#083259","#b2915f","#d7b1b7","#00374b","#124e80", "#001212")
- palette_weezer_pinkerton <- c("#d5bf98","#14140b","#70624b","#8a8d82","#304251","#465656","#945a2d","#708090")
- palette_weezer_green <- c("#bece30","#020100","#4f6238","#cac986","#981f2c","#c13f33","#461005")
- palette_weezer_maladroit <- c("#e0dcce","#575b61","#b69e44","#953d31","#e5b066","#343729","#3e3131")
- palette_weezer_make_believe <- c("#000000","#EAECEB","#C2C2C2","#A0A0A0","#313131")
- palette_weezer_red <- c("#ED1B34","#8A817C","#141311","#8B8D9C","#332E28")
- palette_weezer_raditude <- c("#EC2221","#FBFFFB","#FDF600","#CEB181","#4E1110")
- palette_weezer_everything <- c("#E8A662","#F4F5F1","#463D47","#7F3009","#35180E","F6F3CF")
- palette_weezer_white <- c("#FDFDFD","#242424","#E3E3E3","#B6B6B6","#EEEDED")
- palette_weezer_pacific_daydream <- c("#1E3555","#5C6455","#FBE4BC","#1D1F1E","#69797B","#F8E6CF","#F8E6CF")
- palette_weezer_teal <- c("#1DBBBE","#D6A8CD","#F8F8F8","#182633","#90C5DF")
- palette_weezer_black <- c("#2D2B2C","#060606","#E9E7E8","#0E0E0E")
- palette_weezer_ok_human <- c("#B2A17A","#B3B470","#B1A78F","#D1BE8F","#726D5C","#B8B6A6","#5B4F3F")
- palette_weezer_van_weezer <- c("#B2023E","#E933D3","#770265","#170032","#FDF8FF","#170032","#5329F9","#F3FED5")
-
- plaette_score_charts <- c(palette_weezer_blue[1],
- palette_weezer_red[1],
- palette_weezer_green[1],
- palette_weezer_teal[1],
-
- palette_weezer_pinkerton[1],
- palette_weezer_van_weezer[3]
- )
- }
}
+# # Compare power Tillburg vs success rate
+# {
+# df.chart <- generate_selected_repli_data()
+#
+# }
+
# Main 3 parter
{
- tar_load("repli_outcomes")
- df.chart <- repli_outcomes
- #df.chart <- df_repli_subsetted()
-
- # Merge in orig data
- tar_load("orig_dataset")
- df.chart.orig <- orig_dataset[c("unique_claim_id",
- "original_effect_size_value_reported",
- "original_effect_size_type_reference",
- "original_pearsons_r_numeric")]
- df.chart <- merge(df.chart,df.chart.orig,by.x="claim_id",by.y="unique_claim_id",all.x=TRUE,all.y=FALSE)
-
- df.chart$orig_pearsons_r <- as.numeric(df.chart$original_pearsons_r_numeric)
- df.chart$orig_effect_size_value <- as.numeric(df.chart$original_effect_size_value_reported)
-
- # Gather up new vs originals
- # Pearsons
- df.chart.pearsons <- df.chart[c("repli_pearsons_r_value","orig_pearsons_r")]
- df.chart.pearsons$stat_type <- "Pearson's R"
- colnames(df.chart.pearsons) <- c("Replication","Original","stat_type")
-
- # All others
- df.chart.others <- df.chart[c("repli_effect_size_value","orig_effect_size_value","repli_effect_size_type")]
- colnames(df.chart.others) <- c("Replication","Original","stat_type")
- types_to_keep <- c("ser_method")
- df.chart.others <- df.chart.others[df.chart.others$stat_type %in% types_to_keep,]
-
- # Combine
- df.chart <- rbind(df.chart.pearsons,df.chart.others)
- df.chart <- df.chart %>% pivot_longer(!"stat_type", names_to = "comparison", values_to = "ES_value")
- df.chart <- na.omit(df.chart)
- df.chart$stat_type <- factor(df.chart$stat_type,
- labels=c("Pearson's R","SER"),
- levels=c("Pearson's R","ser_method"))
- df.chart$comparison <- factor(df.chart$comparison,
- labels=c("Replication","Original"),
- levels=c("Replication","Original"))
- df.chart$jitter_bias <- ifelse(df.chart$comparison=="original",-.2,.2)
-
- ggplot(data=df.chart,aes(y=ES_value,x=stat_type,fill=reorder(comparison, desc(comparison)))) +
+ # Generate dataset
+ df.chart <- generate_selected_repli_data()
+
+ # TEMPORARY FOR MADE UP DATA
+ df.chart$rr_pearsons_r_value_reference <- df.chart$rr_pearsons_r_value*1.1
+
+ # Gather up new vs originals
+ # Pearsons
+ df.chart.pearsons <- df.chart[c("rr_pearsons_r_value","rr_effect_size_value_reference")]
+ df.chart.pearsons$stat_type <- "Pearson's R"
+ colnames(df.chart.pearsons) <- c("Replication","Original","stat_type")
+
+ # All others
+ df.chart.others <- df.chart[c("rr_statistic_value_reported","rr_effect_size_value_reference","rr_effect_size_type_reported")]
+ colnames(df.chart.others) <- c("Replication","Original","stat_type")
+ types_to_keep <- c("ser_method")
+ df.chart.others <- df.chart.others[df.chart.others$stat_type %in% types_to_keep,]
+
+ # Combine
+ df.chart <- rbind(df.chart.pearsons,df.chart.others)
+ df.chart <- df.chart %>% pivot_longer(!"stat_type", names_to = "comparison", values_to = "ES_value")
+ df.chart <- na.omit(df.chart)
+ df.chart$stat_type <- factor(df.chart$stat_type,
+ labels=c("Pearson's R","SER"),
+ levels=c("Pearson's R","ser_method"))
+ df.chart$comparison <- factor(df.chart$comparison,
+ labels=c("Replication","Original"),
+ levels=c("Replication","Original"))
+
+ ggplot(data=df.chart,aes(y=ES_value,x=stat_type,fill=comparison)) +
geom_split_violin()+
- geom_point(position=position_jitterdodge(),size=.2)+
- theme_bw()+
- scale_fill_manual(values=plaette_score_charts)+
- geom_hline(aes(yintercept =0),linetype=3,color="#454545")+
+ #geom_histogram(fill="#2B2484",alpha=.4)+
+ #geom_density(fill="#2B2484",alpha=.8)+
+ #scale_x_continuous(expand=c(0,0))+
+ #scale_y_continuous(expand=c(0,0))+
+ theme_minimal()+
theme(
legend.position = "bottom",
panel.grid = element_blank(),
- axis.line = element_line(color="#393939"),
- legend.title=element_blank()
+ axis.line = element_line(color="#393939")
)+
- scale_y_continuous(expand=c(0,0),limits=c(-0,1))+
xlab("Statistic type")+
ylab("Effect size value")
+ #scale_fill_viridis()+
+ #coord_flip()
}
-
-
-# Generate alluvial
-{
- # Data generation
-
- tar_load("repli_outcomes")
- tar_load("orig_dataset")
- tar_load("repro_export")
-
- df.alluvial <- orig_dataset[c("paper_id","claim_id")]
- df.alluvial$claim_id <- paste0(df.alluvial$paper_id,"_",df.alluvial$claim_id)
-
- repro.alluvial <- repro_export[c("paper_id","claim_id")]
- repro.alluvial$claim_id <- paste0(repro.alluvial$paper_id,"_",repro.alluvial$claim_id)
- repro.alluvial$paper_id <- NULL
- repro.alluvial$reproduction <- TRUE
- repro.alluvial$reproduction_outcome <- ifelse(repro_export$rr_repro_success_reported=="yes","Reproduced","Not reproduced")
-
- repli.alluvial <- repli_outcomes[c("claim_id")]
- repli.alluvial$replication <- TRUE
- repli.alluvial$replication_outcome <- ifelse(repli_outcomes$repli_pattern_criteria_met==TRUE,"Replicated","Not replicated")
-
- df.alluvial <- merge(df.alluvial,repro.alluvial,by = "claim_id",all.x=TRUE,all.y = FALSE)
- df.alluvial <- merge(df.alluvial,repli.alluvial,by = "claim_id",all.x=TRUE,all.y = FALSE)
-
-
- df.alluvial <- rbind(repro.alluvial,repli.alluvial)
-
- # df.repli.no.hier <- repli_outcomes[c("paper_id","claim_id","is_manylabs","power_for_effect_size")]
- # df.repli.no.hier$claim_id <- paste0(df.repli.no.hier$paper_id,"_", df.repli.no.hier$claim_id)
-
- #df.repli.no.hier <- df.repli.no.hier[df.repli.no.hier$paper_id %in% unique(df.repli.no.hier$paper_id)[60:120],]
-
- df.alluvial <- df.alluvial %>%
- ggsankey::make_long(paper_id,claim_id,type,outcome)
-
- ggplot(df.alluvial, aes(x = x, next_x = next_x, node = node, next_node = next_node, fill = factor(node), label = node)) +
- ggsankey::geom_alluvial(flow.alpha = 0.75, show.legend = FALSE,space=1) +
- #ggsankey::geom_sankey()+
- #geom_sankey_label(size = 3, color = "black", fill= "white", hjust = -0.5)+
- theme_bw() +
- theme(legend.position = "none") +
- theme(axis.title = element_blank()
- , axis.text.x = element_blank()
- , axis.ticks = element_blank()
- , panel.grid = element_blank()) +
- labs(fill = 'Nodes')+
- coord_flip()
-}
-
-library(ggplot2)
-
-ID <- c(1,1,2,2,3,3,4,4,5,5)
-group <- c(20,20, 50, 50,20, 20, 80, 80, 80, 80)
-condition <- c("med", "placebo","med", "placebo","med", "placebo","med", "placebo","med", "placebo")
-PropYes <- c(0.13, 0.15, 0.25, 0.13, 0.54, 0.34, 0.23, 0.45, 0.142, 0.344)
-exampleData <- data.frame(ID, group, condition, PropYes)
-exampleData <- within(exampleData, {
- group <- as.factor(group)
- condition <- as.factor(condition)
-})
-pd = position_dodge(width=0)
-ggplot(exampleData, aes(x=factor(condition), y=PropYes,
- color=factor(group), group=factor(ID))) +
- geom_point(position=pd) + geom_line(position=pd)
-ggplot(df.chart, aes(x=comparison, y=ES_value,
- group=factor(group))) +
- geom_point(position=pd) + geom_line(position=pd)
-ggplot(df.chart, aes(x=comparison, y=ES_value,
- group=factor(group))) +
- geom_point() + geom_line()
-
-
-
-# Startup and initialization
-{
- rm(list=ls()) # yes I know this is bad, will get rid of later; just a convenience for now
+# Play area
+if(FALSE){
+ # Main 3
+ {
+ df.hierarchy <- repli_export %>% group_by(paper_id,claim_id,rr_analytic_sample_stage,rr_is_manylabs, .drop = FALSE) %>% count()
+ dup_paper_ids <- df.hierarchy$paper_id[df.hierarchy$n==2]
+ repli_export_dups <- repli_export[repli_export$paper_id %in% dup_paper_ids,]
+
+ test <- repli_export %>% group_by(paper_id,claim_id,rr_is_manylabs, .drop = FALSE) %>% count()
+
+ }
- library(targets)
- library(ggplot2)
- library(ggalluvial)
- library(tidyr)
- library(dplyr)
- library(devtools)
- library(ggsankey)
- library(plotly)
- library(viridis)
-}
-
-tar_load("repli_outcomes")
-
-bootstrap.clust <- function(data=NA,FUN=NA,clustervar=NA,
- alpha=.05,tails="two-tailed",iters=100){
- # Set up cluster designations
- if(anyNA(clustervar)){ data$cluster.id <- 1:nrow(data)
- } else { data$cluster.id <- data[[clustervar]] }
- cluster.set <- unique(data$cluster.id)
- # Generate original target variable
- point.estimate <- FUN(data)
- # Create distribution of bootstrapped samples
- estimates.bootstrapped <- replicate(iters,{
- # Generate sample of clusters to include
- clust.list <- sample(cluster.set,length(cluster.set),replace = TRUE)
- # Build dataset from cluster list
- data.clust <- do.call(rbind,lapply(1:length(clust.list), function(x) {
- data[data$cluster.id == clust.list[x],]
- }))
- # Run function on new data
- tryCatch(FUN(data.clust),finally=NA)
- },
- simplify=TRUE)
- # Outcomes measures
- if(is.matrix(estimates.bootstrapped)){
- n_estimates <- nrow(estimates.bootstrapped)
- SE <- unlist(lapply(1:n_estimates,function(x) {sd(estimates.bootstrapped[x,],na.rm = TRUE)}))
- if (tails == "two-tailed"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], alpha/2,na.rm = TRUE)}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], 1-alpha/2,na.rm = TRUE)}))
- } else if (tails == "one-tailed, upper"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {NA}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], 1-alpha,na.rm = TRUE)}))
- } else if (tails == "one-tailed, lower"){
- CI.lb <- unlist(lapply(1:n_estimates,function(x) {quantile(estimates.bootstrapped[x,], alpha,na.rm = TRUE)}))
- CI.ub <- unlist(lapply(1:n_estimates,function(x) {NA}))
- }
- } else {
- SE <- sd(estimates.bootstrapped,na.rm = TRUE)
- if (tails == "two-tailed"){
- CI.lb <- quantile(estimates.bootstrapped, alpha/2,na.rm = TRUE)
- CI.ub <- quantile(estimates.bootstrapped, 1-alpha/2,na.rm = TRUE)
- } else if (tails == "one-tailed, upper"){
- CI.lb <- NA
- CI.ub <- quantile(estimates.bootstrapped, 1-alpha,na.rm = TRUE)
- } else if (tails == "one-tailed, lower"){
- CI.lb <- quantile(estimates.bootstrapped, alpha,na.rm = TRUE)
- CI.ub <- NA
- }
- }
+
+
+ # Generate alluvial
+ {
+ df.repli.no.hier <- repli_export[c("paper_id","claim_id","rr_is_manylabs","rr_analytic_sample_stage","rr_id")]
+ df.repli.no.hier$claim_id <- paste0(df.repli.no.hier$paper_id,"_", df.repli.no.hier$claim_id)
+
+ df.repli.no.hier <- df.repli.no.hier[df.repli.no.hier$paper_id %in% unique(df.repli.no.hier$paper_id)[60:120],]
+
+ df <- df.repli.no.hier %>%
+ #make_long(paper_id, claim_id,rr_is_manylabs,rr_analytic_sample_stage)
+ make_long(paper_id, claim_id,rr_is_manylabs,rr_analytic_sample_stage)
- # Outputs
- return(list("point.estimate"=point.estimate,"SE"=SE,
- "CI.lb"=CI.lb,"CI.ub"=CI.ub,"estimates.bootstrapped"=estimates.bootstrapped))
+
+ pl <- ggplot(df, aes(x = x, next_x = next_x, node = node, next_node = next_node, fill = factor(node), label = node)) +
+ geom_alluvial(flow.alpha = 0.75, show.legend = FALSE,space=1) +
+ #geom_sankey_label(size = 3, color = "black", fill= "white", hjust = -0.5)+
+ theme_bw() +
+ theme(legend.position = "none") +
+ theme(axis.title = element_blank()
+ , axis.text.y = element_blank()
+ , axis.ticks = element_blank()
+ , panel.grid = element_blank()) +
+ labs(fill = 'Nodes')
+ pl <- pl + scale_fill_viridis_d(option = "inferno")
+ # pl <- pl + labs(title = "Sankey diagram using ggplot")
+ # pl <- pl + labs(subtitle = "using David Sjoberg's ggsankey package")
+ pl
+ }
}
-test <- bootstrap.clust(data=repli_outcomes[c("paper_id","claim_id","repli_pattern_criteria_met")],FUN=function(data) {
- mean(data$repli_pattern_criteria_met,na.rm=TRUE)
-},clustervar = "paper_id")
-test$point.estimate
-
-test <- bootstrap.clust(data=repli_outcomes[c("paper_id","claim_id","repli_pattern_criteria_met")],FUN=function(data) {
- mean(data$repli_pattern_criteria_met,na.rm=TRUE)
-},clustervar = "paper_id")
-test$point.estimate
-
-test <- bootstrap.clust(data=repli_outcomes[c("paper_id","claim_id","repli_pattern_criteria_met","repli_type")],FUN=function(data) {
- reg <- lm("repli_pattern_criteria_met ~ repli_type",data=data)
- reg$coefficients
-},clustervar = "paper_id")
-test$point.estimate
-
-test <- lm("repli_pattern_criteria_met ~ repli_type",data=repli_outcomes)
-
-
-
-repli_outcomes$new_data <- repli_outcomes$repli_type=="new data"
-table(repli_outcomes$repli_pattern_criteria_met,repli_outcomes$new_data)
-
-rr <- (sum(repli_outcomes[repli_outcomes$repli_type=="new data",]$repli_pattern_criteria_met==TRUE)/sum(repli_outcomes$repli_type=="new data"))/
-(sum(repli_outcomes[repli_outcomes$repli_type=="secondary data",]$repli_pattern_criteria_met==TRUE)/sum(repli_outcomes$repli_type=="secondary data"))
-test$coefficients
diff --git a/_targets/meta/meta b/_targets/meta/meta
index 88dad3d..4bc3f00 100644
--- a/_targets/meta/meta
+++ b/_targets/meta/meta
@@ -15,9 +15,9 @@ create_repli_analytic|function|f732d32a5a166699|||||||||||||||
export_orig|function|1d13cf2cfd45903d|||||||||||||||
export_repli|function|48b6c3b2718590c9|||||||||||||||
export_repro|function|0a7486339a7e6bca|||||||||||||||
-finalized_claim4_file|stem|08b5c65587abf039|c8007a3e1323b441|ef46db3751d8e999|-750262725||t19674.8411045502s|b3654bf3682c79ca|86|rds|local|vector|||0||
-finalized_claim4_moddate|stem|b0555d1849304d18|2d0d81a000c050e0|6e76852deb7e5b69|1569643586||t19702.8638136269s|dff9495c51b724c1|77|rds|local|vector|||0.29||
-finalized_claim4_table|stem|7887fb5b44d07123|c7a936d0e47d0fc5|fe8ec385f98b9889|2060009599||t19674.841412857s|f1e3ad6a94194151|628374|rds|local|vector|||2.938||
+finalized_claim4_file|stem|08b5c65587abf039|c8007a3e1323b441|ef46db3751d8e999|-750262725||t19702.8678152924s|b3654bf3682c79ca|86|rds|local|vector|||0||
+finalized_claim4_moddate|stem|b0555d1849304d18|2d0d81a000c050e0|6e76852deb7e5b69|1569643586||t19703.7249384837s|dff9495c51b724c1|77|rds|local|vector|||0.252||
+finalized_claim4_table|stem|7887fb5b44d07123|c7a936d0e47d0fc5|fe8ec385f98b9889|2060009599||t19702.8680729932s|f1e3ad6a94194151|628374|rds|local|vector|||2.938||
generate_claim_ids|function|6819955c8beb1fd9|||||||||||||||
generate_paper_ids|function|c3135e17a538d9a3|||||||||||||||
generate_valid_rr_ids|function|414e92b343c9027c|||||||||||||||
@@ -52,55 +52,55 @@ make_tilburg_orig_input_file|function|00cdb908e3f20429|||||||||||||||
make_tilburg_rr_input|function|3afba25eb5c8dbfe|||||||||||||||
merge_orig_input|function|29ac54b0ebd75ebf|||||||||||||||
merge_repli_input|function|608aeac3c9e7b485|||||||||||||||
-orig_dataset|stem|47335296505e2c59|ad827e718f77f533|f4f6efacf8f73e8a|-1495429541||t19702.8602950011s|a15a070785ae591e|104870|rds|local|vector|||0.512||
+orig_dataset|stem|47335296505e2c59|ad827e718f77f533|f4f6efacf8f73e8a|-1495429541||t19703.6645305504s|a15a070785ae591e|104870|rds|local|vector|||0.501||
orig_dataset_data_entry|stem|5a6e41ba10440444|2410fba7b8239d24|85de6c3fa4e321bb|-1836909783||t19621.6653282251s|ce0976375cb0dc52|87089|rds|local|vector|||0.351||
-orig_input_changelog|stem|8c679afa47f754de|74fc36a4af7e34f5|c5c9be44dc57c7f5|854218549||t19702.8601508545s|869dc918109f7fa2|9532|rds|local|vector|||1.483||
-orig_input_changelog_file|stem|6c95cc454144b201|d5c895b1deacd6c4|ef46db3751d8e999|-2101306176||t19674.8411041958s|f0d5811415b6b792|97|rds|local|vector|||0||
-orig_input_changelog_moddate|stem|2072fcb57bf4d05d|5c5d157bcf9bfcbf|34d9fe7d925779fc|1041070366||t19702.8638163485s|dff9495c51b724c1|77|rds|local|vector|||0.226||
+orig_input_changelog|stem|8c679afa47f754de|74fc36a4af7e34f5|c5c9be44dc57c7f5|854218549||t19702.8681043313s|869dc918109f7fa2|9532|rds|local|vector|||1.483||
+orig_input_changelog_file|stem|6c95cc454144b201|d5c895b1deacd6c4|ef46db3751d8e999|-2101306176||t19702.8678153636s|f0d5811415b6b792|97|rds|local|vector|||0||
+orig_input_changelog_moddate|stem|2072fcb57bf4d05d|5c5d157bcf9bfcbf|34d9fe7d925779fc|1041070366||t19703.7249423386s|dff9495c51b724c1|77|rds|local|vector|||0.323||
orig_rr_file|stem|678d64c2dc2f6eef|f4dea69694f8ec0d|af4986d355838f9b|-391603615|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/orig_dataset.tsv|t19545.8751896821s|21552c36c78ea08a|346885|file|local|vector|||0.097||
-orig_statistics_dataset_p1|stem|8c7743089d4a7c11|aa939b0f558281aa|4dd7277b8c9e7570|1577914184||t19674.8415348554s|9274d6773c8e5ce3|93037|rds|local|vector|||0.834|One or more parsing issues, call problems on your data frame for details,e.g. dat vroom... problemsdat|
+orig_statistics_dataset_p1|stem|8c7743089d4a7c11|aa939b0f558281aa|4dd7277b8c9e7570|1577914184||t19702.8682002707s|9274d6773c8e5ce3|93037|rds|local|vector|||0.834|One or more parsing issues, call problems on your data frame for details,e.g. dat vroom... problemsdat|
orig_statistics_input|stem|dea84ce15745ea55|3854df6349665ec0|737711a03997e19c|766946636||t19599.7475975041s|31dbcdad4a9749ea|116370|rds|local|vector|||0.243||
orig_statistics_input_file|stem|6992fb119b69fe57|9e4ef12ebec638df|2f63b3e6aac469fd|-1553979786|/Users/theresawisneskie/Documents/SCORE/SCORE_papers/data/external_output/tilburg/orig_statistics_input.tsv|t19599.7475997756s|587083c3123a8856|400924|file|local|vector|||0.012||
orig_statistics_input_gsheet|stem|7137190230b3b9b4|d83b07f71154e7f2|ef46db3751d8e999|65061010||t19587.6728225445s|f0d5811415b6b792|97|rds|local|vector|||0.32||
orig_statistics_input_mod_date|stem|88ac7522b9d9beee|0c1c96b3fc42a6ad|4f89c0e0c8368fe1|773685720||t19600.5649332994s|dff9495c51b724c1|77|rds|local|vector|||0.844||
orig_statistics_input_tilburg|stem|cd9ae9a81649e348|bce9327c16d92420|64f8d6afc8dcaa5a|1121680062||t19599.7475279142s|d567f332af5e0242|120014|rds|local|vector|||2.623||
-orig_statistics_manual_data_entry|stem|10ce46ddb3b3165c|9614c9111222e219|db01eb91771a6e6b|654883457||t19674.8415533106s|b710176b916cf0e9|2771|rds|local|vector|||0.768||
-orig_statistics_manual_file|stem|b527092d6b502800|db94c9d617954695|ef46db3751d8e999|-589235286||t19674.8411042955s|b3654bf3682c79ca|86|rds|local|vector|||0||
-orig_statistics_manual_moddate|stem|b0555d1849304d18|bebcaff5ab1b3dbc|113def65aea2fd54|-1684405514||t19702.8638390827s|dff9495c51b724c1|77|rds|local|vector|||0.258||
-orig_statistics_output_p2|stem|87fb94191ee3e67f|10bfe5dbaffa65ce|8321a12ab0f9f451|-1548973816||t19702.8601714999s|e939cf0113bfa0a8|138980|rds|local|vector|||1.767|One or more parsing issues, call problems on your data frame for details,e.g. dat vroom... problemsdat|
-orig_statistics_output_p2_mod_date|stem|9b83b4640342a250|85a85002001b69b6|758e05c4b910614c|1470382855||t19702.8638266977s|4bab66ba4bee4440|108|rds|local|vector|||0.472||
-orig_statistics_output_p2_osf|stem|bd33e183684407c4|4b01986bfdde8c16|ef46db3751d8e999|679538478||t19674.8411040518s|00c37fc0166b3b11|58|rds|local|vector|||0||
-orig_statistics_p1_file|stem|0111f57ad3809efc|896ea845b6c6df46|ef46db3751d8e999|380404372||t19674.8411045262s|b3654bf3682c79ca|86|rds|local|vector|||0||
-orig_statistics_p1_moddate|stem|b0555d1849304d18|1c325091d93a0529|87ec9fb6a2c67a4f|1821613396||t19702.8638320753s|dff9495c51b724c1|77|rds|local|vector|||0.187||
+orig_statistics_manual_data_entry|stem|10ce46ddb3b3165c|9614c9111222e219|db01eb91771a6e6b|654883457||t19702.8682264213s|b710176b916cf0e9|2771|rds|local|vector|||0.768||
+orig_statistics_manual_file|stem|b527092d6b502800|db94c9d617954695|ef46db3751d8e999|-589235286||t19702.8678152597s|b3654bf3682c79ca|86|rds|local|vector|||0||
+orig_statistics_manual_moddate|stem|b0555d1849304d18|bebcaff5ab1b3dbc|113def65aea2fd54|-1684405514||t19703.7249649634s|dff9495c51b724c1|77|rds|local|vector|||0.374||
+orig_statistics_output_p2|stem|87fb94191ee3e67f|10bfe5dbaffa65ce|8321a12ab0f9f451|-1548973816||t19703.6644389848s|e939cf0113bfa0a8|138980|rds|local|vector|||2.459|One or more parsing issues, call problems on your data frame for details,e.g. dat vroom... problemsdat|
+orig_statistics_output_p2_mod_date|stem|9b83b4640342a250|85a85002001b69b6|758e05c4b910614c|1470382855||t19703.724952592s|4bab66ba4bee4440|108|rds|local|vector|||0.401||
+orig_statistics_output_p2_osf|stem|bd33e183684407c4|4b01986bfdde8c16|ef46db3751d8e999|679538478||t19702.8678150685s|00c37fc0166b3b11|58|rds|local|vector|||0||
+orig_statistics_p1_file|stem|0111f57ad3809efc|896ea845b6c6df46|ef46db3751d8e999|380404372||t19702.8678150309s|b3654bf3682c79ca|86|rds|local|vector|||0||
+orig_statistics_p1_moddate|stem|b0555d1849304d18|1c325091d93a0529|87ec9fb6a2c67a4f|1821613396||t19703.7249576324s|dff9495c51b724c1|77|rds|local|vector|||0.236||
orig_variables|stem|87cb5db81268fbb0|04c6598a17f17a11|630d84d321eb8fe9|1496817151||t19620.8650029206s|7a78efdfe3383505|85922|rds|local|vector|||0.032||
orig_variables_file|stem|a40476660b61e465|9def54d37c4f3211|4373217b14947adf|1841208288|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/orig_variables.tsv|t19551.7748601636s|b799a26b40d8451f|365996|file|local|vector|||2.737||
-orig_vars_qa|stem|3608e829fbdf9a44|8583be5db3efe63c|0b269295c93ac5ab|-1698991417||t19702.8639027995s|cfc04b7e8e1bd12c|53617|rds|local|vector|||1.501||
-orig_vars_qa_gsheet|stem|9833933f52b9d70b|96429736e75ccccc|ef46db3751d8e999|-274810929||t19674.8411043853s|f0d5811415b6b792|97|rds|local|vector|||0.145||
-orig_vars_qa_mod_date|stem|7a035aff16ec4130|77ba80a476ab3159|8d942c7d465f3cec|-1676201819||t19702.8638192125s|dff9495c51b724c1|77|rds|local|vector|||0.242||
-original_inftest_dataset|stem|11c78ff81eb2cb28|6811fb35a7232fd7|415212331de3c0d2|-2015862532||t19674.8415124264s|6048de4c723205e6|2642|rds|local|vector|||0.673||
-original_inftest_file|stem|5956ae5ed3ff5cc8|7400299f5c394d4d|ef46db3751d8e999|-939075500||t19674.8411043333s|b3654bf3682c79ca|86|rds|local|vector|||0||
-original_inftest_moddate|stem|b0555d1849304d18|5eb243e54b0d731a|20f83a60de29329f|-1440710265||t19702.863851319s|dff9495c51b724c1|77|rds|local|vector|||0.211||
+orig_vars_qa|stem|3608e829fbdf9a44|8583be5db3efe63c|0b269295c93ac5ab|-1698991417||t19703.7250289837s|cfc04b7e8e1bd12c|53617|rds|local|vector|||1.552||
+orig_vars_qa_gsheet|stem|9833933f52b9d70b|96429736e75ccccc|ef46db3751d8e999|-274810929||t19702.8678152425s|f0d5811415b6b792|97|rds|local|vector|||0.145||
+orig_vars_qa_mod_date|stem|7a035aff16ec4130|77ba80a476ab3159|8d942c7d465f3cec|-1676201819||t19703.724945511s|dff9495c51b724c1|77|rds|local|vector|||0.269||
+original_inftest_dataset|stem|11c78ff81eb2cb28|6811fb35a7232fd7|415212331de3c0d2|-2015862532||t19702.8682526636s|6048de4c723205e6|2642|rds|local|vector|||0.673||
+original_inftest_file|stem|5956ae5ed3ff5cc8|7400299f5c394d4d|ef46db3751d8e999|-939075500||t19702.8678153091s|b3654bf3682c79ca|86|rds|local|vector|||0||
+original_inftest_moddate|stem|b0555d1849304d18|5eb243e54b0d731a|20f83a60de29329f|-1440710265||t19703.7249799171s|dff9495c51b724c1|77|rds|local|vector|||0.257||
p2_id_key|stem|f050013e0f21a55f|ef5c6d9cc7630907|31d45ba360081ca3|-1288011618||t19549.6030189373s|5275404ce32c040e|14488|rds|local|vector|||0.038||
p2_id_key_file|stem|a727342764924ccb|9c4f1e6d75bbd0f1|4e3739ef91745af0|1754640234|/Users/theresawisneskie/Documents/SCORE/SCORE_papers/data/paper_level/p2_id_key.csv|t19397.8089282086s|09da6432e1f2331f|20631|file|local|vector|||0.001||
-p2_repli_vf|stem|f4a98a5ad960be2a|5b64ea07d9f13fbc|42f41c4f6711f485|1580136712||t19674.8413623456s|26d8fb4b526e39ee|3340|rds|local|vector|||0.701||
-p2_repli_vf_file|stem|9c78af257b304431|7865bbb416c1a2c1|ef46db3751d8e999|242621543||t19674.8411044652s|b3654bf3682c79ca|86|rds|local|vector|||0||
-p2_repli_vf_moddate|stem|b0555d1849304d18|13bd76f459bbdc1d|3db522f5b89a1824|714180891||t19702.8638534867s|dff9495c51b724c1|77|rds|local|vector|||0.184||
+p2_repli_vf|stem|f4a98a5ad960be2a|5b64ea07d9f13fbc|42f41c4f6711f485|1580136712||t19702.8681467821s|26d8fb4b526e39ee|3340|rds|local|vector|||0.701||
+p2_repli_vf_file|stem|9c78af257b304431|7865bbb416c1a2c1|ef46db3751d8e999|242621543||t19702.8678154382s|b3654bf3682c79ca|86|rds|local|vector|||0||
+p2_repli_vf_moddate|stem|b0555d1849304d18|13bd76f459bbdc1d|3db522f5b89a1824|714180891||t19703.7249821359s|dff9495c51b724c1|77|rds|local|vector|||0.188||
p2_repro_input_changelog|stem|5f96842df25069dc|dc2951b63aa83552|4f3adb6b99994ebe|1349257770||t19663.7600025376s|909c2ac50c1f63c3|1126|rds|local|vector|||1.067||
p2_repro_input_changelog_file|stem|8fea26f172c6060b|e2d3795cc5e0d824|ef46db3751d8e999|123532905||t19663.7598655165s|f0d5811415b6b792|97|rds|local|vector|||0||
p2_repro_input_changelog_moddate|stem|e2226f2bfbd6fb24|6e8c2ebf84883730|8068e54f63323784|286567377||t19663.7598822737s|dff9495c51b724c1|77|rds|local|vector|||0.222||
-p2_repro_vf|stem|1f8b8727d907f2b7|ce596b6126c589c0|ca2b29a27844c014|-2044233774||t19674.8412381791s|78116c1a4c40d04b|2851|rds|local|vector|||0.589||
-p2_repro_vf_file|stem|2241d6491312f4ab|76d85def17908ba4|ef46db3751d8e999|-2029585368||t19674.8411041262s|b3654bf3682c79ca|86|rds|local|vector|||0||
-p2_repro_vf_moddate|stem|b0555d1849304d18|0224388204cae393|3ec36c2f59ca3513|-1318523890||t19702.8638413815s|dff9495c51b724c1|77|rds|local|vector|||0.194||
+p2_repro_vf|stem|1f8b8727d907f2b7|ce596b6126c589c0|ca2b29a27844c014|-2044233774||t19702.8680466617s|78116c1a4c40d04b|2851|rds|local|vector|||0.589||
+p2_repro_vf_file|stem|2241d6491312f4ab|76d85def17908ba4|ef46db3751d8e999|-2029585368||t19702.8678152761s|b3654bf3682c79ca|86|rds|local|vector|||0||
+p2_repro_vf_moddate|stem|b0555d1849304d18|0224388204cae393|3ec36c2f59ca3513|-1318523890||t19703.7249671007s|dff9495c51b724c1|77|rds|local|vector|||0.178||
process_raw_repli_vf|function|07494fa87a336cd6|||||||||||||||
read_google_csv|function|f1f10b55fe1b6fce|||||||||||||||
read_google_sheet|function|361769e0aad78a52|||||||||||||||
read_google_tsv|function|9aaba7d64ca7b572|||||||||||||||
repli_data_entry|stem|045a599605c86522|d4a1700b68f5352a|cdb5322553ecb135|-652185030||t19613.8653115365s|b14719f63f85659d|156770|rds|local|vector|||0.336||
-repli_export|stem|7ee66a7897bb2aed|9fbca4d6e07e6622|49b8452fc5df95c6|-411665577||t19702.8602888228s|f2ffa8ee7b4412f4|157449|rds|local|vector|||0.431||
-repli_input_changelog|stem|450ed9f9e16bc8d9|71412182b6b1ffea|2b37228831bac6c1|-463572932||t19702.860183601s|6f314cf4eb190907|7616|rds|local|vector|||1.04||
-repli_input_changelog_file|stem|1e8ab1cffb921f88|b3e1585768b4f21d|ef46db3751d8e999|584491267||t19674.8411042728s|f0d5811415b6b792|97|rds|local|vector|||0||
-repli_input_changelog_moddate|stem|1b140f4467aaca9c|6e8c2ebf84883730|8068e54f63323784|89727246||t19702.8638360417s|dff9495c51b724c1|77|rds|local|vector|||0.339||
-repli_outcomes|stem|bc40df21dcdee7fc|1bf85971762cd74f|a831a81c45eea480|-1550709889||t19702.8602960349s|9e8a29bdb5decb1e|173099|rds|local|vector|||0.071|There was 1 warning in mutate.ℹ In argument acrossfactors, as.factor.Caused by warning Using an external vector in selections was deprecated in tidyselect 1.1.0.ℹ Please use all_of or any_of instead. Was data selectfactors Now data selectall_offactorsSee httpstidyselect.rlib.orgreferencefaqexternalvector.html.|
+repli_export|stem|7ee66a7897bb2aed|9fbca4d6e07e6622|49b8452fc5df95c6|-411665577||t19702.8682579172s|f2ffa8ee7b4412f4|157449|rds|local|vector|||0.431||
+repli_input_changelog|stem|450ed9f9e16bc8d9|71412182b6b1ffea|2b37228831bac6c1|-463572932||t19702.8681581595s|6f314cf4eb190907|7616|rds|local|vector|||1.04||
+repli_input_changelog_file|stem|1e8ab1cffb921f88|b3e1585768b4f21d|ef46db3751d8e999|584491267||t19702.8678154551s|f0d5811415b6b792|97|rds|local|vector|||0||
+repli_input_changelog_moddate|stem|1b140f4467aaca9c|6e8c2ebf84883730|8068e54f63323784|89727246||t19703.7249605953s|dff9495c51b724c1|77|rds|local|vector|||0.252||
+repli_outcomes|stem|bc40df21dcdee7fc|1bf85971762cd74f|a831a81c45eea480|-1550709889||t19703.6645316397s|9e8a29bdb5decb1e|173099|rds|local|vector|||0.071|There was 1 warning in mutate.ℹ In argument acrossfactors, as.factor.Caused by warning Using an external vector in selections was deprecated in tidyselect 1.1.0.ℹ Please use all_of or any_of instead. Was data selectfactors Now data selectall_offactorsSee httpstidyselect.rlib.orgreferencefaqexternalvector.html.|
repli_primary|stem|2d364186e7502b1e|3f020df85e65b2ec|a3b960e1af7fc1d0|349140557||t19702.8602963309s|146fa8b5346d6cff|126755|rds|local|vector|||0.007||
repli_primary_file|stem|27f26ed895dfdfbb|0be1a6481bb48939|6bae89149a82eff2|1073006109||t19613.8653137577s|4f74cbc508fbc9d3|133|rds|local|vector|||0.11||
repli_secondary|stem|b230d9e8dffc6348|326d8567b27aa5b7|c1b88dbccc966dd4|1647155869||t19702.8602964266s|b2d4c6672ece891f|36020|rds|local|vector|||0.002||
@@ -112,49 +112,49 @@ replication_outcome_status|stem|3f17c7d167cbdad5|d0af1b6dd3b38195|dbe7e2d9cf978b
replication_outcome_status_file|stem|4ae8db0fbc3cb371|ed435bbdef88871e|af4986d355838f9b|-996001090|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/status/replication_outcome_status.csv|t19565.8340691159s|6f42eea7edcb0597|33097|file|local|vector|||0||
replication_outcome_status_loaded|stem|9af68188b2efbe0a|7b5f9e7adb3ce755|2029d98c9e8743fa|-281567976||t19566.7956739303s|c2a4caffc75de547|6335|rds|local|vector|||0.028||
replication_outcome_status_updated|stem|4ae8db0fbc3cb371|34eb71601fdc53df|54594e3cfb7c397e|1434854150|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/status/replication_outcome_status.csv|t19565.8340691159s|6f42eea7edcb0597|33097|file|local|vector|||0.013||
-replication_qa|stem|a99659c9f5fa296e|28c1a9fc23b6c85c|1f4b01a3e2ead9dd|49819664||t19702.8639219297s|61544ba2d274cbb0|73464|rds|local|vector|||1.641|There was 1 warning in mutate.ℹ In argument acrossall_ofto_numeric, as.double.x.Caused by warning NAs introduced by coercion|
+replication_qa|stem|a99659c9f5fa296e|28c1a9fc23b6c85c|1f4b01a3e2ead9dd|49819664||t19703.7250452923s|61544ba2d274cbb0|73464|rds|local|vector|||1.397|There was 1 warning in mutate.ℹ In argument acrossall_ofto_numeric, as.double.x.Caused by warning NAs introduced by coercion|
replication_qa_file|stem|c40026a63e90a20e|851a6cd3ad4d93f5|af4986d355838f9b|-150818710|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/replication_qa.tsv|t19397.8089301099s|22f0c50a699232be|246670|file|local|vector|||0.119||
-replication_qa_gsheet|stem|633840fb2a41ae9c|1a11df88e1762750|ef46db3751d8e999|524784443||t19674.841104231s|f0d5811415b6b792|97|rds|local|vector|||0||
+replication_qa_gsheet|stem|633840fb2a41ae9c|1a11df88e1762750|ef46db3751d8e999|524784443||t19702.8678152223s|f0d5811415b6b792|97|rds|local|vector|||0||
replication_qa_mod_date|stem|8ba52a628cf43ade|db8c419168bf73d4|61c9798914b8e8ed|-1954816758||t19615.725470641s|dff9495c51b724c1|77|rds|local|vector|||0.254||
repro_export|stem|a9276c6a7d7517e4|5e784d525f5aa3e6|7497db6e4beb8c21|-1658640441||t19663.7602710954s|5b2b86edc3065c4a|40005|rds|local|vector|||0.05||
-reproduction_qa|stem|a4c34b2b14be4943|609ddb796673a9d2|79c9ac01cce43979|-535869334||t19702.8638850228s|e77346534ddee027|41642|rds|local|vector|||2.214||
-reproduction_qa_gsheet|stem|1d03d2ccd2651ba9|5748ed093b2e62cf|ef46db3751d8e999|214557842||t19674.8411045997s|f0d5811415b6b792|97|rds|local|vector|||0||
+reproduction_qa|stem|a4c34b2b14be4943|609ddb796673a9d2|79c9ac01cce43979|-535869334||t19703.7250105549s|e77346534ddee027|41642|rds|local|vector|||1.851||
+reproduction_qa_gsheet|stem|1d03d2ccd2651ba9|5748ed093b2e62cf|ef46db3751d8e999|214557842||t19702.8678154003s|f0d5811415b6b792|97|rds|local|vector|||0||
reproduction_qa_mod_date|stem|ad2075e84111420c|d50e4df223cf469b|7f7c41ca30426be2|1522312466||t19620.6911006419s|dff9495c51b724c1|77|rds|local|vector|||0.414||
rr_attempt_status|stem|8820fae1782ce96c|6fb43fdfa03a1a70|cabec542a36eeb4f|1289882620||t19566.7956734357s|93349a0b492866e4|10891|rds|local|vector|||0.04||
rr_attempt_status_file|stem|649256cb7de623f1|6a35068fb68aa51e|af4986d355838f9b|-2092996541|/Users/theresawisneskie/Documents/SCORE_Org/data/rr/status/rr_attempt_status.csv|t19397.808930134s|62be6b79cd38ef08|44153|file|local|vector|||0.117||
-rr_attempts_minted|stem|6052c42dd250c91f|1b041b138fc2b09c|bd5f0a009a63e524|-1347692668||t19674.8412819533s|a192a14775032a93|7205|rds|local|vector|||0.715||
-rr_attempts_minted_file|stem|ae893169619dd040|20ff57583a508b7e|ef46db3751d8e999|632770681||t19674.8411042538s|b3654bf3682c79ca|86|rds|local|vector|||0||
-rr_attempts_minted_moddate|stem|b0555d1849304d18|abd3e5d4cb15d99a|926ae77353facf3f|838030836||t19702.8638465519s|dff9495c51b724c1|77|rds|local|vector|||0.241||
+rr_attempts_minted|stem|6052c42dd250c91f|1b041b138fc2b09c|bd5f0a009a63e524|-1347692668||t19702.8680376154s|a192a14775032a93|7205|rds|local|vector|||0.715||
+rr_attempts_minted_file|stem|ae893169619dd040|20ff57583a508b7e|ef46db3751d8e999|632770681||t19702.8678151606s|b3654bf3682c79ca|86|rds|local|vector|||0||
+rr_attempts_minted_moddate|stem|b0555d1849304d18|abd3e5d4cb15d99a|926ae77353facf3f|838030836||t19703.724974576s|dff9495c51b724c1|77|rds|local|vector|||0.369||
rr_confrontations_prereg|stem|956a07fe9c4f2145|5c047e14a93604dc|60702827cde64e2b|811813380||t19549.8605829958s|04f9e3897bbc8fb6|37200|rds|local|vector|||0.193||
rr_confrontations_prereg_file|stem|1ef99afc25717548|ac7e11eca3c37395|4e3739ef91745af0|1827497287|/Users/theresawisneskie/Documents/SCORE/SCORE_papers/data/rr/checkins/rr_confrontations_prereg.tsv|t19397.8089300078s|7437010b12f39a65|318468|file|local|vector|||0.001||
-rr_outcomes_dataset_p1|stem|298094d73ae67f57|98d08a09dd6a20cf|6c9fd9ddf00583ce|557866776||t19674.8413533225s|3a50733422bc19b4|113515|rds|local|vector|||0.949||
-rr_outcomes_dataset_p1_file|stem|38df086024aa936a|cfef50e626d048ff|ef46db3751d8e999|-1191766433||t19674.8411044484s|b3654bf3682c79ca|86|rds|local|vector|||0||
-rr_outcomes_dataset_p1_moddate|stem|b0555d1849304d18|42b9e3cec183fe0a|f8eaa8640d3721c2|-876425914||t19702.8638212003s|dff9495c51b724c1|77|rds|local|vector|||0.169||
-rr_projects|stem|08efd4e8b942d3df|e344f00d3940480c|78b93ce5d61fa046|-396283616||t19674.841330091s|66ee3a5822251b40|26845|rds|local|vector|||0.66||
-rr_projects_file|stem|3a74654718032a90|f3db8bccd707087e|ef46db3751d8e999|1335176940||t19674.8411043511s|b3654bf3682c79ca|86|rds|local|vector|||0||
-rr_projects_moddate|stem|b0555d1849304d18|4c1dd47e3948704f|d633010439db5bab|-1816630940||t19702.8638558217s|dff9495c51b724c1|77|rds|local|vector|||0.198||
+rr_outcomes_dataset_p1|stem|298094d73ae67f57|98d08a09dd6a20cf|6c9fd9ddf00583ce|557866776||t19702.8681172571s|3a50733422bc19b4|113515|rds|local|vector|||0.949||
+rr_outcomes_dataset_p1_file|stem|38df086024aa936a|cfef50e626d048ff|ef46db3751d8e999|-1191766433||t19702.8678153825s|b3654bf3682c79ca|86|rds|local|vector|||0||
+rr_outcomes_dataset_p1_moddate|stem|b0555d1849304d18|42b9e3cec183fe0a|f8eaa8640d3721c2|-876425914||t19703.7249479064s|dff9495c51b724c1|77|rds|local|vector|||0.203||
+rr_projects|stem|08efd4e8b942d3df|e344f00d3940480c|78b93ce5d61fa046|-396283616||t19702.8679646674s|66ee3a5822251b40|26845|rds|local|vector|||0.66||
+rr_projects_file|stem|3a74654718032a90|f3db8bccd707087e|ef46db3751d8e999|1335176940||t19702.8678150093s|b3654bf3682c79ca|86|rds|local|vector|||0||
+rr_projects_moddate|stem|b0555d1849304d18|4c1dd47e3948704f|d633010439db5bab|-1816630940||t19703.7249853448s|dff9495c51b724c1|77|rds|local|vector|||0.271||
rr_replication_outcomes|stem|8b61662d258ccfa1|f8178c800321733e|36d154cafc394c3c|1497318871||t19613.820013797s|782e5d846da4d2fe|156473|rds|local|vector|||0.02||
rr_replication_outcomes_p2|stem|8b4e3a4182dd2a27|4ace702d8413a093|f426d4f3f5a82496|-166997433||t19570.612130227s|a7e32826ea933426|45940|rds|local|vector|||0.251||
-rr_reporting_checkin|stem|df01ade03192c3c0|c94c261b6a39c1a7|4c3d458525d7b560|-159602147||t19674.8412638012s|926e68571db54ad4|18709|rds|local|vector|||0.677||
-rr_reporting_checkin_file|stem|9302d8be5833a80b|1f62463992074b2d|ef46db3751d8e999|2052531205||t19674.8411041724s|b3654bf3682c79ca|86|rds|local|vector|||0||
-rr_reporting_checkin_moddate|stem|b0555d1849304d18|3a132ebf07988e7d|d331cc328694af1d|-1434497540||t19702.8638298607s|dff9495c51b724c1|77|rds|local|vector|||0.27||
+rr_reporting_checkin|stem|df01ade03192c3c0|c94c261b6a39c1a7|4c3d458525d7b560|-159602147||t19702.8680931084s|926e68571db54ad4|18709|rds|local|vector|||0.677||
+rr_reporting_checkin_file|stem|9302d8be5833a80b|1f62463992074b2d|ef46db3751d8e999|2052531205||t19702.8678153464s|b3654bf3682c79ca|86|rds|local|vector|||0||
+rr_reporting_checkin_moddate|stem|b0555d1849304d18|3a132ebf07988e7d|d331cc328694af1d|-1434497540||t19703.7249548274s|dff9495c51b724c1|77|rds|local|vector|||0.189||
rr_statistics_input|stem|594994dfab2f37f7|85a51a116e42ce93|8c995c871224d211|45443738||t19594.696986712s|507950a1be2a396c|114732|rds|local|vector|||0.033||
rr_statistics_input_file|stem|1d634af981dd0a9d|918726c04a40c095|c2a2f81ca75f68ec|1779321885|/Users/theresawisneskie/Documents/SCORE/SCORE_papers/data/external_output/tilburg/rr_statistics_input.tsv|t19599.7476001431s|6dff14638d321e26|398478|file|local|vector|||0.012||
rr_statistics_input_gsheet|stem|1e0e0e2783cbbe04|6da0996253f6fac2|ef46db3751d8e999|208541772||t19587.6728226838s|f0d5811415b6b792|97|rds|local|vector|||0.001||
rr_statistics_input_mod_date|stem|58ac199905efa30a|9be2e753041628a5|043132fe343a06fc|-1249039998||t19600.5649377877s|dff9495c51b724c1|77|rds|local|vector|||0.362||
rr_statistics_input_tilburg|stem|fcb99a1c30539da6|786a78570cca5463|649ce44edd675d9a|-2117780133||t19593.7156540616s|21ea163898f374d4|119790|rds|local|vector|||3.16||
-rr_statistics_output_p2|stem|6af69267c1a091a1|e27224de40a47a5a|1935511ad79f9a1b|1473213609||t19702.8602113278s|546b4b4fd9ecf17c|24903|rds|local|vector|||2.385||
-rr_statistics_output_p2_mod_date|stem|ba97c86785d7274b|c070acb820ed4655|abe1a46cbc2a4b27|1277869765||t19702.8638591671s|4bab66ba4bee4440|108|rds|local|vector|||0.285||
-rr_statistics_output_p2_osf|stem|94c0d5db24994642|449ef05e3f855762|ef46db3751d8e999|40585422||t19674.8411041515s|00c37fc0166b3b11|58|rds|local|vector|||0.001||
+rr_statistics_output_p2|stem|6af69267c1a091a1|e27224de40a47a5a|1935511ad79f9a1b|1473213609||t19702.8679912595s|546b4b4fd9ecf17c|24903|rds|local|vector|||2.385||
+rr_statistics_output_p2_mod_date|stem|ba97c86785d7274b|c070acb820ed4655|abe1a46cbc2a4b27|1277869765||t19703.7249888413s|4bab66ba4bee4440|108|rds|local|vector|||0.296||
+rr_statistics_output_p2_osf|stem|94c0d5db24994642|449ef05e3f855762|ef46db3751d8e999|40585422||t19702.8678150509s|00c37fc0166b3b11|58|rds|local|vector|||0.001||
split_hybrid|function|8f02ba5828ce9cbc|||||||||||||||
split_repli_primary|function|b629a6ecf07e04db|||||||||||||||
split_repli_secondary|function|55a6276e7eac4f60|||||||||||||||
-status|stem|71e2df9f2949c4da|abd371d4f20430b2|eeee80281583afc9|1711913059||t19674.8413212117s|3632b1294ff8dfa6|236562|rds|local|vector|||1.661||
-status_file|stem|2d618622345c260e|647d6bd585806ec0|ef46db3751d8e999|775164438||t19674.8411043149s|b3654bf3682c79ca|86|rds|local|vector|||0||
-status_moddate|stem|b0555d1849304d18|84258ab7a8b2d99a|40d6056ec6e3258d|-134802917||t19702.8638488254s|dff9495c51b724c1|77|rds|local|vector|||0.191||
-tagtable_covid_p1|stem|332308747dcfca2f|d5fcf72f75c295cf|0fa414c722d70db6|903968770||t19674.8413405926s|5811da14a37ffcfb|125200|rds|local|vector|||6.136||
-tagtable_covid_p1_file|stem|2c1def289ab881ed|6e25a7093500855c|ef46db3751d8e999|-640545787||t19674.8411044086s|b3654bf3682c79ca|86|rds|local|vector|||0||
-tagtable_covid_p1_moddate|stem|b0555d1849304d18|2dbde51d2426fc25|d45ae9696f95897d|-996389966||t19702.8638437178s|dff9495c51b724c1|77|rds|local|vector|||0.196||
+status|stem|71e2df9f2949c4da|abd371d4f20430b2|eeee80281583afc9|1711913059||t19702.8681363542s|3632b1294ff8dfa6|236562|rds|local|vector|||1.661||
+status_file|stem|2d618622345c260e|647d6bd585806ec0|ef46db3751d8e999|775164438||t19702.8678154189s|b3654bf3682c79ca|86|rds|local|vector|||0||
+status_moddate|stem|b0555d1849304d18|84258ab7a8b2d99a|40d6056ec6e3258d|-134802917||t19703.7249768644s|dff9495c51b724c1|77|rds|local|vector|||0.192||
+tagtable_covid_p1|stem|332308747dcfca2f|d5fcf72f75c295cf|0fa414c722d70db6|903968770||t19702.8680833918s|5811da14a37ffcfb|125200|rds|local|vector|||6.136||
+tagtable_covid_p1_file|stem|2c1def289ab881ed|6e25a7093500855c|ef46db3751d8e999|-640545787||t19702.867815328s|b3654bf3682c79ca|86|rds|local|vector|||0||
+tagtable_covid_p1_moddate|stem|b0555d1849304d18|2dbde51d2426fc25|d45ae9696f95897d|-996389966||t19703.7249702513s|dff9495c51b724c1|77|rds|local|vector|||0.265||
tagtable_p1|stem|2704f4c9702a3e31|434ed89b77f32783|4c6bde1b73e4009f|1857056087||t19549.7671955153s|1068772e20eda139|4402232|rds|local|vector|||0.296||
tagtable_p1_file|stem|49d1253dde9bd741|380d6a7857971970|4e3739ef91745af0|687716871|/Users/theresawisneskie/Documents/SCORE/SCORE_papers/data/claims/tagtable_p1.tsv|t19397.8089310373s|58ca8dff0689796d|12796579|file|local|vector|||0||
tagtable_p2_CES|stem|1ed69770db35c0bc|17cabf15e67ce621|ca553229fcba9988|-1337685309||t19549.7671979188s|b225d9cfb5ba95b4|741242|rds|local|vector|||0.086||
@@ -167,7 +167,7 @@ update_repli_attempts_staus|function|47ff8bc077efcc88|||||||||||||||
update_repli_input|function|9e1432cc077993ae|||||||||||||||
update_repli_outcomes_status|function|82b8035fc5144444|||||||||||||||
valid_claims|stem|b73ee64e82307484|31503845aedce777|4f929f0cb9dbd9cb|-1047532097||t19564.7532019596s|e9eb8fcdc42fa72c|33756|rds|local|vector|||0.055||
-valid_ids|stem|e629014676cc0960|e591787d848101f2|00399ce59d67e2d2|1609612332||t19674.8414581629s|a9924331cd05df7a|226502|rds|local|vector|||0.027||
+valid_ids|stem|e629014676cc0960|e591787d848101f2|00399ce59d67e2d2|1609612332||t19702.8681886651s|a9924331cd05df7a|226502|rds|local|vector|||0.027||
valid_rr|stem|e7aa0a23363cfd68|89c45c6a3ef04dd3|3fc432f4037172bf|-942215095||t19555.8581479813s|34fe586450e60e2a|9302|rds|local|vector|||0.013||
write_hybrid|function|9e8963076cde222f|||||||||||||||
write_repli_outcomes_status|function|a50b3907dbb546ad|||||||||||||||
diff --git a/renv/activate.R b/renv/activate.R
index 31d28bc..019b5a6 100644
--- a/renv/activate.R
+++ b/renv/activate.R
@@ -3,26 +3,10 @@ local({
# the requested version of renv
version <- "0.16.0"
- attr(version, "sha") <- NULL
# the project directory
project <- getwd()
- # use start-up diagnostics if enabled
- diagnostics <- Sys.getenv("RENV_STARTUP_DIAGNOSTICS", unset = "FALSE")
- if (diagnostics) {
- start <- Sys.time()
- profile <- tempfile("renv-startup-", fileext = ".Rprof")
- utils::Rprof(profile)
- on.exit({
- utils::Rprof(NULL)
- elapsed <- signif(difftime(Sys.time(), start, units = "auto"), digits = 2L)
- writeLines(sprintf("- renv took %s to run the autoloader.", format(elapsed)))
- writeLines(sprintf("- Profile: %s", profile))
- print(utils::summaryRprof(profile))
- }, add = TRUE)
- }
-
# figure out whether the autoloader is enabled
enabled <- local({
@@ -76,75 +60,21 @@ local({
# load bootstrap tools
`%||%` <- function(x, y) {
- if (is.null(x)) y else x
- }
-
- catf <- function(fmt, ..., appendLF = TRUE) {
-
- quiet <- getOption("renv.bootstrap.quiet", default = FALSE)
- if (quiet)
- return(invisible())
-
- msg <- sprintf(fmt, ...)
- cat(msg, file = stdout(), sep = if (appendLF) "\n" else "")
-
- invisible(msg)
-
- }
-
- header <- function(label,
- ...,
- prefix = "#",
- suffix = "-",
- n = min(getOption("width"), 78))
- {
- label <- sprintf(label, ...)
- n <- max(n - nchar(label) - nchar(prefix) - 2L, 8L)
- if (n <= 0)
- return(paste(prefix, label))
-
- tail <- paste(rep.int(suffix, n), collapse = "")
- paste0(prefix, " ", label, " ", tail)
-
- }
-
- startswith <- function(string, prefix) {
- substring(string, 1, nchar(prefix)) == prefix
+ if (is.environment(x) || length(x)) x else y
}
bootstrap <- function(version, library) {
- friendly <- renv_bootstrap_version_friendly(version)
- section <- header(sprintf("Bootstrapping renv %s", friendly))
- catf(section)
-
# attempt to download renv
- catf("- Downloading renv ... ", appendLF = FALSE)
- withCallingHandlers(
- tarball <- renv_bootstrap_download(version),
- error = function(err) {
- catf("FAILED")
- stop("failed to download:\n", conditionMessage(err))
- }
- )
- catf("OK")
- on.exit(unlink(tarball), add = TRUE)
+ tarball <- tryCatch(renv_bootstrap_download(version), error = identity)
+ if (inherits(tarball, "error"))
+ stop("failed to download renv ", version)
# now attempt to install
- catf("- Installing renv ... ", appendLF = FALSE)
- withCallingHandlers(
- status <- renv_bootstrap_install(version, tarball, library),
- error = function(err) {
- catf("FAILED")
- stop("failed to install:\n", conditionMessage(err))
- }
- )
- catf("OK")
-
- # add empty line to break up bootstrapping from normal output
- catf("")
+ status <- tryCatch(renv_bootstrap_install(version, tarball, library), error = identity)
+ if (inherits(status, "error"))
+ stop("failed to install renv ", version)
- return(invisible())
}
renv_bootstrap_tests_running <- function() {
@@ -153,32 +83,28 @@ local({
renv_bootstrap_repos <- function() {
- # get CRAN repository
- cran <- getOption("renv.repos.cran", "https://cloud.r-project.org")
-
# check for repos override
repos <- Sys.getenv("RENV_CONFIG_REPOS_OVERRIDE", unset = NA)
- if (!is.na(repos)) {
-
- # check for RSPM; if set, use a fallback repository for renv
- rspm <- Sys.getenv("RSPM", unset = NA)
- if (identical(rspm, repos))
- repos <- c(RSPM = rspm, CRAN = cran)
-
+ if (!is.na(repos))
return(repos)
- }
-
# check for lockfile repositories
repos <- tryCatch(renv_bootstrap_repos_lockfile(), error = identity)
if (!inherits(repos, "error") && length(repos))
return(repos)
+ # if we're testing, re-use the test repositories
+ if (renv_bootstrap_tests_running())
+ return(getOption("renv.tests.repos"))
+
# retrieve current repos
repos <- getOption("repos")
# ensure @CRAN@ entries are resolved
- repos[repos == "@CRAN@"] <- cran
+ repos[repos == "@CRAN@"] <- getOption(
+ "renv.repos.cran",
+ "https://cloud.r-project.org"
+ )
# add in renv.bootstrap.repos if set
default <- c(FALLBACK = "https://cloud.r-project.org")
@@ -217,34 +143,33 @@ local({
renv_bootstrap_download <- function(version) {
- sha <- attr(version, "sha", exact = TRUE)
-
- methods <- if (!is.null(sha)) {
-
- # attempting to bootstrap a development version of renv
- c(
- function() renv_bootstrap_download_tarball(sha),
- function() renv_bootstrap_download_github(sha)
+ # if the renv version number has 4 components, assume it must
+ # be retrieved via github
+ nv <- numeric_version(version)
+ components <- unclass(nv)[[1]]
+
+ # if this appears to be a development version of 'renv', we'll
+ # try to restore from github
+ dev <- length(components) == 4L
+
+ # begin collecting different methods for finding renv
+ methods <- c(
+ renv_bootstrap_download_tarball,
+ if (dev)
+ renv_bootstrap_download_github
+ else c(
+ renv_bootstrap_download_cran_latest,
+ renv_bootstrap_download_cran_archive
)
-
- } else {
-
- # attempting to bootstrap a release version of renv
- c(
- function() renv_bootstrap_download_tarball(version),
- function() renv_bootstrap_download_cran_latest(version),
- function() renv_bootstrap_download_cran_archive(version)
- )
-
- }
+ )
for (method in methods) {
- path <- tryCatch(method(), error = identity)
+ path <- tryCatch(method(version), error = identity)
if (is.character(path) && file.exists(path))
return(path)
}
- stop("All download methods failed")
+ stop("failed to download renv ", version)
}
@@ -308,6 +233,8 @@ local({
type <- spec$type
repos <- spec$repos
+ message("* Downloading renv ", version, " ... ", appendLF = FALSE)
+
baseurl <- utils::contrib.url(repos = repos, type = type)
ext <- if (identical(type, "source"))
".tar.gz"
@@ -324,10 +251,13 @@ local({
condition = identity
)
- if (inherits(status, "condition"))
+ if (inherits(status, "condition")) {
+ message("FAILED")
return(FALSE)
+ }
# report success and return
+ message("OK (downloaded ", type, ")")
destfile
}
@@ -384,6 +314,8 @@ local({
urls <- file.path(repos, "src/contrib/Archive/renv", name)
destfile <- file.path(tempdir(), name)
+ message("* Downloading renv ", version, " ... ", appendLF = FALSE)
+
for (url in urls) {
status <- tryCatch(
@@ -391,11 +323,14 @@ local({
condition = identity
)
- if (identical(status, 0L))
+ if (identical(status, 0L)) {
+ message("OK")
return(destfile)
+ }
}
+ message("FAILED")
return(FALSE)
}
@@ -409,7 +344,8 @@ local({
return()
# allow directories
- if (dir.exists(tarball)) {
+ info <- file.info(tarball, extra_cols = FALSE)
+ if (identical(info$isdir, TRUE)) {
name <- sprintf("renv_%s.tar.gz", version)
tarball <- file.path(tarball, name)
}
@@ -418,7 +354,7 @@ local({
if (!file.exists(tarball)) {
# let the user know we weren't able to honour their request
- fmt <- "- RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist."
+ fmt <- "* RENV_BOOTSTRAP_TARBALL is set (%s) but does not exist."
msg <- sprintf(fmt, tarball)
warning(msg)
@@ -427,7 +363,10 @@ local({
}
- catf("- Using local tarball '%s'.", tarball)
+ fmt <- "* Bootstrapping with tarball at path '%s'."
+ msg <- sprintf(fmt, tarball)
+ message(msg)
+
tarball
}
@@ -454,6 +393,8 @@ local({
on.exit(do.call(base::options, saved), add = TRUE)
}
+ message("* Downloading renv ", version, " from GitHub ... ", appendLF = FALSE)
+
url <- file.path("https://api.github.com/repos/rstudio/renv/tarball", version)
name <- sprintf("renv_%s.tar.gz", version)
destfile <- file.path(tempdir(), name)
@@ -463,105 +404,26 @@ local({
condition = identity
)
- if (!identical(status, 0L))
+ if (!identical(status, 0L)) {
+ message("FAILED")
return(FALSE)
-
- renv_bootstrap_download_augment(destfile)
-
- return(destfile)
-
- }
-
- # Add Sha to DESCRIPTION. This is stop gap until #890, after which we
- # can use renv::install() to fully capture metadata.
- renv_bootstrap_download_augment <- function(destfile) {
- sha <- renv_bootstrap_git_extract_sha1_tar(destfile)
- if (is.null(sha)) {
- return()
}
- # Untar
- tempdir <- tempfile("renv-github-")
- on.exit(unlink(tempdir, recursive = TRUE), add = TRUE)
- untar(destfile, exdir = tempdir)
- pkgdir <- dir(tempdir, full.names = TRUE)[[1]]
-
- # Modify description
- desc_path <- file.path(pkgdir, "DESCRIPTION")
- desc_lines <- readLines(desc_path)
- remotes_fields <- c(
- "RemoteType: github",
- "RemoteHost: api.github.com",
- "RemoteRepo: renv",
- "RemoteUsername: rstudio",
- "RemotePkgRef: rstudio/renv",
- paste("RemoteRef: ", sha),
- paste("RemoteSha: ", sha)
- )
- writeLines(c(desc_lines[desc_lines != ""], remotes_fields), con = desc_path)
-
- # Re-tar
- local({
- old <- setwd(tempdir)
- on.exit(setwd(old), add = TRUE)
-
- tar(destfile, compression = "gzip")
- })
- invisible()
- }
+ message("OK")
+ return(destfile)
- # Extract the commit hash from a git archive. Git archives include the SHA1
- # hash as the comment field of the tarball pax extended header
- # (see https://www.kernel.org/pub/software/scm/git/docs/git-archive.html)
- # For GitHub archives this should be the first header after the default one
- # (512 byte) header.
- renv_bootstrap_git_extract_sha1_tar <- function(bundle) {
-
- # open the bundle for reading
- # We use gzcon for everything because (from ?gzcon)
- # > Reading from a connection which does not supply a 'gzip' magic
- # > header is equivalent to reading from the original connection
- conn <- gzcon(file(bundle, open = "rb", raw = TRUE))
- on.exit(close(conn))
-
- # The default pax header is 512 bytes long and the first pax extended header
- # with the comment should be 51 bytes long
- # `52 comment=` (11 chars) + 40 byte SHA1 hash
- len <- 0x200 + 0x33
- res <- rawToChar(readBin(conn, "raw", n = len)[0x201:len])
-
- if (grepl("^52 comment=", res)) {
- sub("52 comment=", "", res)
- } else {
- NULL
- }
}
renv_bootstrap_install <- function(version, tarball, library) {
# attempt to install it into project library
+ message("* Installing renv ", version, " ... ", appendLF = FALSE)
dir.create(library, showWarnings = FALSE, recursive = TRUE)
- output <- renv_bootstrap_install_impl(library, tarball)
-
- # check for successful install
- status <- attr(output, "status")
- if (is.null(status) || identical(status, 0L))
- return(status)
-
- # an error occurred; report it
- header <- "installation of renv failed"
- lines <- paste(rep.int("=", nchar(header)), collapse = "")
- text <- paste(c(header, lines, output), collapse = "\n")
- stop(text)
-
- }
-
- renv_bootstrap_install_impl <- function(library, tarball) {
# invoke using system2 so we can capture and report output
bin <- R.home("bin")
exe <- if (Sys.info()[["sysname"]] == "Windows") "R.exe" else "R"
- R <- file.path(bin, exe)
+ r <- file.path(bin, exe)
args <- c(
"--vanilla", "CMD", "INSTALL", "--no-multiarch",
@@ -569,7 +431,19 @@ local({
shQuote(path.expand(tarball))
)
- system2(R, args, stdout = TRUE, stderr = TRUE)
+ output <- system2(r, args, stdout = TRUE, stderr = TRUE)
+ message("Done!")
+
+ # check for successful install
+ status <- attr(output, "status")
+ if (is.numeric(status) && !identical(status, 0L)) {
+ header <- "Error installing renv:"
+ lines <- paste(rep.int("=", nchar(header)), collapse = "")
+ text <- c(header, lines, output)
+ writeLines(text, con = stderr())
+ }
+
+ status
}
@@ -779,60 +653,32 @@ local({
}
- renv_bootstrap_validate_version <- function(version, description = NULL) {
-
- # resolve description file
- #
- # avoid passing lib.loc to `packageDescription()` below, since R will
- # use the loaded version of the package by default anyhow. note that
- # this function should only be called after 'renv' is loaded
- # https://github.com/rstudio/renv/issues/1625
- description <- description %||% packageDescription("renv")
+ renv_bootstrap_validate_version <- function(version) {
- # check whether requested version 'version' matches loaded version of renv
- sha <- attr(version, "sha", exact = TRUE)
- valid <- if (!is.null(sha))
- renv_bootstrap_validate_version_dev(sha, description)
- else
- renv_bootstrap_validate_version_release(version, description)
-
- if (valid)
+ loadedversion <- utils::packageDescription("renv", fields = "Version")
+ if (version == loadedversion)
return(TRUE)
- # the loaded version of renv doesn't match the requested version;
- # give the user instructions on how to proceed
- remote <- if (!is.null(description[["RemoteSha"]])) {
- paste("rstudio/renv", description[["RemoteSha"]], sep = "@")
- } else {
- paste("renv", description[["Version"]], sep = "@")
- }
-
- # display both loaded version + sha if available
- friendly <- renv_bootstrap_version_friendly(
- version = description[["Version"]],
- sha = description[["RemoteSha"]]
- )
+ # assume four-component versions are from GitHub; three-component
+ # versions are from CRAN
+ components <- strsplit(loadedversion, "[.-]")[[1]]
+ remote <- if (length(components) == 4L)
+ paste("rstudio/renv", loadedversion, sep = "@")
+ else
+ paste("renv", loadedversion, sep = "@")
fmt <- paste(
"renv %1$s was loaded from project library, but this project is configured to use renv %2$s.",
- "- Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.",
- "- Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.",
+ "Use `renv::record(\"%3$s\")` to record renv %1$s in the lockfile.",
+ "Use `renv::restore(packages = \"renv\")` to install renv %2$s into the project library.",
sep = "\n"
)
- catf(fmt, friendly, renv_bootstrap_version_friendly(version), remote)
- FALSE
+ msg <- sprintf(fmt, loadedversion, version, remote)
+ warning(msg, call. = FALSE)
- }
-
- renv_bootstrap_validate_version_dev <- function(version, description) {
- expected <- description[["RemoteSha"]]
- is.character(expected) && startswith(expected, version)
- }
+ FALSE
- renv_bootstrap_validate_version_release <- function(version, description) {
- expected <- description[["Version"]]
- is.character(expected) && identical(expected, version)
}
renv_bootstrap_hash_text <- function(text) {
@@ -854,12 +700,6 @@ local({
# warn if the version of renv loaded does not match
renv_bootstrap_validate_version(version)
- # execute renv load hooks, if any
- hooks <- getHook("renv::autoload")
- for (hook in hooks)
- if (is.function(hook))
- tryCatch(hook(), error = warnify)
-
# load the project
renv::load(project)
@@ -999,66 +839,14 @@ local({
}
- renv_bootstrap_version_friendly <- function(version, shafmt = NULL, sha = NULL) {
- sha <- sha %||% attr(version, "sha", exact = TRUE)
- parts <- c(version, sprintf(shafmt %||% " [sha: %s]", substring(sha, 1L, 7L)))
- paste(parts, collapse = "")
- }
-
- renv_bootstrap_exec <- function(project, libpath, version) {
- if (!renv_bootstrap_load(project, libpath, version))
- renv_bootstrap_run(version, libpath)
- }
-
- renv_bootstrap_run <- function(version, libpath) {
-
- # perform bootstrap
- bootstrap(version, libpath)
-
- # exit early if we're just testing bootstrap
- if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA)))
- return(TRUE)
-
- # try again to load
- if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
- return(renv::load(project = getwd()))
- }
-
- # failed to download or load renv; warn the user
- msg <- c(
- "Failed to find an renv installation: the project will not be loaded.",
- "Use `renv::activate()` to re-initialize the project."
- )
-
- warning(paste(msg, collapse = "\n"), call. = FALSE)
-
- }
renv_json_read <- function(file = NULL, text = NULL) {
- jlerr <- NULL
-
# if jsonlite is loaded, use that instead
- if ("jsonlite" %in% loadedNamespaces()) {
-
- json <- catch(renv_json_read_jsonlite(file, text))
- if (!inherits(json, "error"))
- return(json)
-
- jlerr <- json
-
- }
-
- # otherwise, fall back to the default JSON reader
- json <- catch(renv_json_read_default(file, text))
- if (!inherits(json, "error"))
- return(json)
-
- # report an error
- if (!is.null(jlerr))
- stop(jlerr)
+ if ("jsonlite" %in% loadedNamespaces())
+ renv_json_read_jsonlite(file, text)
else
- stop(json)
+ renv_json_read_default(file, text)
}
@@ -1172,9 +960,35 @@ local({
# construct full libpath
libpath <- file.path(root, prefix)
- # run bootstrap code
- renv_bootstrap_exec(project, libpath, version)
+ # attempt to load
+ if (renv_bootstrap_load(project, libpath, version))
+ return(TRUE)
+
+ # load failed; inform user we're about to bootstrap
+ prefix <- paste("# Bootstrapping renv", version)
+ postfix <- paste(rep.int("-", 77L - nchar(prefix)), collapse = "")
+ header <- paste(prefix, postfix)
+ message(header)
+
+ # perform bootstrap
+ bootstrap(version, libpath)
+
+ # exit early if we're just testing bootstrap
+ if (!is.na(Sys.getenv("RENV_BOOTSTRAP_INSTALL_ONLY", unset = NA)))
+ return(TRUE)
+
+ # try again to load
+ if (requireNamespace("renv", lib.loc = libpath, quietly = TRUE)) {
+ message("* Successfully installed and loaded renv ", version, ".")
+ return(renv::load())
+ }
+
+ # failed to download or load renv; warn the user
+ msg <- c(
+ "Failed to find an renv installation: the project will not be loaded.",
+ "Use `renv::activate()` to re-initialize the project."
+ )
- invisible()
+ warning(paste(msg, collapse = "\n"), call. = FALSE)
})
diff --git a/renv/settings.json b/renv/settings.json
deleted file mode 100644
index 2472d63..0000000
--- a/renv/settings.json
+++ /dev/null
@@ -1,19 +0,0 @@
-{
- "bioconductor.version": [],
- "external.libraries": [],
- "ignored.packages": [],
- "package.dependency.fields": [
- "Imports",
- "Depends",
- "LinkingTo"
- ],
- "ppm.enabled": null,
- "ppm.ignored.urls": [],
- "r.version": [],
- "snapshot.type": "implicit",
- "use.cache": true,
- "vcs.ignore.cellar": true,
- "vcs.ignore.library": true,
- "vcs.ignore.local": true,
- "vcs.manage.ignores": true
-}