├── .Rhistory ├── run.R ├── .Rproj.user └── 74FDFA94 │ ├── sdb │ └── prop │ │ ├── E8FE08F8 │ │ └── INDEX │ ├── saved_source_markers │ └── pcs │ ├── source-pane.pper │ ├── workbench-pane.pper │ ├── files-pane.pper │ └── windowlayoutstate.pper ├── p-hacker ├── www │ ├── preloader.gif │ ├── showstartmessage.js │ ├── busy.js │ ├── busy.css │ ├── loading.css │ └── accordion.css ├── .Rhistory ├── DESCRIPTION ├── Readme.md ├── snippets │ ├── tech_details.html │ ├── about.html │ └── quick_start.html ├── global.R ├── ui.R └── server.R ├── rmvnorm.R ├── LICENSE ├── P-Hacking.Rproj ├── test.R ├── reliability_test.R └── .Rapp.history /.Rhistory: -------------------------------------------------------------------------------- 1 | shiny::runApp('p-hacker') 2 | -------------------------------------------------------------------------------- /run.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | runApp("p-hacker") -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/sdb/prop/E8FE08F8: -------------------------------------------------------------------------------- 1 | { 2 | } -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/saved_source_markers: -------------------------------------------------------------------------------- 1 | {"active_set":"","sets":[]} -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/pcs/source-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "activeTab" : -1 3 | } -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/pcs/workbench-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "TabSet1" : 0, 3 | "TabSet2" : 0 4 | } -------------------------------------------------------------------------------- /p-hacker/www/preloader.gif: -------------------------------------------------------------------------------- https://raw.githubusercontent.com/nicebread/p-hacker/HEAD/p-hacker/www/preloader.gif -------------------------------------------------------------------------------- /p-hacker/www/showstartmessage.js: -------------------------------------------------------------------------------- 1 | $(document).ready( 2 | function(){ 3 | $('div.loading').show(); 4 | }); 5 | -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/sdb/prop/INDEX: -------------------------------------------------------------------------------- 1 | ~%2FDocuments%2FR%2FFunktionen%2FGitHub%2FshinyApps%2Fp-hacker%2Fp-hacker%2Fserver.R="E8FE08F8" 2 | -------------------------------------------------------------------------------- /p-hacker/.Rhistory: -------------------------------------------------------------------------------- 1 | shiny::runApp() 2 | shiny::runApp() 3 | shiny::runApp() 4 | shiny::runApp() 5 | shiny::runApp() 6 | shiny::runApp() 7 | shiny::runApp() 8 | -------------------------------------------------------------------------------- /rmvnorm.R: -------------------------------------------------------------------------------- 1 | library(mvtnorm) 2 | n <- 3 3 | p <- 0.5 4 | sigma <- matrix(p, nrow=n, ncol=n) 5 | diag(sigma) <- 1.0 6 | data <- rmvnorm(10000, sigma=sigma) 7 | cor(data) 8 | 9 | -------------------------------------------------------------------------------- /p-hacker/DESCRIPTION: -------------------------------------------------------------------------------- 1 | Title: p-hacker 2 | Author: Felix Schönbrodt & Tobias Kächele, with code from Uri Simonsohn & Moritz Heene 3 | AuthorUrl: http://www.nicebread.de 4 | License: GPL-3 5 | DisplayMode: Normal 6 | Type: Shiny 7 | -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/pcs/files-pane.pper: -------------------------------------------------------------------------------- 1 | { 2 | "path" : "~/Documents/R/Funktionen/GitHub/shinyApps/p-hacker/p-hacker", 3 | "sortOrder" : [ 4 | { 5 | "ascending" : true, 6 | "columnIndex" : 2 7 | } 8 | ] 9 | } -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | p-hacker app: A shiny app to train your p-hacking skills. 2 | Copyright (C) 2015 Felix Schönbrodt (felix@nicebread.de) and Tobias Kächele. 3 | 4 | The source code of this app is licensed under a CC-BY 4.0 license (https://creativecommons.org/licenses/by/4.0/). -------------------------------------------------------------------------------- /P-Hacking.Rproj: -------------------------------------------------------------------------------- 1 | Version: 1.0 2 | 3 | RestoreWorkspace: Default 4 | SaveWorkspace: Default 5 | AlwaysSaveHistory: Default 6 | 7 | EnableCodeIndexing: Yes 8 | UseSpacesForTab: Yes 9 | NumSpacesForTab: 2 10 | Encoding: UTF-8 11 | 12 | RnwWeave: Sweave 13 | LaTeX: pdfLaTeX 14 | -------------------------------------------------------------------------------- /p-hacker/www/busy.js: -------------------------------------------------------------------------------- 1 | setInterval(function() { 2 | if ($('html').attr('class')=='shiny-busy') { 3 | setTimeout(function() { 4 | if ($('html').attr('class')=='shiny-busy') { 5 | $('div.busy').show() 6 | } 7 | }, 1000) 8 | } else { 9 | $('div.busy').hide() 10 | } 11 | }, 100) 12 | -------------------------------------------------------------------------------- /p-hacker/www/busy.css: -------------------------------------------------------------------------------- 1 | div.busy { 2 | position:absolute; 3 | top: 40%; 4 | left: 50%; 5 | margin-top: -100px; 6 | margin-left: -50px; 7 | display:none; 8 | background: rgba(230, 230, 230, .8); 9 | text-align: center; 10 | padding-top: 20px; 11 | padding-left: 30px; 12 | padding-bottom: 40px; 13 | padding-right: 30px; 14 | border-radius: 5px; 15 | } -------------------------------------------------------------------------------- /p-hacker/www/loading.css: -------------------------------------------------------------------------------- 1 | div.loading { 2 | position:absolute; 3 | top: 40%; 4 | left: 50%; 5 | margin-top: -100px; 6 | margin-left: -50px; 7 | display:none; 8 | background: rgba(230, 230, 230, .8); 9 | text-align: center; 10 | padding-top: 20px; 11 | padding-left: 30px; 12 | padding-bottom: 40px; 13 | padding-right: 30px; 14 | border-radius: 5px; 15 | } 16 | -------------------------------------------------------------------------------- /.Rproj.user/74FDFA94/pcs/windowlayoutstate.pper: -------------------------------------------------------------------------------- 1 | { 2 | "left" : { 3 | "panelheight" : 717, 4 | "splitterpos" : 300, 5 | "topwindowstate" : "HIDE", 6 | "windowheight" : 755 7 | }, 8 | "right" : { 9 | "panelheight" : 717, 10 | "splitterpos" : 450, 11 | "topwindowstate" : "NORMAL", 12 | "windowheight" : 755 13 | } 14 | } -------------------------------------------------------------------------------- /p-hacker/www/accordion.css: -------------------------------------------------------------------------------- 1 | @import url('//netdna.bootstrapcdn.com/font-awesome/3.2.1/css/font-awesome.css'); 2 | 3 | /* CSS Method for adding Font Awesome Chevron Icons */ 4 | .accordion-toggle:after { 5 | /* symbol for "opening" panels */ 6 | font-family:'FontAwesome'; 7 | content:"\f077"; 8 | float: right; 9 | color: inherit; 10 | } 11 | .panel-heading.collapsed .accordion-toggle:after { 12 | /* symbol for "collapsed" panels */ 13 | content:"\f078"; 14 | } -------------------------------------------------------------------------------- /p-hacker/Readme.md: -------------------------------------------------------------------------------- 1 | ## R-Index, TIVA and p-curve 2 | 3 | This R code implements the **p-curve** (Simonsohn, Nelson, & Simmons, 2013; see http://www.p-curve.com), the **R-Index**, and the **Test of Insufficient Variance, TIVA** (Schimmack, 2014; see http://www.r-index.org/). 4 | 5 | Some code is from Uri Simonsohn (http://www.p-curve.com/Supplement/R/) and from Moritz Heene. 6 | 7 | WARNING: This app is *not thoroughly tested yet*! 8 | 9 | *Version 0.2* 10 | --- 11 | ### Known issues: 12 | 13 | - p-curve plot missing 14 | - pp33b function gives slightly different results than the original pp33 function 15 | - TODO: Separate inference functions from UI functions 16 | - *All* ES are used for calculations (the R-Index Excel sheet allows to differentiate between focal hypotheses etc.) 17 | - Extension of p-curve to other alpha-levels should be tested more 18 | - Implementation of p-uniform -------------------------------------------------------------------------------- /p-hacker/snippets/tech_details.html: -------------------------------------------------------------------------------- 1 | 2 |
3 |
4 |
5 |
6 |

Techical Details

7 |
8 |
9 |
10 | 11 | Several DVs are generated which correlate r = .2 to each other (assuming that they roughly tap into the same phenomenon). DV_all is the mean of all DVs. The DVs are drawn from a multivariate normal distribution with mean=0 and SD=1. A standardized mean difference is imposed between groups on each DV corresponding to slider value "True effect (Cohen's d)". A t-test for independent groups is performed on each DV. 12 | 13 |
14 |
15 |
16 |
17 |
-------------------------------------------------------------------------------- /p-hacker/snippets/about.html: -------------------------------------------------------------------------------- 1 | 2 | 3 |
4 |
5 |
6 |
7 |

About

8 |
9 |
10 |
11 | (c) 2016 by Felix Schönbrodt (www.nicebread.de). The source code of this app is licensed under the CC-BY 4.0 license and is published on Github. 12 | 13 |

Citation

14 | Programming this app took a considerable effort and amount of time. If you use it in your research or teaching, please consider citing the app: 15 |

16 | 17 | Schönbrodt, F. D. (2016). p-hacker: Train your p-hacking skills! Retrieved from http://shinyapps.org/apps/p-hacker/. 18 |

