Data commit

Task/Permutation-test/Tcl/permutation-test-1.tcl

@@ -0,0 +1,47 @@
+package require Tcl 8.5
+
+# Difference of means; note that the first list must be the concatenation of
+# the two lists (because this is cheaper to work with).
+proc statistic {AB A} {
+    set sumAB [tcl::mathop::+ {*}$AB]
+    set sumA [tcl::mathop::+ {*}$A]
+    expr {
+	$sumA / double([llength $A]) -
+	($sumAB - $sumA) / double([llength $AB] - [llength $A])
+    }
+}
+
+# Selects all k-sized combinations from a list.
+proc selectCombinationsFrom {k l} {
+    if {$k == 0} {return {}} elseif {$k == [llength $l]} {return [list $l]}
+    set all {}
+    set n [expr {[llength $l] - [incr k -1]}]
+    for {set i 0} {$i < $n} {} {
+        set first [lindex $l $i]
+	incr i
+        if {$k == 0} {
+            lappend all $first
+	} else {
+	    foreach s [selectCombinationsFrom $k [lrange $l $i end]] {
+		lappend all [list $first {*}$s]
+	    }
+        }
+    }
+    return $all
+}
+
+# Compute the permutation test value and its complement.
+proc permutationTest {A B} {
+    set whole [concat $A $B]
+    set Tobs [statistic $whole $A]
+    set undercount 0
+    set overcount 0
+    set count 0
+    foreach perm [selectCombinationsFrom [llength $A] $whole] {
+	set t [statistic $whole $perm]
+	incr count
+	if {$t <= $Tobs} {incr undercount} else {incr overcount}
+    }
+    set count [tcl::mathfunc::double $count]
+    list [expr {$overcount / $count}] [expr {$undercount / $count}]
+}

Task/Permutation-test/Tcl/permutation-test-2.tcl

@@ -0,0 +1,4 @@
+set treatmentGroup {0.85 0.88 0.75 0.66 0.25 0.29 0.83 0.39 0.97}
+set controlGroup   {0.68 0.41 0.10 0.49 0.16 0.65 0.32 0.92 0.28 0.98}
+lassign [permutationTest $treatmentGroup $controlGroup] over under
+puts [format "under=%.2f%%, over=%.2f%%" [expr {$under*100}] [expr {$over*100}]]