# derangements.ssc is a trivial S+ program written by Chris Evans in 2001 # copyright is asserted by me, Chris Evans # Rampton Hospital, Retford, Notts. DN22 0PD Britain # by telephone at [+44|0] 1777 247242 # and 'fax at: [+44|0] 1777 247213 # or http://www.psyctc.org/cgi-bin/mailto.pl?webmaster # like all my shabby programming that I put on the www, this is released under the # "atrribution, share-alike" creative commons licence http://creativecommons.org/licenses/by-sa/1.0/ # what that says is: # You are free: # # * to copy, distribute, display, and perform the work # * to make derivative works # * to make commercial use of the work # # Under the following conditions: # # Attribution. You must give the original author credit. # # Share Alike. If you alter, transform, or build upon this work, you may distribute the resulting work # only under a license identical to this one. # # * For any reuse or distribution, you must make clear to others the license terms of this work. # * Any of these conditions can be waived if you get permission from the author. # If you do change or improve on this (shouldn't be hard as I'm no programmer!) I would hugely appreciate # receiving a copy and your permission to replace this with any improved version with full attribution to you # Ditto if you translate this into another language, human or computer form. # # 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, 385-390. # and if you contact me, I will endeavour to send you a copy of that if it looks unlikely that you'd find other ways # of getting it. all.derangements <- function(n){ cumprob <- prob <- number <- term <- score <- rev(0:n) for (m in 1:n) { i <- m+1 s <- n-m term[i] <- ((-1)^(m))/(factorial(m)) } term[1] <- 1 for (i in 0:n) { s <- i+1 prob[s] <- (sum(term[1:s]))/factorial(n-i) } number <- factorial(n)*prob for (s in 0:n) { m <- n-s i <- m+1 cumprob[i] <- sum(prob[1:i]) } tmp <- cbind(score,number,prob,cumprob) } p.derange.score <- function(score,n){ if (score > n) stop("Score cannot be greater than n") if (score == (n-1)) stop ("Score cannot be n-1") cumprob <- prob <- term <- rev(0:n) for (m in 1:n) { i <- m+1 s <- n-m term[i] <- ((-1)^(m))/(factorial(m)) } term[1] <- 1 for (i in 0:n) { s <- i+1 prob[s] <- (sum(term[1:s]))/factorial(n-i) } for (s in 0:n) { m <- n-s i <- m+1 cumprob[i] <- sum(prob[1:i]) } cumprob[n+1-score] } all.derangements(8) p.derange.score(6,8)