19 | 20 |
21 |
22 |
23 |
24 |
-------------------------------------------------------------------------------- /test.R: -------------------------------------------------------------------------------- 1 | library(plyr) 2 | library(ggplot2) 3 | library(Cairo) 4 | 5 | group_names <- c('exp','ctrl') 6 | true_effect <- 0 7 | 8 | # simulate study with N participants (not all are included in analysis) 9 | n <- 20 * 2 10 | 11 | # alternate group 12 | group <- factor(rep_len(group_names, n)) 13 | 14 | # randomize age 15 | age <- round(rgamma(n, 4, 0.5) + 18) 16 | 17 | # randomize gender 18 | gender <- factor(sample(0:1, n, replace=TRUE), labels=c("male", "female")) 19 | 20 | # create data frame 21 | allData <- data.frame( 22 | group = group, 23 | age = age, 24 | gender = gender, 25 | y = scale(rnorm(n, 0, 1)) 26 | ) 27 | 28 | # get indices of all rows belonging to group1 29 | indices <- which(allData$group == 'exp') 30 | 31 | # add true effect to all values of group1 32 | allData$y[indices] <- allData$y[indices] + true_effect 33 | 34 | dv <- 'y' 35 | 36 | means <- aggregate(allData[,dv], by=allData[c("group","gender")], FUN=mean) 37 | 38 | ggplot(allData, aes(x = group, y = y, colour = gender)) + 39 | geom_point(data = means, mapping=aes(y = dv), shape = 0, size=8) + 40 | geom_point(shape=16, size=3) + 41 | geom_line(data = means, mapping=aes(y = dv, group = gender)) + 42 | stat_boxplot(geom ='errorbar',geom_params = list(fill = "white", color = "steelblue"), stat_params = list(color="grey",width = 0.5)) + 43 | geom_boxplot(width=0.5, colour="grey", fill=NA) 44 | 45 | -------------------------------------------------------------------------------- /reliability_test.R: -------------------------------------------------------------------------------- 1 | library(ggplot2) 2 | library(Cairo) 3 | 4 | set.seed(1) 5 | 6 | num <- 20 #number of people to simulate 7 | 8 | rel <- .3 #the reliability of the observed extraversion score 9 | 10 | item_max <- 5 11 | item_min <- 0 12 | item_mean <- (item_max - item_min) / 2 #mean of true extraversion 13 | 14 | 15 | items <- 3 16 | 17 | #generate the data using the random normal distribution 18 | 19 | #first simulate true (latent) scores 20 | true_scores <- rnorm(num, item_mean) #true trait extraversion is normally distributed with sigma=1 21 | 22 | values <- true_e 23 | groups <- rep("true", length(values)) 24 | 25 | set.seed(NULL) 26 | 27 | sum_scores <- rep(0,num) 28 | 29 | # sum up scores 30 | for(g in 1:items) { 31 | # create scores for each item 32 | true_scores <- rnorm(num, item_mean) #true trait extraversion is normally distributed with sigma=1 33 | 34 | item_scores <- ( sqrt(rel) * (true_e - item_mean) ) + ( sqrt(1-rel) * rnorm(num) ) + mean_E 35 | # limit scores according to min and max value of item 36 | item_scores[item_scores < 0] <- 0 37 | item_scores[item_scores > 6] <- 6 38 | # sum up scores 39 | sum_scores <- sum_scores + ( sqrt(rel)*(true_e-mean_E) + sqrt(1-rel)*rnorm(num) + mean_E ) 40 | } 41 | 42 | # compute average of scores 43 | sum_scores <- sum_scores / items 44 | 45 | values <- c(values, sum_scores) 46 | groups <- c(groups, rep("with rel", num)) 47 | 48 | 49 | df <- data.frame( 50 | group = groups, 51 | val = values 52 | ) 53 | 54 | 55 | g <- ggplot(df, aes(x = group, y = val), ymin=0, ymax=6) + 56 | ylim(0,6) + 57 | geom_boxplot() 58 | print(g) -------------------------------------------------------------------------------- /p-hacker/global.R: -------------------------------------------------------------------------------- 1 | ## 2 | # 3 | # const 4 | # 5 | ## 6 | 7 | 8 | DV_PREFIX <- 'DV' # used to name DV 9 | DV_ALL <- 'DV_all' # name of average DV 10 | 11 | 12 | ## 13 | # 14 | # functions 15 | # 16 | ## 17 | 18 | 19 | readFile <- function(filename) { 20 | fileConnection <- file(filename, encoding="UTF-8") 21 | text <- readChar(fileConnection, file.info(filename)$size, useBytes = TRUE) 22 | Encoding(text) <- "UTF-8" 23 | close(fileConnection) 24 | text 25 | } 26 | 27 | # simple wrapper: formats a number in f.2 format 28 | f2 <- function(x, digits=2, prepoint=0, skipZero=FALSE) { 29 | if (skipZero == TRUE) {zero <- "."} else {zero <- "0."} 30 | 31 | if (length(dim(x)) == 2) { 32 | apply(x, 2, function(x2) {gsub("0.", zero, sprintf(paste("%",prepoint,".",digits,"f",sep=""), x2) , fixed=TRUE)}) 33 | } else { 34 | gsub("0.", zero, sprintf(paste("%",prepoint,".",digits,"f",sep=""), x) , fixed=TRUE) 35 | } 36 | } 37 | 38 | 39 | # nicely formats a p-value 40 | p.format <- function(x, digits=3) { 41 | if(is.na(x)) return("NA") 42 | if(x >= .1^digits) return(paste0("p = ", f2(x, digits, skipZero=TRUE))) 43 | return(paste0("p < ", f2(.1^digits, digits, skipZero=TRUE))) 44 | } 45 | 46 | 47 | # returns color for different p-value 48 | p.color <- function(p) { 49 | if(p <= .05) return("#5AEB31") 50 | if(p <= .10) return("#EBF2D6") 51 | if(p <= .20) return("#F4F4F4") 52 | return("none") 53 | } 54 | 55 | 56 | # returns significance of a p-value as sequence of stars 57 | p.stars <- function(p) { 58 | if(p <= .0001) return('****') 59 | if(p <= .001) return('***') 60 | if(p <= .01) return('**') 61 | if(p <= .05) return('*') 62 | return ('ns') 63 | } 64 | 65 | 66 | # returns a named vector containing various informations about ANOVA 67 | p.summary <- function(x) { 68 | sum <- summary(x)[[1]] 69 | p <- sum$Pr[1] 70 | return(c( 71 | f=paste0( "F(1, ", x$df.residual, ") = ", round(sum$F[1], 2) ), 72 | p=p.format(p), 73 | color=p.color(p), 74 | stars=p.stars(p) 75 | )) 76 | } 77 | 78 | 79 | ## 80 | # Get rows of dataframe which are selected by a boolean column of another dataframe 81 | # 82 | # df Dataframe which rows are selected 83 | # df2 Dataframe which contains a boolean column used as a selection mask 84 | # column Name of the column of df2 to be used as a selection mask 85 | # invert Optional. If set TRUE boolean column will be negated prior to selection. Default is FALSE. 86 | ## 87 | getSelectedRows <- function( df, df2, column, invert=FALSE ) { 88 | if ( invert ) { 89 | return( df[ which( !df2[,column] ), ] ) 90 | } 91 | return( df[ which( df2[,column] ), ] ) 92 | } 93 | 94 | 95 | ## 96 | # Get a number of rows from a dataframe 97 | # 98 | # df Dataframe 99 | # n Number of rows to grap 100 | ## 101 | getNRows <- function( df, n ) { 102 | return(df[1:n,]) 103 | } -------------------------------------------------------------------------------- /p-hacker/ui.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinythemes) 3 | library(shinyBS) # Additional Bootstrap Controls 4 | 5 | shinyUI(fluidPage(theme = shinytheme("spacelab"), 6 | tags$head(tags$link(rel="stylesheet", type="text/css", href="accordion.css")), 7 | 8 | title = "p-hacker: Train your p-hacking skills!", 9 | 10 | titlePanel("p-hacker: Train your p-hacking skills!"), 11 | 12 | div(class="row", 13 | HTML(readFile("snippets/quick_start.html")), 14 | HTML(readFile("snippets/tech_details.html")), 15 | HTML(readFile("snippets/about.html")) 16 | ), 17 | 18 | # --------------------------------------------------------------------- 19 | # The actual app ... 20 | 21 | fluidRow( 22 | column(width=4, 23 | tabsetPanel(id ="tabs1", 24 | tabPanel("New study", 25 | h3("Settings for initial data collection:"), 26 | textInput("label_group1", "Name for experimental group", "Elderly priming"), 27 | textInput("label_group2", "Name for control group", "Control priming"), 28 | sliderInput("n_per_group", "Initial # of participants in each group", min=2, max=100, value=20, step=1), 29 | sliderInput("true_effect", "True effect (Cohen's d)", min=0, max=1.5, value=0, step=0.05), 30 | sliderInput("dv_n", "Number of DVs", min=2, max=10, value=4, step=1), 31 | actionButton('generateNewData','Run new experiment'), 32 | p("(Discards previous data)"), 33 | br(),br(), 34 | HTML("
"), 35 | popify(textInput("seed", "Use seed (automatically incremented)", ''), "Hint", "Used to generate random values. Same seed leads to same values!", placement="top"), 36 | htmlOutput("seed_form"), 37 | htmlOutput("error_msg"), 38 | HTML("
") 39 | ), 40 | tabPanel("Now: p-hack!", class="disabled", 41 | h3("Basic tools to improve your p-value:"), 42 | checkboxInput("cov_age", "Control for age", FALSE), 43 | checkboxInput("cov_gender", "Control for gender", FALSE), 44 | checkboxInput("cov_gender_IA", "Interaction with gender", FALSE), 45 | div(class="btn-group-vertical", 46 | actionButton('add5','Add 5 new participants'), 47 | actionButton('add10','Add 10 new participants') 48 | ) 49 | ), 50 | tabPanel("Expert feature: Subgroup analysis", class="disabled", 51 | h3("Unlock the expert feature: Subgroup analysis!"), 52 | checkboxInput("subgroups", "Do an expert subgroup analysis", FALSE) 53 | ) 54 | ) 55 | ), 56 | 57 | 58 | # -------------------------------------------------------------------- 59 | # The output panels, on the right side 60 | 61 | column(width=5, 62 | conditionalPanel( 63 | condition = "input.tabs1 == 'New study' | input.tabs1 == 'Now: p-hack!'", 64 | htmlOutput("testoverview"), 65 | htmlOutput("plotoverview"), 66 | plotOutput("mainplot", 67 | click="mainplot_clicked" 68 | ), 69 | htmlOutput("plothints") 70 | ), 71 | conditionalPanel( 72 | condition = "input.tabs1 == 'Expert feature: Subgroup analysis'", 73 | HTML("

