Scores from matching things

Mostly about the method of derangements but some huxtable!

Show code

### this is just the code that creates the "copy to clipboard" function in the code blocks
htmltools::tagList(
  xaringanExtra::use_clipboard(
    button_text = "<i class=\"fa fa-clone fa-2x\" style=\"color: #301e64\"></i>",
    success_text = "<i class=\"fa fa-check fa-2x\" style=\"color: #90BE6D\"></i>",
    error_text = "<i class=\"fa fa-times fa-2x\" style=\"color: #F94144\"></i>"
  ),
  rmarkdown::html_dependency_font_awesome()
)

Show code

as_tibble(list(x = 1,
               y = 1)) -> tibDat

ggplot(data = tibDat,
       aes(x = x, y = y)) +
  geom_text(label = "Derangements #1",
            size = 20,
            colour = "red",
            angle = 30,
            lineheight = 1) +
  xlab("") +
  ylab("") +
  theme_bw() +
  theme(panel.grid.major = element_blank(),
        panel.grid.minor = element_blank(),
        panel.border = element_blank(),
        panel.background = element_blank(),
        axis.line = element_blank(),
        axis.text = element_blank(),
        axis.ticks = element_blank()) 

[Created 15.vii.22, tweaked 23.vii.22 and 11.ix.22, neither changing code or outputs.] The theory behind this is fully described in:

Evans, C., Hughes, J., & Houston, J. (2002). Significance testing the validity of ideographic methods: A little derangement goes a long way. British Journal of Mathematical and Statistical Psychology, 55(2), 385–390. https://doi.org/10.1348/000711002760554525

Do contact me through my work site if you would like a copy of that.

The idea is of matching things which might be purely idiographic. For example in that original paper the matching task presented to therapists from a prison therapy group was to see if they could match the two dimensional principal component plots from person repertory grids created with elicited contructs and varying elements by each of the six members of the group. Both therapists matched four of the six pre-therapy grids successfully; one therapist matched all six post-therapy grids and the other matched three of the six.

The paper showed that the probability of matching four or more objects correctly is always unlikely to happen by chance alone with p < .05 regardless of the number of objects.

All I am doing here is using a bit of R, specifically the function permutations() from the admisc package to get all the possible permutations (i.e. ways of chosing) n objects and using a bit of tidyverse to feed this into a huxtable … i.e. into one of R’s various ways of prettifying and managing tables.

n(objects) = 3

Let’s start with the situation where you only have three objects (as it makes things small and simple). There are six ways of rearranging three objects, three ways to pick the first, two ways to pick the second and then of course the third one is picked for you.

This table shows the six possible permutations of three objects in columns 2 to 4. Then in columns 5 to 7 it shows the matching scores as “Y” or “N” depending on whether each chosen object has been put in the correct place. (Imagine that you had been given three repertory grid plots created from grids from people you knew well and you are trying to match each grid to the person who created it with no other clues.) Finally it shows the matching score.

Show code

options(width = 160)
options(huxtable.knitr_output_format = "html") 
getMatches <- function(vec) {
  ### litle function that returns a vector of zero or one
  ### depending whether the number in the vector matches its
  ### position in the vector
  ### I could have put some input error trapping 
  ### but no need given that I'm only using this here
  return(as.numeric(vec == 1:length(vec)))
}
# getMatches(1:3)
# getMatches(1:59)
# getMatches(c(3, 2, 1))
# getMatches(c(3, 1, 2))


matchScore <- function(vec) {
  ### similar function to getMatches but this time returns
  ### total score of matches
  return(sum(vec == 1:length(vec)))
}
# matchScore(1:3)
# matchScore(1:59)
# matchScore(c(3, 2, 1))
# matchScore(c(3, 1, 2))

