#! /usr/bin/R sink(file="/dev/null") # to stop getting the Hmisc announcement text library(xtable); # libary to output tables in HTML or latex format # derangements.R is a trivial R 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. # # 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) } 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) tmp } sink() # switch output back to stdout tag(HTML) tag(HEAD) tag(TITLE) cat("Probability of a derangement score r from n") untag(TITLE) untag(HEAD) lf(2) tag(BODY, bgcolor = "lime") lf(2) tag(center) cat("

Probability of a derangement score r from n

") comments("Let's start with some testing") prob <- 0 n <- as.numeric(scanText(formData$n)) round <- as.numeric(scanText(formData$round)) if ((trunc(n) != n) || (n < 0)) { cat("

n must be a positive integer, go back and try again!

") prob <- 1 } if (n >= 200) { cat("

n must be <= 200, go back and try again!

") prob <- 1 } if (trunc(round) != round) { cat("

Score must be an integer, go back and try again!

") prob <- 1 } if ((round < 0) | (round > 8)) { cat("

Program only offers rounding to between zero and eight significant digits. Go back and try again!

") prob <- 1 } if (prob) { cat("

Go back and try again!

") cat("CGI script written by Chris Evans using David Firth's excellent GGIwithR package. ") linkto("Contact me if something isn't working right ...", "http://www.psyctc.org/cgi-bin/mailto.pl?chris") ; br() } lf(2) comments("end of testing") if (!prob) { comments("Got into results section") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("") cat("
") cat("Your input") cat("
") now <- system('date +%Y-%m-%d,%T', intern=TRUE) host <- system("echo $REMOTE_ADDR", intern=TRUE) cat("Request from: ") cat("") cat(host, " at", now,"
") cat("
") cat("n: ") cat("") cat(n) cat("
") cat("Significant digits wanted: ") cat("") cat(round) cat("
") cat("Results") cat("
") p <- all.derangements(n) p <- signif(p,round) print(xtable(p),type="html") cat("
") cat("
") cat("Explanation") cat("
That table has four columns: score, number, prob, cumprob.
") cat("
  • score is the score between 0 and ",n,"") cat("
  • number is the number of times that score occurs in the ",n,"! random ways of rearranging ",n,"objects. (n-1) is always impossible as, once you've correctly matched n-2, you can either match the other two incorrectly or correctly. If you've entered a large n you may find that this column is full of blanks or "Inf" as the numbers of possible ways of achieving the score is too huge to be represented easily here.") cat("
  • prob is the probability of achieving exactly this score (it's number/",n,"!") cat("
  • cumprob is the interesting column really: it's the cumulative probability of achieving that score or higher. You'll always find, for n > 4, that a score of 4 or more has a cumprob < .05, i.e. statistically significant by a conventional pre hoc alpha criterion of .05.
") cat("

If you are using this method and publishing the results or finding them of use to you, then ") linkto("I'd love to hear about what you're doing.", "http://www.psyctc.org/cgi-bin/mailto.pl?chris") cat("

") cat("Technicalities") cat("
") cat("Calculation done in R by a CGI script written by Chris Evans using David Firth's excellent GGIwithR package.") cat(" Neither myself, David Firth or anyone in the R team accept responsibility for the results or consequences of their use, the maths of this is fairly easy and spelled out in my publication on the topic and R is very reliable but it's always possible for things to go wrong so think through what you see here carefully before doing anything serious with it.") linkto("Contact me if something isn't working right ...", "http://www.psyctc.org/cgi-bin/mailto.pl?chris") ; br() lf() cat("

") cat("Output produced at ", date()) cat("

") lf() cat("
") } untag(BODY) untag(HTML) lf() sink(paste("/home/xychris0/R/CGIwithR-log/derange.table.R.",as.character(now),sep="")) cat("program = derange.table.R ; host = ",host, "; ", now, "; score = ",score,"; n = ",n,"; p = ",p,"; round = ",round,"\n") sink()