steve
/
factor
1
0
Fork 0
Code Issues Pull Requests Releases Wiki Activity

random: implement gamma distribution, fix beta to use it.

db4
John Benediktsson 2012-03-30 19:30:29 -07:00
parent 8e3f0cdeac
commit 2682e7ec7f
1 changed files with 63 additions and 6 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

69
basis/random/random.factor
View File

@ -1,10 +1,11 @@
! Copyright (C) 2008 Doug Coleman. ! Copyright (C) 2008 Doug Coleman.
! See http://factorcode.org/license.txt for BSD license. ! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.c-types alien.data arrays assocs USING: accessors alien.c-types alien.data arrays assocs
byte-arrays byte-vectors combinators fry io.backend io.binary byte-arrays byte-vectors combinators combinators.short-circuit
kernel locals math math.bitwise math.constants math.functions fry io.backend io.binary kernel locals math math.bitwise
math.order math.ranges namespaces sequences sequences.private math.constants math.functions math.order math.ranges namespaces
sets summary system vocabs hints typed ; sequences sequences.private sets summary system vocabs hints
typed ;
IN: random IN: random
SYMBOL: system-random-generator SYMBOL: system-random-generator
@ -129,9 +130,65 @@ ERROR: too-many-samples seq n ;
: pareto-random-float ( alpha -- n ) : pareto-random-float ( alpha -- n )
[ random-unit ] dip [ 1. swap / ] bi@ ^ ; [ random-unit ] dip [ 1. swap / ] bi@ ^ ;
:: (gamma-random-float>1) ( alpha beta -- n )
! Uses R.C.H. Cheng, "The generation of Gamma
! variables with non-integral shape parameters",
! Applied Statistics, (1977), 26, No. 1, p71-74
2. alpha * 1 - sqrt :> ainv
alpha 4. log - :> bbb
alpha ainv + :> ccc
0 :> r! 0 :> z! 0 :> result! ! initialize locals
[
r {
[ 1. 4.5 log + + z 4.5 * - 0 >= ]
[ z log >= ]
} 1|| not
] [
random-unit :> u1
random-unit :> u2
u1 1. u1 - / log ainv / :> v
alpha v exp * :> x
u1 sq u2 * z!
bbb ccc v * + x - r!
x beta * result!
] do while result ;
: (gamma-random-float=1) ( alpha beta -- n )
nip random-unit log neg * ;
:: (gamma-random-float<1) ( alpha beta -- n )
! Uses ALGORITHM GS of Statistical Computing - Kennedy & Gentle
alpha e + e / :> b
0 :> x! 0 :> p! ! initialize locals
[
p 1.0 > [
random-unit x alpha 1 - ^ >
] [
random-unit x neg exp >
] if
] [
random-unit b * p!
p 1.0 <= [
p 1. alpha / ^
] [
b p - alpha / log neg
] if x!
] do while x beta * ;
: gamma-random-float ( alpha beta -- n )
{
{ [ over 1 > ] [ (gamma-random-float>1) ] }
{ [ over 1 = ] [ (gamma-random-float=1) ] }
[ (gamma-random-float<1) ]
} cond ;
: beta-random-float ( alpha beta -- n ) : beta-random-float ( alpha beta -- n )
[ 1. normal-random-float ] dip over zero? [ 1. gamma-random-float ] dip over zero?
[ 2drop 0 ] [ 1. normal-random-float dupd + / ] if ; [ 2drop 0 ] [ 1. gamma-random-float dupd + / ] if ;
{ {
{ [ os windows? ] [ "random.windows" require ] } { [ os windows? ] [ "random.windows" require ] }