### I've wrapped this in suppressMessages to get rid of the irritating renaming messages from dplyr
suppressMessages(admisc::permutations(1:3) %>%
                   ### that got me all the permtations of 1:3 
                   ### but as a matrix
                   as.data.frame() %>% # go to df (avoids warning from dplyr)
                   as_tibble() %>% # and then to tibble!
                   rowwise() %>% # go to rowwise mode
                   ### and compute the matches as a list/vector
                   mutate(matches = list(getMatches(across(everything())))) %>%
                   ungroup() %>% # come out of rowwise (not strictly necessary)
                   ### unnest that to separate columns
                   unnest_wider(matches, names_sep = "_") %>%
                   ### do some renaming to make things clearer
                   rename_with( ~ gsub("V", "Choice", .x, fixed = TRUE)) %>%
                   rename_with( ~ gsub("...", "Match", .x, fixed = TRUE)) %>%
                   mutate(across(starts_with("Match"), ~ if_else(.x == 1, "Y", "N"))) %>%
                   ### back into rowwise mode
                   rowwise() %>%
                   ### to get the score
                   mutate(score = matchScore(c_across(starts_with("Choice")))) %>%
                   ungroup() %>% 
                   ### create permutation number
                   mutate(permutationN = row_number()) %>%
                   ### rearrange order of columns
                   select(permutationN, everything()) -> tmpTib3)


tmpTib3 %>%
  as_hux() %>%
  set_position("left") %>% # left align the whole table
  set_bold(row = everywhere, col = everywhere) %>% # everything into bold
  set_align(everywhere, everywhere, "center") %>% # everything centred
  set_align(everywhere, 1, "right") %>% # but now right justify the first column
  map_text_color(by_values("Y" = "green")) %>% # colour matches by text recognition
  map_text_color(by_values("N" = "red"))

permutationN	Choice1	Choice2	Choice3	matches_1	matches_2	matches_3	score
1	1	2	3	Y	Y	Y	3
2	1	3	2	Y	N	N	1
3	2	1	3	N	N	Y	1
4	2	3	1	N	N	N	0
5	3	1	2	N	N	N	0
6	3	2	1	N	Y	N	1

(Sorry: the colour scheme isn’t great on the yellow I’ve used for this blog/site.) We can see that there is, as there will be for any number of objects, only one way of getting all of them matched correctly. There are three ways to get one matched correctly and that leaves two ways of scoring zero correct matches. There are no ways of scoring two correct matches: if you match the first two correctly then you are left with the last one which you then have to put in the correct place.

So nothing very impressive even about getting all three correct: you had a one in six probability of doing that by chance. Let’s go up to n = 4.

n(objects) = 4

Show code

suppressMessages(admisc::permutations(1:4) %>%
                   as.data.frame() %>%
                   as_tibble() %>%
                   rowwise() %>%
                   mutate(matches = list(getMatches(across(everything())))) %>%
                   unnest_wider(matches, names_sep = "_") %>%
                   rename_with( ~ gsub("V", "Choice", .x, fixed = TRUE)) %>%
                   rename_with( ~ gsub("...", "Match", .x, fixed = TRUE)) %>%
                   mutate(across(starts_with("Match"), ~ if_else(.x == 1, "Y", "N"))) %>%
                   rowwise() %>%
                   mutate(score = matchScore(c_across(starts_with("Choice")))) %>%
                   ungroup() %>% 
                   mutate(permutationN = row_number()) %>%
                   select(permutationN, everything()) -> tmpTib4)


tmpTib4 %>%
  as_hux() %>%
  set_position("left") %>%
  set_bold(row = everywhere, col = everywhere) %>%
  set_align(everywhere, everywhere, "center") %>%
  set_align(everywhere, 1, "right") %>%
  map_text_color(by_values("Y" = "green")) %>%
  map_text_color(by_values("N" = "red"))