Subgroup analysis: Age groups by gender

"), 74 | conditionalPanel( 75 | condition = "input.subgroups == 1", 76 | htmlOutput("subgroupOutput") 77 | ) 78 | ) 79 | ), 80 | 81 | column(width=3, 82 | htmlOutput("studystack") 83 | ) 84 | ) 85 | )) 86 | -------------------------------------------------------------------------------- /p-hacker/snippets/quick_start.html: -------------------------------------------------------------------------------- 1 | 2 |
3 |
4 |
5 |
6 |

Manual

7 |
8 |
9 |
10 | 11 | [For another introduction, see this blog post]. 12 |

13 | 14 |

Step 1: The initial sample

15 | Go to the tab "New study" on the left. 16 | 17 |
    18 |
  • Decide how many participants you want to collect initially.
    19 | Pro-Tip: You increase your chances of finding a significant effect when you run many studies with few participants, instead of few studies with many participants (Bakker, van Dijk, & Wicherts, 2012)! 20 |
    • 21 | 22 |
  • Next, decide what the true effect size should be.
    23 | Pro-Tip: For a proper training in p-hacking, always select "0"! Then you can train to squeeze out an effect from nothing - isn`t that cool!? 24 |
    • 25 |
  • Next, decide how many potential dependent variables (DVs) you assess. (Technical detail: all DVs correlate to r=.2)
    26 | Pro-Tip: The more DVs you measure, the more you increase the chance of finding something! DV_all is an aggregate of all DVs. 27 |
    • 28 |
  • 29 | Finally, click on the button Run new experiment to collect your sample. 30 |
    • 31 |
32 |
33 | Now, take a look at the p-values in the middle pane. For your convenience, significant results are already marked in green, and result that are teetering on the brink of significance (i.e., promising results!) are yellow. 34 |
    35 |
  • 36 | Is it futile, such as p > .60? Meh. Consider to run another conceptual replication. Probably the manipulation did not work, or the DV was not so good. (What a luck that you didn`t run too many subjects on this shitty stimulus set!) 37 |
    • 38 |
  • 39 | But maybe the p-value is in a promising region, say p <.20? Great! That`s a near hit. Are you ready to go to Step 2? Now comes the fun part! 40 |
    • 41 |
42 | 43 | 44 |

Step 2: Polish your p-value

45 | Got to the tab "Now: p-hack!". This gives you all the great tools to improve your current study. Here you can fully utilize your data analytic skills and creativity. 46 | 47 | Things to try: 48 |
    49 |
  • Have you looked at all dependent variables (DVs)? And also their aggregate?
    • 50 |
  • Have you tried to control for age? Or for gender? Or for both?
    • 51 |
  • Maybe the effect is only present in one gender. You should try the interaction. (You will find a great post-hoc explanation, why this only works in men. I count on your creativity!)
    • 52 |
  • Push your result across the 5% boundary by adding 5 or 10 new subjects! (The 5% criterion is arbitrary anyway, isn`t it?)
    • 53 |
  • Remove outliers! Simply click on a data point in the plot to exclude (or re-include) it from your analysis. This is also very powerful when you look at the interaction with gender: Sometimes a point is an outlier only when you consider genders separately.
    • 54 |
55 | 56 | Nothing helped to get a significant result? Well, that happens to the best of us.
57 | Don`t become desperate, and don`t think too long about why that specific study failed.

58 | Now it is important to show even more productivity: Go for the next conceptual rpelication (i.e., go back to Step 1 and collect a new sample, with a new manipulation and a new DV).

