Data update

Task/Permutation-test/Ada/permutation-test-1.adb

@@ -0,0 +1,62 @@
+with Ada.Text_IO; with Iterate_Subsets;
+
+procedure Permutation_Test is
+
+   type Group_Type is array(Positive range <>) of Positive;
+
+   Treat_Group: constant Group_Type := (85, 88, 75, 66, 25, 29, 83, 39, 97);
+   Ctrl_Group:  constant Group_Type := (68, 41, 10, 49, 16, 65, 32, 92, 28, 98);
+
+   package Iter is new Iterate_Subsets(Treat_Group'Length, Ctrl_Group'Length);
+
+   Full_Group: constant Group_Type(1 .. Iter.All_Elements)
+     := Treat_Group & Ctrl_Group;
+
+   function Mean(S: Iter.Subset) return Float is
+      Sum: Natural := 0;
+   begin
+      for I in S'Range loop
+         Sum := Sum + Full_Group(S(I));
+      end loop;
+      return Float(Sum)/Float(S'Length);
+   end Mean;
+
+   package FIO is new Ada.Text_IO.Float_IO(Float);
+
+   T_Avg: Float := Mean(Iter.First);
+   S_Avg: Float;
+   S:     Iter.Subset := Iter.First;
+   Equal:  Positive := 1; -- Mean(Iter'First) = Mean(Iter'First)
+   Higher: Natural  := 0;
+   Lower:  Natural  := 0;
+
+begin -- Permutation_Test;
+   -- first, count the subsets with a higher, an equal or a lower mean
+   loop
+      Iter.Next(S);
+      S_Avg := Mean(S);
+      if S_Avg = T_Avg then
+         Equal := Equal + 1;
+      elsif S_Avg >= T_Avg then
+         Higher := Higher + 1;
+      else
+         Lower := Lower + 1;
+      end if;
+      exit when Iter.Last(S);
+   end loop;
+
+   -- second, output the results
+   declare
+      use Ada.Text_IO;
+      Sum: Float := Float(Higher + Equal + Lower);
+   begin
+      Put("Less or Equal: ");
+      FIO.Put(100.0*Float(Lower+Equal) / Sum, Fore=>3, Aft=>1, Exp=>0);
+      Put(Integer'Image(Lower+Equal));
+      New_Line;
+      Put("More:          ");
+      FIO.Put(100.0*Float(Higher) / Sum,      Fore=>3, Aft=>1, Exp=>0);
+      Put(Integer'Image(Higher));
+      New_Line;
+   end;
+end Permutation_Test;

Task/Permutation-test/Ada/permutation-test-2.adb

@@ -0,0 +1,16 @@
+generic
+   Subset_Size, More_Elements: Positive;
+package Iterate_Subsets is
+
+   All_Elements: Positive := Subset_Size + More_Elements;
+   subtype Index is Integer range 1 .. All_Elements;
+   type Subset is array (1..Subset_Size) of Index;
+
+   -- iterate over all subsets of size Subset_Size
+   -- from the set {1, 2, ..., All_Element}
+
+   function First return Subset;
+   procedure Next(S: in out Subset);
+   function Last(S: Subset) return Boolean;
+
+end Iterate_Subsets;

Task/Permutation-test/Ada/permutation-test-3.adb

@@ -0,0 +1,34 @@
+package body Iterate_Subsets is
+
+   function First return Subset is
+      S: Subset;
+   begin
+      for I in S'Range loop
+         S(I) := I;
+      end loop;
+      return S;
+   end First;
+
+   procedure Next(S: in out Subset) is
+      I: Natural := S'Last;
+   begin
+      if S(I) < Index'Last then
+         S(I) := S(I) + 1;
+      else
+         while S(I-1)+1 = S(I) loop
+            I := I - 1;
+         end loop;
+         S(I-1) := S(I-1) + 1;
+         for J in I .. S'Last loop
+            S(J) := S(J-1) + 1;
+         end loop;
+      end if;
+      return;
+   end Next;
+
+   function Last(S: Subset) return Boolean is
+   begin
+      return S(S'First) = Index'Last-S'Length+1;
+   end Last;
+
+end Iterate_Subsets;

Task/Permutation-test/Common-Lisp/permutation-test-1.lisp

@@ -1,24 +1,24 @@
 (defun perm-test (s1 s2)
   (let ((more 0) (leq 0)
-	(all-data (append s1 s2))
-	(thresh (apply #'+ s1)))
+   (all-data (append s1 s2))
+   (thresh (apply #'+ s1)))
     (labels
       ((recur (data sum need avail)
-	      (cond ((zerop need)   (if (>= sum thresh)
-				      (incf more)
-				      (incf leq)))
-		    ((>= avail need)
-		       (recur (cdr data) sum need (1- avail))
-		       (recur (cdr data) (+ sum (car data)) (1- need) (1- avail))))))
+         (cond ((zerop need)   (if (>= sum thresh)
+                  (incf more)
+                  (incf leq)))
+          ((>= avail need)
+             (recur (cdr data) sum need (1- avail))
+             (recur (cdr data) (+ sum (car data)) (1- need) (1- avail))))))
 
       (recur all-data 0 (length s1) (length all-data))
       (cons more leq))))
 
 (let* ((a (perm-test '(68 41 10 49 16 65 32 92 28 98)
-		     '(85 88 75 66 25 29 83 39 97)))
+           '(85 88 75 66 25 29 83 39 97)))
        (x (car a))
        (y (cdr a))
        (s (+ x y)))
   (format t "<=: ~a ~6f%~% >: ~a ~6f%~%"
-	  x (* 100e0 (/ x s))
-	  y (* 100e0 (/ y s))))
+     x (* 100e0 (/ x s))
+     y (* 100e0 (/ y s))))

Task/Permutation-test/GAP/permutation-test.gap

@@ -3,47 +3,47 @@ b := [68, 41, 10, 49, 16, 65, 32, 92, 28, 98];
 
 # Compute a decimal approximation of a rational
 Approx := function(x, d)
-	local neg, a, b, n, m, s;
-	if x < 0 then
-		x := -x;
-		neg := true;
-	else
-		neg := false;
-	fi;
-	a := NumeratorRat(x);
-	b := DenominatorRat(x);
-	n := QuoInt(a, b);
-	a := RemInt(a, b);
-	m := 10^d;
-	s := "";
-	if neg then
-		Append(s, "-");
-	fi;
-	Append(s, String(n));
-	n := Size(s) + 1;
-	Append(s, String(m + QuoInt(a*m, b)));
-	s[n] := '.';
-	return s;
+   local neg, a, b, n, m, s;
+   if x < 0 then
+      x := -x;
+      neg := true;
+   else
+      neg := false;
+   fi;
+   a := NumeratorRat(x);
+   b := DenominatorRat(x);
+   n := QuoInt(a, b);
+   a := RemInt(a, b);
+   m := 10^d;
+   s := "";
+   if neg then
+      Append(s, "-");
+   fi;
+   Append(s, String(n));
+   n := Size(s) + 1;
+   Append(s, String(m + QuoInt(a*m, b)));
+   s[n] := '.';
+   return s;
 end;
 
 PermTest := function(a, b)
-	local c, d, p, q, u, v, m, n, k, diff, all;
-	p := Size(a);
-	q := Size(b);
-	v := Concatenation(a, b);
-	n := p + q;
-	m := Binomial(n, p);
-	diff := Sum(a)/p - Sum(b)/q;
-	all := [1 .. n];
-	k := 0;
-	for u in Combinations(all, p) do
-		c := List(u, i -> v[i]);
-		d := List(Difference(all, u), i -> v[i]);
-		if Sum(c)/p - Sum(d)/q > diff then
-			k := k + 1;
-		fi;
-	od;
-	return [Approx((1 - k/m)*100, 3), Approx(k/m*100, 3)];
+   local c, d, p, q, u, v, m, n, k, diff, all;
+   p := Size(a);
+   q := Size(b);
+   v := Concatenation(a, b);
+   n := p + q;
+   m := Binomial(n, p);
+   diff := Sum(a)/p - Sum(b)/q;
+   all := [1 .. n];
+   k := 0;
+   for u in Combinations(all, p) do
+      c := List(u, i -> v[i]);
+      d := List(Difference(all, u), i -> v[i]);
+      if Sum(c)/p - Sum(d)/q > diff then
+         k := k + 1;
+      fi;
+   od;
+   return [Approx((1 - k/m)*100, 3), Approx(k/m*100, 3)];
 end;
 
 # in order, % less or greater than original diff

Task/Permutation-test/Haskell/permutation-test-1.hs

@@ -1,21 +1,21 @@
 binomial n m = (f !! n) `div` (f !! m) `div` (f !! (n - m))
-	where f = scanl (*) 1 [1..]
+   where f = scanl (*) 1 [1..]
 
 permtest treat ctrl = (fromIntegral less) / (fromIntegral total) * 100
-	where
-	total = binomial (length avail) (length treat)
-	less  = combos (sum treat) (length treat) avail
-	avail = ctrl ++ treat
-	combos total n a@(x:xs)
-		| total < 0	= binomial (length a) n
-		| n == 0	= 0
-		| n > length a	= 0
-		| n == length a = fromEnum (total < sum a)
-		| otherwise	= combos (total - x) (n - 1) xs
-				+ combos total n xs
+   where
+   total = binomial (length avail) (length treat)
+   less  = combos (sum treat) (length treat) avail
+   avail = ctrl ++ treat
+   combos total n a@(x:xs)
+      | total < 0 = binomial (length a) n
+      | n == 0 = 0
+      | n > length a = 0
+      | n == length a = fromEnum (total < sum a)
+      | otherwise = combos (total - x) (n - 1) xs
+            + combos total n xs
 
-main =	let	r = permtest
-			[85, 88, 75, 66, 25, 29, 83, 39, 97]
-			[68, 41, 10, 49, 16, 65, 32, 92, 28, 98]
-	in do	putStr "> : "; print r
-		putStr "<=: "; print $ 100 - r
+main =   let   r = permtest
+         [85, 88, 75, 66, 25, 29, 83, 39, 97]
+         [68, 41, 10, 49, 16, 65, 32, 92, 28, 98]
+   in do putStr "> : "; print r
+      putStr "<=: "; print $ 100 - r

Task/Permutation-test/Haskell/permutation-test-2.hs

@@ -1,19 +1,19 @@
 binomial n m = (f !! n) `div` (f !! m) `div` (f !! (n - m))
-	where f = scanl (*) 1 [1..]
+   where f = scanl (*) 1 [1..]
 
 perms treat ctrl = (less,total) where
-	total = binomial (length ctrl + length treat) (length treat)
-	less = length	$ filter (<= sum treat)
-			$ sums (treat ++ ctrl) (length treat)
-	sums x n
-		| l < n || n < 0 = []
-		| n == 0 = [0]
-		| l == n = [sum x]
-		| otherwise = [a + b | i <- [0..n], a <- sums left i, b <- sums right (n - i)]
-			where	(l, l1) = (length x, l `div` 2)
-				(left, right) = splitAt l1 x
+   total = binomial (length ctrl + length treat) (length treat)
+   less = length  $ filter (<= sum treat)
+         $ sums (treat ++ ctrl) (length treat)
+   sums x n
+      | l < n || n < 0 = []
+      | n == 0 = [0]
+      | l == n = [sum x]
+      | otherwise = [a + b | i <- [0..n], a <- sums left i, b <- sums right (n - i)]
+         where (l, l1) = (length x, l `div` 2)
+            (left, right) = splitAt l1 x
 
 main = print $ (lt, 100 - lt) where
-	(a, b) = perms	[85, 88, 75, 66, 25, 29, 83, 39, 97]
-			[68, 41, 10, 49, 16, 65, 32, 92, 28, 98]
-	lt = (fromIntegral a) / (fromIntegral b) * 100
+   (a, b) = perms [85, 88, 75, 66, 25, 29, 83, 39, 97]
+         [68, 41, 10, 49, 16, 65, 32, 92, 28, 98]
+   lt = (fromIntegral a) / (fromIntegral b) * 100

Task/Permutation-test/Haskell/permutation-test-3.hs

@@ -1,26 +1,26 @@
 combs maxsum len x = foldl f [(0,0,1)] x where
-	f a n = merge a (map (addNum n) $ filter (\(l,_,_) -> l < len) a)
-	addNum n (a,s,c)
-		-- anything larger than maxsum is as good as infinity
-		| s + n > maxsum = (a+1, maxsum + 1, c)
-		| otherwise = (a+1, s+n, c)
+   f a n = merge a (map (addNum n) $ filter (\(l,_,_) -> l < len) a)
+   addNum n (a,s,c)
+      -- anything larger than maxsum is as good as infinity
+      | s + n > maxsum = (a+1, maxsum + 1, c)
+      | otherwise = (a+1, s+n, c)
 
-	merge a [] = a
-	merge [] a = a
-	merge a@((a1,a2,a3):as) b@((b1,b2,b3):bs)
-		| a1 == b1 && a2 == b2 = (a1,a2,a3+b3):merge as bs
-		| a1 < b1 || (a1 == b1 && a2 < b2) = (a1,a2,a3):merge as b
-		| otherwise = (b1,b2,b3):merge a bs
+   merge a [] = a
+   merge [] a = a
+   merge a@((a1,a2,a3):as) b@((b1,b2,b3):bs)
+      | a1 == b1 && a2 == b2 = (a1,a2,a3+b3):merge as bs
+      | a1 < b1 || (a1 == b1 && a2 < b2) = (a1,a2,a3):merge as b
+      | otherwise = (b1,b2,b3):merge a bs
 
 permtest a b = (lt, ge) where
-	lt = sum	$ map (\(a,b,c) -> if a == la && b < sa then c else 0)
-			$ combs sa la (a++b)
-	ge = (binomial (la + lb) la) - lt
-	(sa, la, lb) = (sum a, length a, length b)
+   lt = sum $ map (\(a,b,c) -> if a == la && b < sa then c else 0)
+         $ combs sa la (a++b)
+   ge = (binomial (la + lb) la) - lt
+   (sa, la, lb) = (sum a, length a, length b)
 
 binomial n m = (f !! n) `div` (f !! m) `div` (f !! (n - m))
-	where f = scanl (*) 1 [1..]
+   where f = scanl (*) 1 [1..]
 
 -- how many combinations are less than current sum
-main =	print$ permtest	[85, 88, 75, 66, 25, 29, 83, 39, 97]
-			[68, 41, 10, 49, 16, 65, 32, 92, 28, 98]
+main =   print$ permtest   [85, 88, 75, 66, 25, 29, 83, 39, 97]
+         [68, 41, 10, 49, 16, 65, 32, 92, 28, 98]

Task/Permutation-test/Rebol/permutation-test.rebol

@@ -0,0 +1,144 @@
+Rebol [
+    title: "Rosetta code: Permutation test"
+    file:  %Permutation_test.r3
+    url:   https://rosettacode.org/wiki/Permutation_test
+    note:  "Translated from Julia"
+]
+
+;; Splits vector `a` into two sub-vectors based on a block of selected indices.
+;; Elements at positions listed in `sel` go into x; all others go into y.
+;; Returns a two-element block: [x y]
+bifurcate: func [
+    a    [vector!]         ; The source to split
+    sel  [vector! block!]  ; 1-based indices identifying the "selected" partition
+    /local
+        x     ; Will hold elements at the selected indices
+        y     ; Will hold the remaining elements
+        asel  ; Boolean mask, same length as `a`; true = selected, false = remainder
+        i     ; Loop counter
+][
+    x: copy/part a 0 ;; creates an empty vector of the same type like the source
+    y: copy x
+    ; Build a boolean mask initialised entirely to false
+    asel: make bitset! 1 + length? a
+    ; Flip the mask to true at every index listed in sel
+    foreach idx sel [ asel/:idx: true ]
+    ; Walk the mask and route each element of `a` to x or y accordingly
+    repeat i length? a [
+        either asel/:i [
+            append x a/:i   ; Index is selected -> goes to x
+        ][
+            append y a/:i   ; Index is not selected -> goes to y
+        ]
+    ]
+    reduce [x y]  ; Return both partitions as a two-element block
+]
+
+;; Returns all k-element combinations of indices drawn from `lst`.
+;; Uses the classical index-advancement algorithm: maintains a combo block
+;; of k indices and repeatedly advances the rightmost index that still has
+;; room to move, resetting every index to its right to the next consecutive
+;; values.  Each valid state of `combo` is snapshot-copied into `result`.
+combinations: func [
+    lst  [block! vector!] ; Source vector whose indices are combined
+    k    [integer!]       ; Number of elements to choose per combination
+    /local
+        result  ; Accumulator — block of k-element index blocks
+        combo   ; Current combination, represented as k ascending indices
+        n       ; Length of lst, i.e. the upper bound for any index
+        i       ; Cursor: points to the rightmost index still able to advance
+][
+    result: copy []
+    n: length? lst
+
+    ; Edge cases: choosing nothing yields one empty combination;
+    ; choosing more than available yields no combinations at all.
+    if k = 0  [return reduce [result]]
+    if k > n  [return result]
+
+    ; Seed combo with the lexicographically first combination: [1 2 3 ... k]
+    combo: case [
+        k < 0#FF       [#(uint8!  [])]
+        k < 0#FFFF     [#(uint16! [])]
+        k < 0#FFFFFFFF [#(uint32! [])]
+        else           [#(uint64! [])]
+    ]
+    repeat i k [append combo i]
+
+    ; `loop 1` is used as a single-pass block so we can record the first
+    ; combo before entering the advancement loop.
+    loop 1 [
+        append/only result copy combo   ; Record the initial combination
+        forever [
+            ; Scan right-to-left for the rightmost index that can still
+            ; be incremented without exceeding its ceiling (n - k + position).
+            i: k
+            while [i > 0] [
+                if combo/:i < (n - k + i) [break]  ; This index has room — stop here
+                i: i - 1                           ; This index is maxed out — look left
+            ]
+            ; If no index could advance, we have exhausted all combinations.
+            if i = 0 [break]
+            ; Advance the chosen index by one ...
+            combo/:i: combo/:i + 1
+            ; ... then reset every index to its right to the next consecutive
+            ; values, keeping the block strictly ascending.
+            if i < k [
+                loop k - i [
+                    i: i + 1
+                    combo/:i: combo/(i - 1) + 1
+                ]
+            ]
+            append/only result copy combo   ; Record this new combination
+        ]
+    ]
+    result  ; Return the full list of combinations
+]
+
+
+;; Performs a two-sample permutation test to assess whether the observed
+;; difference in means between `treated` and `control` is statistically
+;; surprising under the null hypothesis of no group effect.
+;;
+;; For every possible way to split the pooled data into two groups of the
+;; same sizes as the originals, we check whether the re-split mean difference
+;; beats the observed one.  The counts of splits that do and do not beat it
+;; give an exact p-value numerator (better / (better + worse)).
+permutation-test: function [
+    treated  [vector!]  ; Observed values for the treatment group
+    control  [vector!]  ; Observed values for the control group
+][
+    ; Observed effect: mean difference between the two original groups
+    effect0: treated/mean - control/mean
+    ; Merge both groups into one pool from which all re-splits are drawn
+    pool: append copy treated control
+    tlen: length? treated   ; Re-splits must have the same size as `treated`
+    plen: length? pool      ; Total number of observations
+
+    better: worse: 0   ; Counters for re-splits that beat (or tie/trail) effect0
+
+    ; Iterate over every k-element subset of pool indices, where k = tlen
+    foreach subset combinations pool tlen [
+        ; Partition the pool into two groups matching the original group sizes
+        tc: bifurcate pool subset
+        ; Compare the re-split mean difference against the observed effect
+        either effect0 < (tc/1/mean - tc/2/mean) [
+            ++ better  ; This re-split produced a larger difference
+        ][  ++ worse ] ; This re-split matched or fell below effect0
+    ]
+    reduce [better worse]
+]
+
+; --- Example usage ---
+treated: #(uint8! [85 88 75 66 25 29 83 39 97])
+control: #(uint8! [68 41 10 49 16 65 32 92 28 98])
+
+set [better worse] permutation-test treated control
+tot: better + worse
+
+print  "Permutation test using the following data:"
+print ["Treated:  " treated]
+print ["Control:  " control]
+print ["^/There are" tot "different permuted groups of these data."]
+print ajoin [" " better ", " round/to (100 * better / tot) 0.001 " showed better than actual results."]
+print ajoin [" " worse  ", " round/to (100 * worse  / tot) 0.001 " showed equalivalent or worse results."]

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

@@ -6,8 +6,8 @@ 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])
+   $sumA / double([llength $A]) -
+   ($sumAB - $sumA) / double([llength $AB] - [llength $A])
     }
 }
 
@@ -18,13 +18,13 @@ proc selectCombinationsFrom {k l} {
     set n [expr {[llength $l] - [incr k -1]}]
     for {set i 0} {$i < $n} {} {
         set first [lindex $l $i]
-	incr i
+   incr i
         if {$k == 0} {
             lappend all $first
-	} else {
-	    foreach s [selectCombinationsFrom $k [lrange $l $i end]] {
-		lappend all [list $first {*}$s]
-	    }
+   } else {
+       foreach s [selectCombinationsFrom $k [lrange $l $i end]] {
+      lappend all [list $first {*}$s]
+       }
         }
     }
     return $all
@@ -38,9 +38,9 @@ proc permutationTest {A B} {
     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 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}]