permutationN	Choice1	Choice2	Choice3	Choice4	matches_1	matches_2	matches_3	matches_4	score
1	1	2	3	4	Y	Y	Y	Y	4
2	1	2	4	3	Y	Y	N	N	2
3	1	3	2	4	Y	N	N	Y	2
4	1	3	4	2	Y	N	N	N	1
5	1	4	2	3	Y	N	N	N	1
6	1	4	3	2	Y	N	Y	N	2
7	2	1	3	4	N	N	Y	Y	2
8	2	1	4	3	N	N	N	N	0
9	2	3	1	4	N	N	N	Y	1
10	2	3	4	1	N	N	N	N	0
11	2	4	1	3	N	N	N	N	0
12	2	4	3	1	N	N	Y	N	1
13	3	1	2	4	N	N	N	Y	1
14	3	1	4	2	N	N	N	N	0
15	3	2	1	4	N	Y	N	Y	2
16	3	2	4	1	N	Y	N	N	1
17	3	4	1	2	N	N	N	N	0
18	3	4	2	1	N	N	N	N	0
19	4	1	2	3	N	N	N	N	0
20	4	1	3	2	N	N	Y	N	1
21	4	2	1	3	N	Y	N	N	1
22	4	2	3	1	N	Y	Y	N	2
23	4	3	1	2	N	N	N	N	0
24	4	3	2	1	N	N	N	N	0

Now we have 24 ways of permuting the objects and still just the one correct matching of all four. As ever it’s impossible to score n - 1, i.e. three here. There are six ways of scoring two correct matches and eight ways of scoring one correct match leaving nine ways of scoring zero correct matches.

Here’s that score breakdown.

Show code

tmpTib4 %>%
  tabyl(score) %>%
  adorn_pct_formatting(digits = 2) %>%
  arrange(desc(score))

score	n	percent
4	1	4.17%
2	6	25.00%
1	8	33.33%
0	9	37.50%

So the chances of getting all four correct by chance alone was p = 1/24 = 0.04, below the conventional p < .05 criterion.

n(objects) = 5

Show code

suppressMessages(admisc::permutations(1:5) %>%
                   as.data.frame() %>%
                   as_tibble() %>%
                   rowwise() %>%
                   mutate(matches = list(getMatches(across(everything())))) %>%
                   unnest_wider(matches, names_sep = "_") %>%
                   rename_with( ~ gsub("V", "Choice", .x, fixed = TRUE)) %>%
                   rename_with( ~ gsub("...", "Match", .x, fixed = TRUE)) %>%
                   mutate(across(starts_with("Match"), ~ if_else(.x == 1, "Y", "N"))) %>%
                   rowwise() %>%
                   mutate(score = matchScore(c_across(starts_with("Choice")))) %>%
                   ungroup() %>% 
                   mutate(permutationN = row_number()) %>%
                   select(permutationN, everything()) -> tmpTib5)


tmpTib5 %>%
  as_hux() %>%
  set_position("left") %>%
  set_bold(row = everywhere, col = everywhere) %>%
  set_align(everywhere, everywhere, "center") %>%
  set_align(everywhere, 1, "right") %>%
  map_text_color(by_values("Y" = "green")) %>%
  map_text_color(by_values("N" = "red"))

