Testing for ESP

Introduction

Every year, I use an active learning exercise suggested by the authors of Unlocking the Power of data to introduce hypothesis tests. Students were asked to pair up with a partner. One of the two students “thinks” of a letter A, B, C, D, or E and then tries to telepathically communicate their choice to their partner. The partner then selects one of the 5 letters and the “sender” of the information fills out a Google form recording:

1. Whether they believe in ESP or not.
2. Whether their partner guessed the letter they selected.

In past year’s, we have found some support for ESP, particularly among believers. You can find those analyses on the biometry lab website.

This year, I am making some changes in hopes of providing a more rigorous test. Specifically:

• letters will be randomly chosen by R
• guessers and their partners will independently enter their letters
• I will use R to identify correct and incorrect guesses.

Load libraries

library(mosaic)
library(dplyr)
library(googledrive)
library(googlesheets4)
library(stringr)
library(fuzzyjoin)

set.seed(03222005)

Read in the data

Match the records

# Standardize keys (convert to lowercase and strip whitespace)
esp.C_clean <- esp.C %>%
  mutate(
    k1_clean = str_to_lower(str_trim(`Keyword 1`)),
    k2_clean = str_to_lower(str_trim(`Keyword 2`))
  )

esp.G_clean <- esp.G %>%
  mutate(
    k1_clean = str_to_lower(str_trim(`Keyword 1`)),
    k2_clean = str_to_lower(str_trim(`Keyword 2`))
  )

# 2. Fuzzy join (without the suffix argument)
matched_esp <- stringdist_inner_join(
  esp.C_clean,
  esp.G_clean,
  by = c("k1_clean" = "k1_clean", "k2_clean" = "k2_clean"),
  method = "lv",     # Levenshtein distance
  max_dist = 2      # Max allowed character edits/typos per key
) %>%
  # 3. Check if guessed letter (.y) matches chosen letter (.x)
  mutate(
    is_correct = (`Letter.x` == `Letter.y`)
  ) %>%
  # 4. Select and rename final columns for display
  select(
    chooser_k1 = `Keyword 1.x`,
    chooser_k2 = `Keyword 2.x`,
    guesser_k1 = `Keyword 1.y`,
    guesser_k2 = `Keyword 2.y`,
    chosen_letter = `Letter.x`,
    guessed_letter = `Letter.y`,
    guesser_believe = Believe.x,
    is_correct
  )

Let’s look at the matches and all the cool keywords!

select(matched_esp, chooser_k1, chooser_k2, guesser_k1, guesser_k2, chosen_letter, guessed_letter) |> print(n = 1000)

# A tibble: 34 × 6
   chooser_k1   chooser_k2   guesser_k1  guesser_k2 chosen_letter guessed_letter
   <chr>        <chr>        <chr>       <chr>      <chr>         <chr>         
 1 mustache     stick        mustache    stick      A             C             
 2 cheese       elephant     Cheese      Elephant   E             B             
 3 Manatee      Vulture      Manatee     Vulture    D             B             
 4 Fish         Cat          Fish        Cat        E             D             
 5 cheese       cat          cheese      cat        D             C             
 6 bass         bluegill     Bass        Bluegill   D             B             
 7 Blue         Black        blue        black      D             E             
 8 Manatee      Vulture      Manatee     Vulture    E             B             
 9 Owls         Omelet       Owls        Omelet     D             C             
10 biometry     morning      biometry    morning    D             D             
11 dino         nuggets      dino        nuggets    E             B             
12 Owls         Omelet       Owls        Omelet     B             C             
13 AlligatorGar BurrowingOwl Alligator … Burrowing… A             C             
14 Orange       Snake        orange      snake      C             C             
15 Goblin       Troll        Goblin      Troll      D             D             
16 Yesterday    Today        yesterday   today      D             D             
17 Trout        Kestrel      Trout       Kestrel    A             B             
18 Creek        Land         Creek       Land       E             D             
19 test         score        test        score      D             A             
20 skunk        deer         skunk       deer       C             C             
21 Deer         Dog          deer        dog        E             B             
22 Minnesota    Canada       Minnesota   Canada     E             A             
23 dog          tiger        dog         tiger      C             A             
24 Brain        Frog         Brain       Frog       A             B             
25 Olive        Rutabaga     olive       rutabaga   E             C             
26 pencil       eraser       Pencil      Eraser     C             E             
27 Vital        Source       Vital       Source     E             D             
28 bird         horse        Bird        Horse      C             B             
29 chair        hair         Chair       Hair       C             A             
30 fish         taco         fish        taco       D             A             
31 albatross    shearwater   albatross   sheerwater B             B             
32 Care         Color        care        color      C             C             
33 apple        caramel      apple       carame     D             D             
34 Fruit Salad  Jit          Fruit Salad Jit        C             C             