59 | Pro-Tip: Never do direct replications (aka. "stupid method repetitions")! 60 |
    61 |
  • First, this is only for second-stringers without creative potential.
    • 62 |
  • Second, direct replications lock the "Now: p-hack" tab! Oh no! With direct replications, you are forced to use the same DV as before, and you cannot choose anymore from several DVs. If you controlled for age in the first study, you would have to control for age in the direct replication as well, etc. All this compulsive, anal-retentive stuff just limits your creative potential.
    • 63 |
  • Instead of conducting a direct replication (which, at n=20, wouldn`t take too long, right?), we rather suggest to write long rebuttals about the merits of conceptual replication. You can point to all of the successful conceptual replications you have collected in your study stack! (See Step 3.)
    • 64 |
65 | 66 |

Step 3: Harvest your accomplishments

67 | You found a significant effect? We congratulate you for your creativity and productivity. 68 |

69 | On the right panel, you can harvest your successes. Simply click on the Save button next to each DV and the current study is saved to your stack, awaiting some additional conceptual replications that show the robustness of the effect. 70 |

71 | But the challenge continues. Many journals require multiple studies - but that should be no problem for you. Go back to Step 1. Craft a new sample with a significant p-value, and when you have it, save it to your stack. 72 |

73 | Four to six studies should make a compelling case for your subtile, counterintuitive, and shocking effects. Honor to whom honor is due: Find the best outlet for your achievements! 74 | 75 | 76 |

Step 4: The nasty part

77 | Those were the good times where we could stop here. But some nasty researchers developed tools that are quite powerful in detecting p-hacking. If you click on the Send to p-checker button below your study stack on the right, the saved test statistics are transfered to the p-checker app. Let`s see whether we can detect p-hacking! 78 | 79 |

References

80 | Bakker, M., van Dijk, A., & Wicherts, J. M. (2012). The rules of the game called psychological science. Perspectives on Psychological Science, 7, 543–554. doi:10.1177/1745691612459060 81 |
82 |
83 |
84 |
85 |
-------------------------------------------------------------------------------- /p-hacker/server.R: -------------------------------------------------------------------------------- 1 | library(shiny) 2 | library(shinyBS) # Additional Bootstrap Controls 3 | library(ggplot2) 4 | library(mvtnorm) # used for generating multivariate distributed random numbers 5 | 6 | #source("helpers.R") 7 | 8 | shinyServer(function(input, output, session) { 9 | 10 | 11 | dat <- reactiveValues( 12 | selected = data.frame(), 13 | allData = data.frame(), 14 | n = 0, 15 | n_studies = 0, # number of studies in stack 16 | studystack="", 17 | save_dv_observers = list(), # list of observer objects dynamically produced when displaying table 18 | counter = 0, 19 | chosen = '', 20 | DV_selector_sg.chosen = DV_ALL, 21 | control_for_gender = FALSE, 22 | control_for_interaction = FALSE, 23 | next_seed = sample(1:5000,1,replace=TRUE), 24 | current_seed = NULL, 25 | dv_names = c(), 26 | dv_names_all = c(), 27 | TEST = NULL, 28 | blub = 0, 29 | flag_auto_selected = FALSE, 30 | flag_point_already_excluded = FALSE 31 | ) 32 | 33 | 34 | 35 | ################################### 36 | # 37 | # observe & reactive expressions 38 | # 39 | ################################### 40 | 41 | 42 | # observe changes in next_seed and update textInput accordingly 43 | observe({ 44 | if(is.null(dat$next_seed)) return() 45 | 46 | isolate({ 47 | updateTextInput(session, "seed", NULL, dat$next_seed) 48 | }) 49 | }) 50 | 51 | 52 | 53 | 54 | # observe number of participants 55 | # change dataframe selected accordingly 56 | observe({ 57 | if(is.null(dat$current_seed) || is.null(dat$n) || dat$n <= 0) return(); 58 | 59 | isolate({ 60 | # length of vector included 61 | n <- nrow(dat$selected) 62 | 63 | if ( dat$n < n ) { 64 | # limit df to size n 65 | dat$selected <- getNRows(dat$selected, dat$n) 66 | } else if ( dat$n > n) { 67 | # extend df to size n 68 | dat$selected[(n + 1):dat$n, ] <- T 69 | } 70 | 71 | }) 72 | }) 73 | 74 | 75 | # computes tests and selects DV with lowest p value 76 | # observed values: dat$currentData, dat$n, dat$included, input$cov_age, input$cov_gender, input$cov_gender_IA 77 | observe({ 78 | 79 | if (nrow(dat$selected)==0) return(); 80 | 81 | 82 | 83 | # make a copy of all the data which will be used when creating the plots 84 | 85 | 86 | control <- "" 87 | if (input$cov_age) control <- paste0(control, " + age") 88 | if (dat$control_for_gender) control <- paste0(control, " + gender") 89 | if (dat$control_for_interaction) control <- paste0(control, " + gender*group") 90 | 91 | isolate({ 92 | 93 | dat$TEST <- list() # keeps the aov objects for each DV 94 | dat$P <- list() # stores p values for each DV 95 | for ( DV in dat$dv_names_all) { 96 | # create formula for anova 97 | f <- formula(paste0(DV, " ~ group", control)) 98 | 99 | # separete included from excluded data and save them for later usage 100 | includedData <- getSelectedRows(dat$allData, dat$selected, DV) 101 | 102 | #Print(paste0("Compute anova for ", DV)) 103 | 104 | # compute anova and other tests 105 | dat$TEST[[DV]] <- aov(f, includedData) 106 | dat$TEST[[DV]]$DV <- DV 107 | dat$P[[DV]] <- summary(dat$TEST[[DV]])[[1]]$Pr[1] 108 | } 109 | 110 | 111 | # automatically select the DV with the lowest p value 112 | if(dat$counter == 0) { 113 | dat$chosen <- names(which.min(dat$P)) 114 | dat$flag_auto_selected <- T 115 | } 116 | 117 | # increment counter 118 | dat$counter <- dat$counter + 1 119 | 120 | }) 121 | }) 122 | 123 | 124 | ################################### 125 | # 126 | # event handlers 127 | # 128 | ################################### 129 | 130 | 131 | # add 5 participants pressed 132 | observeEvent(input$add5, { 133 | dat$n <- dat$n + ( 5 * 2 ) 134 | }) 135 | 136 | # add 10 participants pressed 137 | observeEvent(input$add10, { 138 | dat$n <- dat$n + ( 10 * 2 ) 139 | }) 140 | 141 | 142 | # dvs chosen 143 | observeEvent(input$DV_selector, { 144 | dat$chosen <- input$DV_selector 145 | }) 146 | 147 | observeEvent(input$DV_selector_sg, { 148 | dat$chosen.sg <- input$DV_selector_sg 149 | }) 150 | 151 | # clear stack pressed 152 | observeEvent(input$clear_stack, { 153 | dat$n_studies <- 0 154 | dat$studystack <- "" 155 | }) 156 | 157 | # control for interaction of gender checkbox changed 158 | observeEvent(input$cov_gender_IA, { 159 | # TODO: If the "Interaction with gender" box is clicked, the "control for gender" box should be checked too 160 | if (input$cov_gender_IA) { 161 | dat$control_for_interaction = T 162 | if(!dat$control_for_gender) { 163 | dat$control_for_gender = T 164 | updateCheckboxInput(session, "cov_gender", value=TRUE) 165 | 166 | } 167 | } else { 168 | dat$control_for_interaction = F 169 | } 170 | }) 171 | 172 | # control for gender checkbox changed 173 | observeEvent(input$cov_gender, { 174 | # TODO: If the "Interaction with gender" box is clicked, the "control for gender" box should be checked too 175 | if (input$cov_gender) { 176 | dat$control_for_gender = T 177 | } else { 178 | dat$control_for_gender = F 179 | if(dat$control_for_interaction) { 180 | dat$control_for_interaction = F 181 | updateCheckboxInput(session, "cov_gender_IA", value=FALSE) 182 | } 183 | } 184 | }) 185 | 186 | # generate new data pressed 187 | observeEvent(input$generateNewData, { 188 | 189 | # validate seed input prior using seed 190 | seed <- suppressWarnings(as.numeric(input$seed)) 191 | if(is.na(seed) || input$seed <= 0) { 192 | # set error msg 193 | dat$last_error_msg <- 'Seed is not a positive number!' 194 | return() 195 | } else { 196 | # remove error msg 197 | dat$last_error_msg <- NULL 198 | } 199 | 200 | # floor seed when accidentally using floating numbers 201 | seed <- floor(seed) 202 | 203 | # set current and next seed and use it for creating random numbers 204 | #Print(seed) 205 | dat$current_seed <- seed 206 | dat$next_seed <- seed + 1 207 | set.seed(seed) 208 | 209 | # set number of dvs and create labels accordingly 210 | dat$dv_names <- paste0( DV_PREFIX, 1:input$dv_n ) 211 | dat$dv_names_all <- c(dat$dv_names, DV_ALL) 212 | 213 | # reset the settings from the p-hacking tab 214 | updateCheckboxInput(session, "cov_age", value=FALSE) 215 | updateCheckboxInput(session, "cov_gender", value=FALSE) 216 | updateCheckboxInput(session, "cov_gender_IA", value=FALSE) 217 | 218 | # simulate study with N participants (not all are included in analysis) 219 | n <- 10000 * 2 220 | 221 | # set number of participants 222 | dat$n <- input$n_per_group * 2 223 | 224 | 225 | 226 | # Create matrix of multinomially distributed random numbers 227 | # and convert it to data.frame. Each column represents a dv, 228 | # each row represents a subject. 229 | dv.cor <- 0.2 230 | sigma <- matrix(dv.cor, nrow=input$dv_n, ncol=input$dv_n) 231 | diag(sigma) <- 1.0 232 | dat$allData <- as.data.frame(rmvnorm(n, sigma=sigma)) 233 | 234 | # change column names to dv names 235 | colnames(dat$allData) <- dat$dv_names 236 | 237 | # add column with alternating group 238 | dat$allData$group <- factor(rep_len(c(input$label_group1, input$label_group2), n)) 239 | 240 | # add column with randomized ages 241 | dat$allData$age <- round(rgamma(n, 5, 0.5) + 18) 242 | 243 | # add column with randomized genders 244 | dat$allData$gender <- factor(sample(0:1, n, replace=TRUE), labels=c("male", "female")) 245 | 246 | # create randomized data for other DVs and add fixed effect to all DV values of group1 247 | for(DV in dat$dv_names) { 248 | # get indices of all rows belonging to group1 249 | indices <- which(dat$allData$group == input$label_group1) 250 | 251 | # add true effect to all values of group1 252 | dat$allData[indices, DV] <- dat$allData[indices, DV] + input$true_effect 253 | } 254 | 255 | # calculate mean of all DVs 256 | dat$allData[DV_ALL] <- rowMeans(dat$allData[, dat$dv_names]) 257 | 258 | # reset selection 259 | dat$selected <- matrix(T, nrow=dat$n, ncol = length(dat$dv_names_all)) 260 | colnames(dat$selected) <- dat$dv_names_all 261 | dat$selected <- as.data.frame(dat$selected) 262 | 263 | # reset counter 264 | dat$counter <- 0 265 | 266 | # reset chosen dv 267 | dat$chosen <- NULL 268 | 269 | # reset controlling variables 270 | dat$control_for_gender = F 271 | dat$control_for_interaction = F 272 | 273 | # reset list of tests 274 | dat$TEST <- NULL 275 | 276 | }) 277 | 278 | 279 | # main plot clicked 280 | observeEvent(input$mainplot_clicked, { 281 | 282 | if(is.null(dat$chosen) || nrow(dat$selected) == 0) return() 283 | 284 | # create new boolean column which indicates whether corresponding point was clicked 285 | selectedRows <- nearPoints(dat$allData[1:dat$n,], input$mainplot_clicked, allRows = TRUE) 286 | 287 | # point clicked? 288 | if(T %in% selectedRows$selected_) { 289 | # toggle selected rows 290 | dat$selected[,dat$chosen] <- xor(dat$selected[,dat$chosen], selectedRows$selected_) 291 | 292 | # remove flag 293 | dat$flag_point_already_excluded <- T 294 | } 295 | 296 | }) 297 | 298 | 299 | ################################### 300 | # 301 | # render output 302 | # 303 | ################################### 304 | 305 | 306 | # render table with test results 307 | output$testoverview <- renderUI({ 308 | 309 | if (is.null(dat$TEST)) { 310 | return(list(HTML("

No study run yet - click on 'Run new experiment' at the bottom of the left panel!

"))) 311 | } 312 | 313 | 314 | # create table tag 315 | table.tag <- tags$table(class="table", 316 | tags$tr( 317 | tags$th("Name"), 318 | tags$th("N"), 319 | tags$th("Statistic"), 320 | tags$th("p-Value"), 321 | tags$th("Sign."), 322 | tags$th("Actions") 323 | ) 324 | ) 325 | 326 | isolate({ 327 | sty <- "vertical-align:middle;" 328 | 329 | for( DV in dat$dv_names_all ) { 330 | #Print(paste0("Show stats for ", DV)) 331 | 332 | sum <- p.summary(dat$TEST[[DV]]) 333 | 334 | id <- paste0("save_",DV) 335 | 336 | table.tag <- tagAppendChild( table.tag, 337 | tags$tr(style=paste0("background-color:",sum['color'],";"), 338 | tags$td(style=sty, DV) , 339 | tags$td(style=sty, sum(dat$selected[[DV]])), 340 | tags$td(style=sty, sum['f']), 341 | tags$td(style=sty, sum['p']), 342 | tags$td(style=sty, sum['stars']), 343 | tags$td(style=sty, actionButton(id, "Save", class="btn-xs")) 344 | 345 | ) 346 | ) 347 | 348 | 349 | 350 | if( is.null( dat$save_dv_observers[[id]] ) ) { 351 | 352 | dat$save_dv_observers[[id]] <- observe(substitute({ 353 | value <- input[[id]] 354 | 355 | isolate({ 356 | 357 | 358 | if(!is.null(value) && value != 0) { 359 | dat$n_studies <- dat$n_studies + 1 360 | dat$studystack <- paste0( 361 | dat$studystack, 362 | "hack-o-mat (", format(Sys.time(), "%Y"), ") S", dat$n_studies, ": ", 363 | "F(1, ", dat$TEST[[dv]]$df.residual, ") = ", round(summary(dat$TEST[[dv]])[[1]]$F[1], 2), "; p = ", round(summary(dat$TEST[[dv]])[[1]]$Pr[1], 3), "\n" 364 | ) 365 | } 366 | }) 367 | 368 | 369 | }, list(id=id,dv=DV)), quoted=TRUE) 370 | } 371 | 372 | 373 | 374 | } 375 | }) 376 | 377 | 378 | return(list( 379 | h3("Tests for each DV"), 380 | table.tag 381 | )) 382 | }) 383 | 384 | 385 | 386 | 387 | # --------------------------------------------------------------------- 388 | # render plot overview 389 | 390 | output$plotoverview <- renderUI({ 391 | if(is.null(dat$chosen) || dat$counter < 1) { 392 | return() 393 | } 394 | 395 | isolate({ 396 | #Print(paste0("Plotoverview | dat$chosen = ", dat$chosen, " dat$counter = ", dat$counter, " flag = ", dat$flag_auto_selected)) 397 | 398 | label.tag <- NULL 399 | 400 | if(dat$flag_auto_selected) { 401 | label.tag <- tags$span(class="label label-info", id="selector_label", "Best DV is selected by default") 402 | 403 | # reset auto flag to avoid printing it next time user changes inputs 404 | dat$flag_auto_selected <- F 405 | } 406 | 407 | 408 | 409 | return( 410 | list( 411 | selectInput("DV_selector", label="Choose DV to plot", dat$dv_names_all, dat$chosen), 412 | label.tag 413 | ) 414 | ) 415 | }) 416 | 417 | 418 | }) 419 | 420 | 421 | # --------------------------------------------------------------------- 422 | # render main plot 423 | 424 | output$mainplot <- renderPlot({ 425 | 426 | # react on changes in dat$TEST[[1]], dat$currentData, dat$chosen 427 | 428 | if (is.null(dat$TEST) || is.null(dat$selected) || is.null(dat$chosen) || nrow(dat$selected) == 0) return() 429 | 430 | isolate({ 431 | 432 | p_overview <- NULL 433 | dv <- dat$chosen 434 | 435 | # separete included from excluded data and save them for later usage 436 | includedData <- getSelectedRows(dat$allData, dat$selected, dv) 437 | excludedData <- getSelectedRows(dat$allData, dat$selected, dv, invert = TRUE) 438 | 439 | if(dat$control_for_interaction) { 440 | # draw interaction plot 441 | 442 | 443 | 444 | # calculate means for interaction plot 445 | means <- aggregate(includedData[dv], by=includedData[c("group","gender")], FUN=mean) 446 | 447 | p_overview <- ggplot(dat$allData[1:dat$n,], aes_string(x = "group", y = dv, colour = "gender")) + 448 | geom_point(data = means, mapping=aes_string(y = dv), shape = 0, size=8) + 449 | geom_point(data = includedData, shape=16, size=4) + 450 | geom_point(data = excludedData, shape = 21, size=4, fill = NA, alpha = 0.5) + # show excluded points 451 | geom_line(data = means, mapping=aes_string(y = dv, group = "gender")) + 452 | theme_bw() 453 | 454 | } else { 455 | # draw default plot 456 | 457 | p_overview <- ggplot(dat$allData[1:dat$n,], aes_string(x="group", y=dv)) + 458 | stat_boxplot(geom ='errorbar', data = includedData, color = "grey", width = 0.5) + # draw vertical lines at lower and upper end 459 | geom_boxplot(data = includedData, fill="grey", colour = "grey", alpha = 0.25, outlier.color="red") + # draw boxplot 460 | geom_point(data = includedData, shape = 16, size=4, fill = NA) + # show data points 461 | geom_point(data = excludedData, shape = 21, size=4, fill = NA, colour = "black", alpha = 0.5) + # show excluded points 462 | theme_bw() 463 | } 464 | 465 | 466 | 467 | 468 | }) 469 | return(p_overview) 470 | }) 471 | 472 | 473 | # render hints for plot 474 | output$plothints <- renderUI({ 475 | if(!is.null(dat$TEST) && !dat$flag_point_already_excluded) { 476 | tags$span(class="label label-info", id="selector_label", "Click point to exclude or to reinclude point!") 477 | } 478 | }) 479 | 480 | 481 | # --------------------------------------------------------------------- 482 | # render study stack panel 483 | 484 | output$studystack<- renderUI({ 485 | pchecker_link <- paste0("http://shinyapps.org/apps/p-checker/?syntax=", URLencode(dat$studystack, reserved=TRUE)) 486 | 487 | ul.tag <- tags$ul(class="list-group") 488 | if(is.null(dat$studystack) || dat$studystack == "") { 489 | link.tag <- a(class="btn btn-default btn-sm btn-block", href=pchecker_link,target="_blank", disabled="disabled", 'Send to p-checker') 490 | ul.tag <- tagAppendChild(ul.tag, tags$li(class="list-group-item disabled", "Empty")) 491 | clear.button.tag <- actionButton("clear_stack", 'Clear Stack', icon=icon("trash", lib = "glyphicon"), class="btn-sm btn-block", disabled = "disabled") 492 | } else { 493 | link.tag <- a(class="btn btn-default btn-sm btn-block", href=pchecker_link,target="_blank", 'Send to p-checker') 494 | rows <- strsplit(dat$studystack, "\n")[[1]] 495 | 496 | elements <- list() 497 | for(i in 1:length(rows)) { 498 | elements[[i]] <- tags$li(class="list-group-item", rows[i]) 499 | } 500 | ul.tag <- tagAppendChildren(ul.tag, list = elements) 501 | clear.button.tag <- actionButton("clear_stack", 'Clear Stack', icon=icon("trash", lib = "glyphicon"), class="btn-sm btn-block") 502 | } 503 | 504 | 505 | 506 | return(list( 507 | h3("My study stack"), 508 | p("Studies that worked!"), 509 | div(class="form-group", 510 | ul.tag, 511 | div(class="btn-group-vertical btn-block", link.tag, clear.button.tag) 512 | ) 513 | )) 514 | }) 515 | 516 | output$seed_form <- renderUI({ 517 | p.tag <- NULL 518 | 519 | if(is.null(dat$next_seed)) { 520 | return() 521 | } 522 | 523 | if(!is.null(dat$current_seed)) { 524 | p.tag <- p(paste0("Current seed: ", dat$current_seed)) 525 | } 526 | 527 | p.tag 528 | }) 529 | 530 | output$error_msg <- renderUI({ 531 | if(is.null(dat$last_error_msg)) return(); 532 | 533 | div(class="alert alert-danger",role="alert",dat$last_error_msg) 534 | }) 535 | 536 | 537 | # --------------------------------------------------------------------- 538 | # Subgroup analysis 539 | 540 | output$subgroupOutput <- renderUI({ 541 | 542 | 543 | if (nrow(dat$allData) == 0) return() 544 | 545 | # split into 6 groups 546 | includedData <- getSelectedRows(dat$allData, dat$selected, dat$chosen) 547 | includedData$ageGroup <- cut(includedData$age, breaks=c(0, median(includedData$age), max(includedData$age)), labels=c("young", "old")) 548 | 549 | subgroupTests <- data.frame() 550 | for (ag in levels(includedData$ageGroup)) { 551 | for (g in levels(includedData$gender)){ 552 | 553 | print(paste0("Computing ", ag, "/", g)) 554 | 555 | iD2 <- includedData[includedData$ageGroup == ag & includedData$gender == g, ] 556 | 557 | #print(table(iD2$group)) 558 | 559 | # if at least 5 participants are in each cell, compute the ANOVA 560 | if (sum(iD2$group == input$label_group1)>5 & sum(iD2$group == input$label_group2)>5) { 561 | 562 | sg.aov <- aov(formula(paste0(dat$chosen, " ~ group")), iD2) 563 | 564 | subgroupTests <- rbind(subgroupTests, data.frame( 565 | agegroup = ag, 566 | gender = g, 567 | p.value = summary(sg.aov)[[1]]$Pr[1] 568 | )) 569 | } 570 | } 571 | } 572 | 573 | print(subgroupTests) 574 | 575 | # p1 <- ggplot(includedData, aes_string(x="group", y=dat$chosen)) + geom_point() + facet_grid(gender~ageGroup) + stat_boxplot(geom ='errorbar', data = includedData, color = "grey", width = 0.5) + # draw vertical lines at lower and upper end 576 | # geom_boxplot(data = includedData, fill="grey", colour = "grey", alpha = 0.25, outlier.color="red") + # draw boxplot 577 | # geom_point(data = includedData, shape = 16, size=4, fill = NA) + # show data points 578 | # theme_bw() 579 | 580 | 581 | return(list( 582 | #selectInput("DV_selector_sg", label="Choose DV for analysis", c(paste0(DV_PREFIX, 1:isolate({input$dv_n})), isolate({dat$chosen.sg}))), 583 | renderTable(subgroupTests)#, 584 | #renderPlot(p1) 585 | )) 586 | }) 587 | 588 | 589 | }) 590 | -------------------------------------------------------------------------------- /.Rapp.history: -------------------------------------------------------------------------------- 1 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 2 | library(shiny)# 3 | library(shinyIncubator)# 4 | library(shinythemes)# 5 | runApp("p-checker") 6 | library(metafor) 7 | ?funnel 8 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 9 | library(shiny)# 10 | library(shinyIncubator)# 11 | library(shinythemes)# 12 | runApp("p-checker") 13 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 14 | library(shiny)# 15 | library(shinyIncubator)# 16 | library(shinythemes)# 17 | runApp("p-checker") 18 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 19 | library(shiny)# 20 | library(shinyIncubator)# 21 | library(shinythemes)# 22 | runApp("p-checker") 23 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 24 | library(shiny)# 25 | library(shinyIncubator)# 26 | library(shinythemes)# 27 | runApp("p-checker") 28 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 29 | library(shiny)# 30 | library(shinyIncubator)# 31 | library(shinythemes)# 32 | runApp("p-checker") 33 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 34 | library(shiny)# 35 | library(shinyIncubator)# 36 | library(shinythemes)# 37 | runApp("p-checker") 38 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 39 | library(shiny)# 40 | library(shinyIncubator)# 41 | library(shinythemes)# 42 | runApp("p-checker") 43 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 44 | library(shiny)# 45 | library(shinyIncubator)# 46 | library(shinythemes)# 47 | runApp("p-checker") 48 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 49 | library(shiny)# 50 | library(shinyIncubator)# 51 | library(shinythemes)# 52 | runApp("p-checker") 53 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 54 | library(shiny)# 55 | library(shinyIncubator)# 56 | library(shinythemes)# 57 | runApp("p-checker") 58 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps/p-checker') 59 | # ---------------------------------------------------------------------# 60 | # Parser for the ES strings# 61 | # - parse test statistics and dfs# 62 | # - compute correct p value# 63 | # - convert all to ES to Z values# 64 | # @param x A string with the effect size. Everything before the colon is an identifier for the paper (can be a number, or the name of the paper). Test statistics with the same identifier belong together. You can also skip that part. By default a critical two-tailed p value of .05 is assumed; to override this for a certain test statistic, write at the end of the line: '; crit = .10', for example. Examples:# 65 | # 66 | # x = "MMu (2012) S1: t(88)=2.1; crit = .10; p < .04 # comment"# 67 | # x = "1: t(88)=2.1, crit = .10, p < .04 # comment"# 68 | # x = "1: t(88)=2.1; p < .04; crit = .10"# 69 | # x = "Stapel (2008): r(147)=.246"# 70 | # x = "F(1,100)=9.1"# 71 | # x = "F(2,210)=4.45"# 72 | # x = "Z=3.45"# 73 | # x = "chi2(1)=9.1"# 74 | # x = "r(77)=.47"# 75 | # @param round_up: If the t value is reported as 2.1, it could also be 2.1499 which has been rounded down. If you want to be maximally generous, set this parameter to TRUE, and all test statistics are automatically increased by X.XX49.# 76 | parse_ES1 <- function(x, paper_id_fallback="_1", round_up=FALSE) {# 77 | library(compute.es)# 78 | # 79 | W <- c() # W collects all warnings# 80 | # 81 | # preprocessing: replace typographic characters# 82 | x <- gsub("–|−", "-", x)# 83 | # remove everything after a # sign; remove empty rows; convert to lower# 84 | x <- gsub("#.*$", "", x)# 85 | x <- str_trim(x)# 86 | # replace all commas outside of parentheses with semicolons# 87 | if (str_detect(x, ")")) {# 88 | x1 <- str_match(x, "(.*)\\)(.*)")[2]# 89 | x2 <- str_match(x, "(.*)\\)(.*)")[3]# 90 | x2 <- gsub(",", ";", x2)# 91 | x <- paste0(x1, ")", x2)# 92 | }# 93 | # Is it only a comment line? Return NULL# 94 | if (x == "") return(NULL)# 95 | split0 <- strsplit(x, ":")[[1]]# 96 | # Is a study id provided? # 97 | if (length(split0) > 1) {# 98 | # separate study id into two parts: # 99 | # a) First part until year of publication; b) everything after that# 100 | paper_id_full <- as.character(gsub(":", "", split0[1]))# 101 | paper_id <- str_match(paper_id_full, "^.*\\(.*\\)")[1]# 102 | if (is.na(paper_id)) {# 103 | paper_id <- paper_id_full# 104 | study_id <- ""# 105 | } else {# 106 | study_id <- str_trim(str_match(paper_id_full, "\\(.*\\)(.*$)")[2]) # 107 | }# 108 | x2 <- split0[2]# 109 | } else {# 110 | paper_id <- paper_id_fallback# 111 | study_id <- ""# 112 | x2 <- split0[1]# 113 | }# 114 | # 115 | split1 <- strsplit(gsub(" ", "", x2), ";")[[1]]# 116 | # define defaults# 117 | p.crit <- NA# 118 | p.reported <- NA# 119 | reporting.error <- NA# 120 | error.direction <- ""# 121 | one.tailed <- FALSE# 122 | # Is a critical p value and/or reported p value provided? Is it one-tailed?# 123 | if (length(split1) > 1) {# 124 | for (i in 2:length(split1)) {# 125 | # 126 | split1[i] <- tolower(split1[i])# 127 | if (str_detect(split1[i], "crit") == TRUE) {# 128 | x3 <- strsplit(gsub(" ", "", split1[i]), "=|<|>")[[1]]# 129 | p.crit <- suppressWarnings(as.numeric(as.character(x3[2])))# 130 | }# 131 | if (str_detect(split1[i], "p\\s*(=|<|>)")==TRUE) {# 132 | p.reported <- gsub(" ", "", split1[i])# 133 | }# 134 | if (str_detect(split1[i], "one|1t|one-tailed") == TRUE) {# 135 | one.tailed <- TRUE# 136 | }# 137 | }# 138 | }# 139 | # set default for p.crit if not defined explicitly# 140 | if (is.na(p.crit)) {# 141 | p.crit <- ifelse(one.tailed==FALSE, .05, .10)# 142 | }# 143 | split2 <- strsplit(split1[1], "=")[[1]]# 144 | lhs <- split2[1]# 145 | statistic <- suppressWarnings(as.numeric(split2[2]))# 146 | decPlaces <- decplaces(str_trim(split2[2]))# 147 | if (round_up==TRUE) {# 148 | statistic <- statistic + sign(statistic)* (4.999 / 10^(decPlaces+1))# 149 | }# 150 | # also convert brackets to parentheses# 151 | lhs <- gsub("[", "(", lhs, fixed=TRUE)# 152 | lhs <- gsub("]", ")", lhs, fixed=TRUE)# 153 | type <- tolower(strsplit(lhs, "(", fixed=TRUE)[[1]][1])# 154 | dfs <- str_extract(lhs, "\\(.*\\)")# 155 | dfs <- suppressWarnings(as.numeric(strsplit(substring(dfs, 2, nchar(dfs)-1), ",")[[1]])) # remove parentheses# 156 | # 157 | # error capturing# 158 | if (!type %in% c("t", "f", "r", "z", "chi2")) {# 159 | W <- c(W, paste0("Test statistic not recognized! ", x))# 160 | return(W)# 161 | }# 162 | if (type != "z" && is.na(as.numeric(dfs[1]))) {# 163 | W <- c(W, paste0("Error in df: ", x))# 164 | return(W)# 165 | }# 166 | if (is.na(as.numeric(statistic))) {# 167 | W <- c(W, paste0("Error in test statistic: ", x))# 168 | return(W)# 169 | }# 170 | # 171 | # compute the actual p values# 172 | p.value <- NA# 173 | stat <- abs(statistic)# 174 | stat.sign <- sign(statistic)# 175 | n.approx <- NA # n is approximate because we do not know whether the t-test comes from one sample (n = df+1) or from two samples (n=df+2)# 176 | switch(type,# 177 | "t" = {# 178 | if (length(dfs) != 1) {# 179 | W <- c(W, paste0("t values need exactly one df! ", x))# 180 | return(W)# 181 | }# 182 | t.value <- stat# 183 | p.value <- pt(t.value, dfs, lower.tail=FALSE)*2# 184 | d <- (2*t.value / sqrt(dfs))*stat.sign# 185 | g <- d*(1 - (3/(4 * dfs - 1)))# 186 | n.approx <- dfs+2# 187 | },# 188 | "r" = {# 189 | if (length(dfs) != 1) {# 190 | W <- c(W, paste0("r values need exactly one df (df = n-2)! ", x))# 191 | return(W)# 192 | }# 193 | t.value <- sqrt(dfs) * stat/sqrt(1 - stat^2)# 194 | p.value <- pt(t.value, dfs, lower.tail=FALSE)*2# 195 | d <- (2*t.value / sqrt(dfs))*stat.sign# 196 | g <- d*(1 - (3/(4 * dfs - 1)))# 197 | n.approx <- dfs+2# 198 | },# 199 | "f" = {# 200 | if (length(dfs) != 2) {# 201 | W <- c(W, paste0("F values need exactly two dfs! ", x))# 202 | return(W)# 203 | }# 204 | #if (dfs[1] != 1) warning("First df of F test should be 1 for a focused test!") # 205 | if (dfs[1] == 1) {# 206 | t.value <- sqrt(stat)# 207 | d <- 2*t.value / sqrt(dfs[2])# 208 | g <- d*(1 - (3/(4 * dfs[2] - 1)))# 209 | n.approx <- dfs+2# 210 | } else {# 211 | d <- NA# 212 | g <- NA# 213 | }# 214 | p.value <- pf(stat, dfs[1], dfs[2], lower.tail=FALSE)# 215 | },# 216 | "z" = {# 217 | p.value <- pnorm(stat, lower.tail=FALSE)*2# 218 | # If a number is provided for z it's the sample size# 219 | if (!is.na(dfs[1])) {# 220 | n <- dfs[1]# 221 | d <- (z/sqrt(n))*stat.sign# 222 | g <- d*(1 - (3/(4 * n - 1)))# 223 | n.approx <- n# 224 | } else {# 225 | d <- NA# 226 | g <- NA# 227 | } # 228 | },# 229 | "chi2" = {# 230 | # If two numbers are provided for chi2, the first are the dfs, the second is the sample size# 231 | p.value <- pchisq(stat, dfs[1], lower.tail=FALSE)# 232 | if (dfs[1] == 1 & !is.na(dfs[2])) {# 233 | # code from compute.es package# 234 | n <- dfs[2]# 235 | n.approx <- n# 236 | dfs <- dfs[1]# 237 | r <- sqrt(stat/n)# 238 | d <- 2 * r * sqrt((n - 1)/(n * (1 - r^2))) * abs(r)/r# 239 | g <- d*(1 - (3/(4 * (n-2) - 1)))# 240 | } else {# 241 | d <- NA# 242 | g <- NA# 243 | }# 244 | }# 245 | )# 246 | # test for reporting errors# 247 | # TODO: check both generous *and* non-generous - maybe one of both is correct# 248 | p.actual <- ifelse(one.tailed==FALSE, p.value, p.value/2)# 249 | p.reported.num <- suppressWarnings(as.numeric(str_split(p.reported, "=|<|>|<=|>=")[[1]][2]))# 250 | # 251 | if (!is.na(p.reported) & !is.na(p.reported.num)) {# 252 | # check for inequality# 253 | if (str_detect(p.reported, "<")) {# 254 | if (p.actual >= p.reported.num) {# 255 | reporting.error <- TRUE# 256 | error.direction <- "smaller"# 257 | } else {# 258 | reporting.error <- FALSE# 259 | error.direction <- ""# 260 | }# 261 | }# 262 | if (str_detect(p.reported, "<=")) {# 263 | if (p.actual >= p.reported.num) {# 264 | reporting.error <- TRUE# 265 | error.direction <- "smaller"# 266 | } else {# 267 | reporting.error <- FALSE# 268 | error.direction <- ""# 269 | }# 270 | }# 271 | if (str_detect(p.reported, ">")) {# 272 | if (p.actual <= p.reported.num) {# 273 | reporting.error <- TRUE# 274 | error.direction <- "larger"# 275 | } else {# 276 | reporting.error <- FALSE# 277 | error.direction <- ""# 278 | }# 279 | }# 280 | if (str_detect(p.reported, "p=")) {# 281 | dec <- decplaces(str_split(p.reported, "=")[[1]][2])# 282 | p.actual <- round(p.actual, dec)# 283 | if (p.reported.num == p.actual) {# 284 | reporting.error <- FALSE# 285 | error.direction <- ""# 286 | } else {# 287 | reporting.error <- TRUE# 288 | error.direction <- ifelse(p.reported.num > p.actual, "larger", "smaller")# 289 | }# 290 | }# 291 | }# 292 | res <- data.frame(# 293 | paper_id = as.character(paper_id),# 294 | study_id = as.character(study_id),# 295 | focal = ifelse(substr(as.character(paper_id), 1, 1) == "_", FALSE, TRUE),# 296 | type = type, # 297 | df1 = dfs[1], # 298 | df2 = ifelse(length(dfs)>1, dfs[2], NA), # 299 | d = d,# 300 | g = g,# 301 | n.approx = n.approx,# 302 | statistic = statistic, # 303 | p.value = p.value,# 304 | p.value.one = p.value/2,# 305 | p.reported = p.reported, # 306 | p.crit = p.crit,# 307 | significant = p.value < p.crit,# 308 | one.tailed = one.tailed,# 309 | reporting.error = reporting.error,# 310 | error.direction = error.direction# 311 | )# 312 | attr(res, "warnings") <- W# 313 | # 314 | return(res)# 315 | }# 316 | # 317 | # A vectorized version of the parse_ES1 function# 318 | parse_ES <- function(x, round_up=FALSE) {# 319 | # split input string at line break & remove empty rows# 320 | # Preprocessing: remove everything after a # sign; remove empty rows# 321 | txt <- str_trim(strsplit(x, "\n")[[1]])# 322 | txt <- gsub("#.*$", "", txt)# 323 | txt <- str_trim(txt)# 324 | txt <- txt[txt != ""]# 325 | if (txt[1]=="" | length(txt)==0) return(NULL)# 326 | res <- data.frame()# 327 | Ws <- c()# 328 | for (i in 1:length(txt)) {# 329 | parsed <- parse_ES1(txt[i], paper_id_fallback = paste0(".", i), round_up=round_up) # 330 | if (!is.null(parsed) & is.data.frame(parsed)) res <- rbind(res, parsed)# 331 | # collect errors# 332 | if (length(attr(parsed, "warnings")) > 0) Ws <- c(Ws, attr(parsed, "warnings"))# 333 | if (is.character(parsed)) Ws <- c(Ws, parsed)# 334 | }# 335 | attr(res, "warnings") <- Ws# 336 | res# 337 | }# 338 | x <- c("# 339 | t(88)=-2.1# 340 | r(147)=.246# 341 | F(1,100)=9.1# 342 | f(2,210)=4.45# 343 | Z=3.45# 344 | chi2(1)=9.1# 345 | r(77)=.47# 346 | chi2(1, 345)=8.74# 347 | ")# 348 | parse_ES(x) 349 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps/p-checker') 350 | # ---------------------------------------------------------------------# 351 | # Parser for the ES strings# 352 | # - parse test statistics and dfs# 353 | # - compute correct p value# 354 | # - convert all to ES to Z values# 355 | # @param x A string with the effect size. Everything before the colon is an identifier for the paper (can be a number, or the name of the paper). Test statistics with the same identifier belong together. You can also skip that part. By default a critical two-tailed p value of .05 is assumed; to override this for a certain test statistic, write at the end of the line: '; crit = .10', for example. Examples:# 356 | # 357 | # x = "MMu (2012) S1: t(88)=2.1; crit = .10; p < .04 # comment"# 358 | # x = "1: t(88)=2.1, crit = .10, p < .04 # comment"# 359 | # x = "1: t(88)=2.1; p < .04; crit = .10"# 360 | # x = "Stapel (2008): r(147)=.246"# 361 | # x = "F(1,100)=9.1"# 362 | # x = "F(2,210)=4.45"# 363 | # x = "Z=3.45"# 364 | # x = "chi2(1)=9.1"# 365 | # x = "r(77)=.47"# 366 | # @param round_up: If the t value is reported as 2.1, it could also be 2.1499 which has been rounded down. If you want to be maximally generous, set this parameter to TRUE, and all test statistics are automatically increased by X.XX49.# 367 | parse_ES1 <- function(x, paper_id_fallback="_1", round_up=FALSE) {# 368 | library(compute.es)# 369 | # 370 | W <- c() # W collects all warnings# 371 | # 372 | # preprocessing: replace typographic characters# 373 | x <- gsub("–|−", "-", x)# 374 | # remove everything after a # sign; remove empty rows; convert to lower# 375 | x <- gsub("#.*$", "", x)# 376 | x <- str_trim(x)# 377 | # replace all commas outside of parentheses with semicolons# 378 | if (str_detect(x, ")")) {# 379 | x1 <- str_match(x, "(.*)\\)(.*)")[2]# 380 | x2 <- str_match(x, "(.*)\\)(.*)")[3]# 381 | x2 <- gsub(",", ";", x2)# 382 | x <- paste0(x1, ")", x2)# 383 | }# 384 | # Is it only a comment line? Return NULL# 385 | if (x == "") return(NULL)# 386 | split0 <- strsplit(x, ":")[[1]]# 387 | # Is a study id provided? # 388 | if (length(split0) > 1) {# 389 | # separate study id into two parts: # 390 | # a) First part until year of publication; b) everything after that# 391 | paper_id_full <- as.character(gsub(":", "", split0[1]))# 392 | paper_id <- str_match(paper_id_full, "^.*\\(.*\\)")[1]# 393 | if (is.na(paper_id)) {# 394 | paper_id <- paper_id_full# 395 | study_id <- ""# 396 | } else {# 397 | study_id <- str_trim(str_match(paper_id_full, "\\(.*\\)(.*$)")[2]) # 398 | }# 399 | x2 <- split0[2]# 400 | } else {# 401 | paper_id <- paper_id_fallback# 402 | study_id <- ""# 403 | x2 <- split0[1]# 404 | }# 405 | # 406 | split1 <- strsplit(gsub(" ", "", x2), ";")[[1]]# 407 | # define defaults# 408 | p.crit <- NA# 409 | p.reported <- NA# 410 | reporting.error <- NA# 411 | error.direction <- ""# 412 | one.tailed <- FALSE# 413 | # Is a critical p value and/or reported p value provided? Is it one-tailed?# 414 | if (length(split1) > 1) {# 415 | for (i in 2:length(split1)) {# 416 | # 417 | split1[i] <- tolower(split1[i])# 418 | if (str_detect(split1[i], "crit") == TRUE) {# 419 | x3 <- strsplit(gsub(" ", "", split1[i]), "=|<|>")[[1]]# 420 | p.crit <- suppressWarnings(as.numeric(as.character(x3[2])))# 421 | }# 422 | if (str_detect(split1[i], "p\\s*(=|<|>)")==TRUE) {# 423 | p.reported <- gsub(" ", "", split1[i])# 424 | }# 425 | if (str_detect(split1[i], "one|1t|one-tailed") == TRUE) {# 426 | one.tailed <- TRUE# 427 | }# 428 | }# 429 | }# 430 | # set default for p.crit if not defined explicitly# 431 | if (is.na(p.crit)) {# 432 | p.crit <- ifelse(one.tailed==FALSE, .05, .10)# 433 | }# 434 | split2 <- strsplit(split1[1], "=")[[1]]# 435 | lhs <- split2[1]# 436 | statistic <- suppressWarnings(as.numeric(split2[2]))# 437 | decPlaces <- decplaces(str_trim(split2[2]))# 438 | if (round_up==TRUE) {# 439 | statistic <- statistic + sign(statistic)* (4.999 / 10^(decPlaces+1))# 440 | }# 441 | # also convert brackets to parentheses# 442 | lhs <- gsub("[", "(", lhs, fixed=TRUE)# 443 | lhs <- gsub("]", ")", lhs, fixed=TRUE)# 444 | type <- tolower(strsplit(lhs, "(", fixed=TRUE)[[1]][1])# 445 | dfs <- str_extract(lhs, "\\(.*\\)")# 446 | dfs <- suppressWarnings(as.numeric(strsplit(substring(dfs, 2, nchar(dfs)-1), ",")[[1]])) # remove parentheses# 447 | # 448 | # error capturing# 449 | if (!type %in% c("t", "f", "r", "z", "chi2")) {# 450 | W <- c(W, paste0("Test statistic not recognized! ", x))# 451 | return(W)# 452 | }# 453 | if (type != "z" && is.na(as.numeric(dfs[1]))) {# 454 | W <- c(W, paste0("Error in df: ", x))# 455 | return(W)# 456 | }# 457 | if (is.na(as.numeric(statistic))) {# 458 | W <- c(W, paste0("Error in test statistic: ", x))# 459 | return(W)# 460 | }# 461 | # 462 | # compute the actual p values# 463 | p.value <- NA# 464 | stat <- abs(statistic)# 465 | stat.sign <- sign(statistic)# 466 | n.approx <- NA # n is approximate because we do not know whether the t-test comes from one sample (n = df+1) or from two samples (n=df+2)# 467 | switch(type,# 468 | "t" = {# 469 | if (length(dfs) != 1) {# 470 | W <- c(W, paste0("t values need exactly one df! ", x))# 471 | return(W)# 472 | }# 473 | t.value <- stat# 474 | p.value <- pt(t.value, dfs, lower.tail=FALSE)*2# 475 | d <- (2*t.value / sqrt(dfs))*stat.sign# 476 | g <- d*(1 - (3/(4 * dfs - 1)))# 477 | n.approx <- dfs+2# 478 | },# 479 | "r" = {# 480 | if (length(dfs) != 1) {# 481 | W <- c(W, paste0("r values need exactly one df (df = n-2)! ", x))# 482 | return(W)# 483 | }# 484 | t.value <- sqrt(dfs) * stat/sqrt(1 - stat^2)# 485 | p.value <- pt(t.value, dfs, lower.tail=FALSE)*2# 486 | d <- (2*t.value / sqrt(dfs))*stat.sign# 487 | g <- d*(1 - (3/(4 * dfs - 1)))# 488 | n.approx <- dfs+2# 489 | },# 490 | "f" = {# 491 | if (length(dfs) != 2) {# 492 | W <- c(W, paste0("F values need exactly two dfs! ", x))# 493 | return(W)# 494 | }# 495 | #if (dfs[1] != 1) warning("First df of F test should be 1 for a focused test!") # 496 | if (dfs[1] == 1) {# 497 | t.value <- sqrt(stat)# 498 | d <- 2*t.value / sqrt(dfs[2])# 499 | g <- d*(1 - (3/(4 * dfs[2] - 1)))# 500 | n.approx <- dfs[2]+2# 501 | } else {# 502 | d <- NA# 503 | g <- NA# 504 | }# 505 | p.value <- pf(stat, dfs[1], dfs[2], lower.tail=FALSE)# 506 | },# 507 | "z" = {# 508 | p.value <- pnorm(stat, lower.tail=FALSE)*2# 509 | # If a number is provided for z it's the sample size# 510 | if (!is.na(dfs[1])) {# 511 | n <- dfs[1]# 512 | d <- (z/sqrt(n))*stat.sign# 513 | g <- d*(1 - (3/(4 * n - 1)))# 514 | n.approx <- n# 515 | } else {# 516 | d <- NA# 517 | g <- NA# 518 | } # 519 | },# 520 | "chi2" = {# 521 | # If two numbers are provided for chi2, the first are the dfs, the second is the sample size# 522 | p.value <- pchisq(stat, dfs[1], lower.tail=FALSE)# 523 | if (dfs[1] == 1 & !is.na(dfs[2])) {# 524 | # code from compute.es package# 525 | n <- dfs[2]# 526 | n.approx <- n# 527 | dfs <- dfs[1]# 528 | r <- sqrt(stat/n)# 529 | d <- 2 * r * sqrt((n - 1)/(n * (1 - r^2))) * abs(r)/r# 530 | g <- d*(1 - (3/(4 * (n-2) - 1)))# 531 | } else {# 532 | d <- NA# 533 | g <- NA# 534 | }# 535 | }# 536 | )# 537 | # test for reporting errors# 538 | # TODO: check both generous *and* non-generous - maybe one of both is correct# 539 | p.actual <- ifelse(one.tailed==FALSE, p.value, p.value/2)# 540 | p.reported.num <- suppressWarnings(as.numeric(str_split(p.reported, "=|<|>|<=|>=")[[1]][2]))# 541 | # 542 | if (!is.na(p.reported) & !is.na(p.reported.num)) {# 543 | # check for inequality# 544 | if (str_detect(p.reported, "<")) {# 545 | if (p.actual >= p.reported.num) {# 546 | reporting.error <- TRUE# 547 | error.direction <- "smaller"# 548 | } else {# 549 | reporting.error <- FALSE# 550 | error.direction <- ""# 551 | }# 552 | }# 553 | if (str_detect(p.reported, "<=")) {# 554 | if (p.actual >= p.reported.num) {# 555 | reporting.error <- TRUE# 556 | error.direction <- "smaller"# 557 | } else {# 558 | reporting.error <- FALSE# 559 | error.direction <- ""# 560 | }# 561 | }# 562 | if (str_detect(p.reported, ">")) {# 563 | if (p.actual <= p.reported.num) {# 564 | reporting.error <- TRUE# 565 | error.direction <- "larger"# 566 | } else {# 567 | reporting.error <- FALSE# 568 | error.direction <- ""# 569 | }# 570 | }# 571 | if (str_detect(p.reported, "p=")) {# 572 | dec <- decplaces(str_split(p.reported, "=")[[1]][2])# 573 | p.actual <- round(p.actual, dec)# 574 | if (p.reported.num == p.actual) {# 575 | reporting.error <- FALSE# 576 | error.direction <- ""# 577 | } else {# 578 | reporting.error <- TRUE# 579 | error.direction <- ifelse(p.reported.num > p.actual, "larger", "smaller")# 580 | }# 581 | }# 582 | }# 583 | res <- data.frame(# 584 | paper_id = as.character(paper_id),# 585 | study_id = as.character(study_id),# 586 | focal = ifelse(substr(as.character(paper_id), 1, 1) == "_", FALSE, TRUE),# 587 | type = type, # 588 | df1 = dfs[1], # 589 | df2 = ifelse(length(dfs)>1, dfs[2], NA), # 590 | d = d,# 591 | g = g,# 592 | n.approx = n.approx,# 593 | statistic = statistic, # 594 | p.value = p.value,# 595 | p.value.one = p.value/2,# 596 | p.reported = p.reported, # 597 | p.crit = p.crit,# 598 | significant = p.value < p.crit,# 599 | one.tailed = one.tailed,# 600 | reporting.error = reporting.error,# 601 | error.direction = error.direction# 602 | )# 603 | attr(res, "warnings") <- W# 604 | # 605 | return(res)# 606 | }# 607 | # 608 | # A vectorized version of the parse_ES1 function# 609 | parse_ES <- function(x, round_up=FALSE) {# 610 | # split input string at line break & remove empty rows# 611 | # Preprocessing: remove everything after a # sign; remove empty rows# 612 | txt <- str_trim(strsplit(x, "\n")[[1]])# 613 | txt <- gsub("#.*$", "", txt)# 614 | txt <- str_trim(txt)# 615 | txt <- txt[txt != ""]# 616 | if (txt[1]=="" | length(txt)==0) return(NULL)# 617 | res <- data.frame()# 618 | Ws <- c()# 619 | for (i in 1:length(txt)) {# 620 | parsed <- parse_ES1(txt[i], paper_id_fallback = paste0(".", i), round_up=round_up) # 621 | if (!is.null(parsed) & is.data.frame(parsed)) res <- rbind(res, parsed)# 622 | # collect errors# 623 | if (length(attr(parsed, "warnings")) > 0) Ws <- c(Ws, attr(parsed, "warnings"))# 624 | if (is.character(parsed)) Ws <- c(Ws, parsed)# 625 | }# 626 | attr(res, "warnings") <- Ws# 627 | res# 628 | }# 629 | x <- c("# 630 | t(88)=-2.1# 631 | r(147)=.246# 632 | F(1,100)=9.1# 633 | f(2,210)=4.45# 634 | Z=3.45# 635 | chi2(1)=9.1# 636 | r(77)=.47# 637 | chi2(1, 345)=8.74# 638 | ")# 639 | parse_ES(x) 640 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 641 | library(shiny)# 642 | library(shinyIncubator)# 643 | library(shinythemes)# 644 | runApp("p-checker") 645 | setwd('/Users/Felix/Documents/R/Funktionen/GitHub/shinyApps') 646 | library(shiny)# 647 | library(shinyIncubator)# 648 | library(shinythemes)# 649 | runApp("p-checker") 650 | --------------------------------------------------------------------------------