permutationN	Choice1	Choice2	Choice3	Choice4	Choice5	matches_1	matches_2	matches_3	matches_4	matches_5	score
1	1	2	3	4	5	Y	Y	Y	Y	Y	5
2	1	2	3	5	4	Y	Y	Y	N	N	3
3	1	2	4	3	5	Y	Y	N	N	Y	3
4	1	2	4	5	3	Y	Y	N	N	N	2
5	1	2	5	3	4	Y	Y	N	N	N	2
6	1	2	5	4	3	Y	Y	N	Y	N	3
7	1	3	2	4	5	Y	N	N	Y	Y	3
8	1	3	2	5	4	Y	N	N	N	N	1
9	1	3	4	2	5	Y	N	N	N	Y	2
10	1	3	4	5	2	Y	N	N	N	N	1
11	1	3	5	2	4	Y	N	N	N	N	1
12	1	3	5	4	2	Y	N	N	Y	N	2
13	1	4	2	3	5	Y	N	N	N	Y	2
14	1	4	2	5	3	Y	N	N	N	N	1
15	1	4	3	2	5	Y	N	Y	N	Y	3
16	1	4	3	5	2	Y	N	Y	N	N	2
17	1	4	5	2	3	Y	N	N	N	N	1
18	1	4	5	3	2	Y	N	N	N	N	1
19	1	5	2	3	4	Y	N	N	N	N	1
20	1	5	2	4	3	Y	N	N	Y	N	2
21	1	5	3	2	4	Y	N	Y	N	N	2
22	1	5	3	4	2	Y	N	Y	Y	N	3
23	1	5	4	2	3	Y	N	N	N	N	1
24	1	5	4	3	2	Y	N	N	N	N	1
25	2	1	3	4	5	N	N	Y	Y	Y	3
26	2	1	3	5	4	N	N	Y	N	N	1
27	2	1	4	3	5	N	N	N	N	Y	1
28	2	1	4	5	3	N	N	N	N	N	0
29	2	1	5	3	4	N	N	N	N	N	0
30	2	1	5	4	3	N	N	N	Y	N	1
31	2	3	1	4	5	N	N	N	Y	Y	2
32	2	3	1	5	4	N	N	N	N	N	0
33	2	3	4	1	5	N	N	N	N	Y	1
34	2	3	4	5	1	N	N	N	N	N	0
35	2	3	5	1	4	N	N	N	N	N	0
36	2	3	5	4	1	N	N	N	Y	N	1
37	2	4	1	3	5	N	N	N	N	Y	1
38	2	4	1	5	3	N	N	N	N	N	0
39	2	4	3	1	5	N	N	Y	N	Y	2
40	2	4	3	5	1	N	N	Y	N	N	1
41	2	4	5	1	3	N	N	N	N	N	0
42	2	4	5	3	1	N	N	N	N	N	0
43	2	5	1	3	4	N	N	N	N	N	0
44	2	5	1	4	3	N	N	N	Y	N	1
45	2	5	3	1	4	N	N	Y	N	N	1
46	2	5	3	4	1	N	N	Y	Y	N	2
47	2	5	4	1	3	N	N	N	N	N	0
48	2	5	4	3	1	N	N	N	N	N	0
49	3	1	2	4	5	N	N	N	Y	Y	2
50	3	1	2	5	4	N	N	N	N	N	0
51	3	1	4	2	5	N	N	N	N	Y	1
52	3	1	4	5	2	N	N	N	N	N	0
53	3	1	5	2	4	N	N	N	N	N	0
54	3	1	5	4	2	N	N	N	Y	N	1
55	3	2	1	4	5	N	Y	N	Y	Y	3
56	3	2	1	5	4	N	Y	N	N	N	1
57	3	2	4	1	5	N	Y	N	N	Y	2
58	3	2	4	5	1	N	Y	N	N	N	1
59	3	2	5	1	4	N	Y	N	N	N	1
60	3	2	5	4	1	N	Y	N	Y	N	2
61	3	4	1	2	5	N	N	N	N	Y	1
62	3	4	1	5	2	N	N	N	N	N	0
63	3	4	2	1	5	N	N	N	N	Y	1
64	3	4	2	5	1	N	N	N	N	N	0
65	3	4	5	1	2	N	N	N	N	N	0
66	3	4	5	2	1	N	N	N	N	N	0
67	3	5	1	2	4	N	N	N	N	N	0
68	3	5	1	4	2	N	N	N	Y	N	1
69	3	5	2	1	4	N	N	N	N	N	0
70	3	5	2	4	1	N	N	N	Y	N	1
71	3	5	4	1	2	N	N	N	N	N	0
72	3	5	4	2	1	N	N	N	N	N	0
73	4	1	2	3	5	N	N	N	N	Y	1
74	4	1	2	5	3	N	N	N	N	N	0
75	4	1	3	2	5	N	N	Y	N	Y	2
76	4	1	3	5	2	N	N	Y	N	N	1
77	4	1	5	2	3	N	N	N	N	N	0
78	4	1	5	3	2	N	N	N	N	N	0
79	4	2	1	3	5	N	Y	N	N	Y	2
80	4	2	1	5	3	N	Y	N	N	N	1
81	4	2	3	1	5	N	Y	Y	N	Y	3
82	4	2	3	5	1	N	Y	Y	N	N	2
83	4	2	5	1	3	N	Y	N	N	N	1
84	4	2	5	3	1	N	Y	N	N	N	1
85	4	3	1	2	5	N	N	N	N	Y	1
86	4	3	1	5	2	N	N	N	N	N	0
87	4	3	2	1	5	N	N	N	N	Y	1
88	4	3	2	5	1	N	N	N	N	N	0
89	4	3	5	1	2	N	N	N	N	N	0
90	4	3	5	2	1	N	N	N	N	N	0
91	4	5	1	2	3	N	N	N	N	N	0
92	4	5	1	3	2	N	N	N	N	N	0
93	4	5	2	1	3	N	N	N	N	N	0
94	4	5	2	3	1	N	N	N	N	N	0
95	4	5	3	1	2	N	N	Y	N	N	1
96	4	5	3	2	1	N	N	Y	N	N	1
97	5	1	2	3	4	N	N	N	N	N	0
98	5	1	2	4	3	N	N	N	Y	N	1
99	5	1	3	2	4	N	N	Y	N	N	1
100	5	1	3	4	2	N	N	Y	Y	N	2
101	5	1	4	2	3	N	N	N	N	N	0
102	5	1	4	3	2	N	N	N	N	N	0
103	5	2	1	3	4	N	Y	N	N	N	1
104	5	2	1	4	3	N	Y	N	Y	N	2
105	5	2	3	1	4	N	Y	Y	N	N	2
106	5	2	3	4	1	N	Y	Y	Y	N	3
107	5	2	4	1	3	N	Y	N	N	N	1
108	5	2	4	3	1	N	Y	N	N	N	1
109	5	3	1	2	4	N	N	N	N	N	0
110	5	3	1	4	2	N	N	N	Y	N	1
111	5	3	2	1	4	N	N	N	N	N	0
112	5	3	2	4	1	N	N	N	Y	N	1
113	5	3	4	1	2	N	N	N	N	N	0
114	5	3	4	2	1	N	N	N	N	N	0
115	5	4	1	2	3	N	N	N	N	N	0
116	5	4	1	3	2	N	N	N	N	N	0
117	5	4	2	1	3	N	N	N	N	N	0
118	5	4	2	3	1	N	N	N	N	N	0
119	5	4	3	1	2	N	N	Y	N	N	1
120	5	4	3	2	1	N	N	Y	N	N	1