Belief in ESP

These two graphs should agree

Do you believe in ESP?

gf_percents(~Believe, data=esp.C)

gf_percents(~Believe, data=esp.G)

Do Guessers prefer a certain letter

gf_percents(~Letter, data=esp.G)   

Proportion correct

gf_percents(~is_correct, data=matched_esp)   

tally(~is_correct, data=matched_esp, format="proportion")

is_correct
     TRUE     FALSE 
0.2647059 0.7352941 

(phat<-prop(~is_correct,  data=matched_esp))

prop_TRUE 
0.2647059 

Randomization distribution

Let’s determine what we might expect to see across repeated experiments with the same number of students if the null hypothesis is true - i.e., there is no ESP and students have a 1/5 chance of guessing the correct letter. The histogram, below, shows us what we might expect across repeated samples. The red line shows the sample proportion from today’s experiment.

nguesses<-nrow(matched_esp) # Number of students trying to guess the correct letter
Null.dist<-do(10000)*{
    rflip(nguesses, p=1/5) # each student has a 1 in 5 chance of guessing correctly
}
head(Null.dist)

   n heads tails      prop
1 34     5    29 0.1470588
2 34     5    29 0.1470588
3 34     6    28 0.1764706
4 34     8    26 0.2352941
5 34     8    26 0.2352941
6 34     6    28 0.1764706

gf_histogram(~prop, data=Null.dist,
             binwidth=0.04, title = "Randomization Distribution") %>% 
  gf_vline(xintercept=~phat, data=NA, col="red")

Warning: `aes_string()` was deprecated in ggplot2 3.0.0.
ℹ Please use tidy evaluation idioms with `aes()`.
ℹ See also `vignette("ggplot2-in-packages")` for more information.
ℹ The deprecated feature was likely used in the ggformula package.
  Please report the issue at
  <https://github.com/ProjectMOSAIC/ggformula/issues>.

We can measure the strength of evidence against the null hypothesis by the p-value, or the probability of getting an observation as extreme or more extreme than the one we got, given the null hypothesis is true. Below is a “one-sided p-value” determined by the proportion of statistics (i.e., sample proportions) greater than the one we observed today.

(pvalue<-prop(~prop>=phat, data=Null.dist))  

prop_TRUE 
   0.2265 

We can also calculate a two-sided p-value, say if we are also interested in detecting if p < 0.20 (here, we approximate this p-value by doubling the one-sided p-value).

2*pvalue 

prop_TRUE 
    0.453 

Let’s also create a bootstrap distribution so we can calculate a confidence interval for p. 

bootphats<-do(10000)*{tally(~is_correct, data=resample(matched_esp), format="proportion")}
(CI<-qdata(~TRUE., data=bootphats, p=c(0.025, 0.975)))

     2.5%     97.5% 
0.1176471 0.4117647 

gf_histogram(~TRUE., data=bootphats,
             binwidth=0.04, title = "Bootstrap Distribution") %>% 
  gf_vline(xintercept=~CI[1], data=NA, col="red") %>%
  gf_vline(xintercept=~CI[2], data=NA, col="red")

We see that 0.20 is in the confidence interval, and the p-value is also fairly large. So, this year at least, we don’t find that there is a lot of evidence to support the conclusion that students may do better than random guessing.

Results broken down by Belief status

Correct answers (for those that do and do not believe). There are some interesting patterns here that we will come back to later (e.g., a higher proportion of correct guesses among those that believe in ESP).

gf_percents(~is_correct, fill=~guesser_believe, denom=~fill, data=matched_esp,
            position = position_dodge())   

These results differ from those in past years. I’ll want to replicate the experiment a few more times before assuming that the stricter protocols / setting are responsible for the lack of statistical discernability.