So now we have 120 ways of permuting the objects and still just the one correct matching of all of them. Here’s the score breakdown.

Show code

tmpTib5 %>%
  tabyl(score) %>%
  adorn_pct_formatting(digits = 2) %>%
  arrange(desc(score))

score	n	percent
5	1	0.83%
3	10	8.33%
2	20	16.67%
1	45	37.50%
0	44	36.67%

It was impossible to score four matches but getting all five correct was unlikely by chance alone at p = 1/120 = 0.008

Summary

It can be seen that the number of possible ways to permute n objects goes up rapidly as n increases. That increasing number of ways of permuting things means that getting four or more correctly matched is always unlikely at p < .05 regardless of n. There’s a lookup table at https://link.psyctc.org/derangements where you can look up the scores and their probabilities for n <= 30.

Contact me if you are interested in using this and want help

Contact me here

Historical footnote

This was in my ancient derangements.R file that I clearly created while I still had access to S+:

This program differs from a program for S+ only in having to declare a function, factorial() which comes with S+ but not the version of R on which I’m testing this (1.7.1) and in explicitly declaring tmp at the end of all.derangements() since R won’t return it to the console (does return it for assignment) if you just end the function with the assignment to tmp

# factorial <- function(n) {
#   gamma(n+1)
# }

I’ve often wondered which was my first R release, so it was 1.7.1 or earlier. R has long since acquired a factorial() function in the base functions.

Visit count

website hit counter