BiasedUrn/0000755000176200001440000000000012640166105012127 5ustar liggesusersBiasedUrn/inst/0000755000176200001440000000000012640160171013101 5ustar liggesusersBiasedUrn/inst/doc/0000755000176200001440000000000012640160171013646 5ustar liggesusersBiasedUrn/inst/doc/UrnTheory.Rtex0000644000176200001440000005013712640160171016457 0ustar liggesusers\documentclass[a4paper]{article} % Note: Remember to edit the .Snw file, not the .tex file! %\VignetteIndexEntry{Biased Urn Theory} %\VignettePackage{BiasedUrn} \usepackage{amsmath} \usepackage{amssymb} % % \usepackage{c:/R/share/texmf/Sweave} \usepackage{Sweave} \begin{document} \title{Biased Urn Theory} \author{Agner Fog} \maketitle \section{Introduction} % Two different probability distributions are both known in the literature as ``the'' noncentral hypergeometric distribution. These two distributions will be called Fisher's and Wallenius' noncentral hypergeometric distribution, respectively. Both distributions can be associated with the classical experiment of taking colored balls at random from an urn without replacement. If the experiment is unbiased then the result will follow the well-known hypergeometric distribution. If the balls have different size or weight or whatever so that balls of one color have a higher probability of being taken than balls of another color then the result will be a noncentral hypergeometric distribution. The distribution depends on how the balls are taken from the urn. Wallenius' noncentral hypergeometric distribution is obtained if $n$ balls are taken one by one. Fisher's noncentral hypergeometric distribution is obtained if balls are taken independently of each other. Wallenius' distribution is used in models of natural selection and biased sampling. Fisher's distribution is used mainly for statistical tests in contingency tables. Both distributions are supported in the {\tt BiasedUrn} package. The difference between the two noncentral hypergeometric distributions is difficult to understand. I am therefore providing a detailed explanation in the following sections. \section{Definition of Wallenius' noncentral hypergeometric distribution} % Assume that an urn contains $N$ balls of $c$ different colors and let $m_i$ be the number of balls of color $i$. Balls of color $i$ have the weight $\omega_i$. $n$ balls are drawn from the urn, one by one, in such a way that the probability of taking a particular ball at a particular draw is equal to this ball's fraction of the total weight of all balls that lie in the urn at this moment. The colors of the $n$ balls that are taken in this way will follow Wallenius' noncentral hypergeometric distribution. This distribution has the probability mass function: % $$ \operatorname{dMWNCHypergeo}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \left( \prod_{i=1}^c \binom{m_i}{x_i} \right) \: \int_0^1 \prod_{i=1}^c (1-t^{{\omega_i}/{d}})^{x_i} \, \mathrm{d}t \;, $$ % $$ \text{where } \: d \:=\: \sum_{i=1}^c \omega_i(m_i-x_i) \,. $$ % $\boldsymbol{x}=(x_1,x_2,\ldots,x_c)$ is the number of balls drawn of each color.\\ $\boldsymbol{m}=(m_1,m_2,\ldots,m_c)$ is the initial number of balls of each color in the urn.\\ $\boldsymbol{\omega}=(\omega_1,\omega_2,\ldots,\omega_c)$ is the weight or odds of balls of each color.\\ $n = \sum_{i=1}^c x_i$ is the total number of balls drawn.\\ $c$ is the number of colors. The unexpected integral in this formula arises as the solution to a difference equation. (The above formula is invalid in the trivial case $n = N$.) \section{Definition of Fisher's noncentral hypergeometric distribution} % If the colored balls are taken from the urn in such a way that the probability of taking a particular ball of color $i$ is proportional to its weight $\omega_i$ and the probability for each particular ball is independent of what happens to the other balls, then the number of balls taken will follow a binomial distribution for each color. The total number of balls taken $n = \sum_{i=1}^c x_i$ is necessarily random and unknown prior to the experiment. After the experiment, we can determine $n$ and calculate the distribution of colors for the given value of $n$. This is Fisher's noncentral hypergeometric distribution, which is defined as the distribution of independent binomial variates conditional upon their sum $n$. The probability mass function of Fisher's noncentral hypergeometric distribution is given by % $$ \operatorname{dMFNCHypergeo}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \frac{\textrm{g}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega})} {\sum\limits_{\boldsymbol{y}\in \: \Xi} \textrm{g}(\boldsymbol{y};\boldsymbol{m},n,\boldsymbol{\omega})}\:, $$ % $$ \text{where } \: \textrm{g}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \prod_{i=1}^c \binom{m_i}{x_i}\omega_i^{\,x_i}\:, $$ % $$ \text{and the domain }\: \Xi \:=\: \left\{\boldsymbol{x}\in\mathbb{Z}^c \,\middle|\, \sum_{i=1}^c x_i = n \: \wedge \: \forall\, i \in [1,c] \: : \: 0 \leq x_i \leq m_i \right\}\:. $$ \section{Univariate distributions} % The univariate distributions are used when the number of colors $c$ is $2$. The multivariate distributions are used when the number of colors is more than $2$. The above formulas apply to any number of colors $c$. The univariate distributions can be expressed by setting $c=2$, $\:x_1=x$, $\:x_2=n-x$, $\:m_1=m$, $\:m_2=N-m$, $\:\omega_1=\omega$, $\:\omega_2=1$ in the above formulas. \section{Name confusion} Wallenius' and Fisher's distribution are both known in the literature as ``the'' noncentral hypergeometric distribution. Fisher's distribution was first given the name extended hypergeometric distribution, but some scientists are strongly opposed to using this name. There is a widespread confusion in the literature because these two distributions have been given the same name and because it is not obvious that they are different. Several publications have used the wrong distribution or erroneously assumed that the two distributions were identical. I am therefore recommending to use the prefixes Wallenius' and Fisher's to distinguish the two noncentral hypergeometric distributions. While this makes the names rather long, it has the advantage of emphasizing that there is more than one noncentral hypergeometric distribution, whereby the risk of confusion is minimized. Wallenius and Fisher are the names of the scientists who first described each of these two distributions. The following section explains why the two distributions are different and how to decide which distribution to use in a specific situation. \section{The difference between the two distributions} % Both distributions degenerate into the well-known hypergeometric distribution when all balls have the same weight. In other words: It doesn't matter how the balls are sampled if the balls are unbiased. Only if the urn experiment is biased can we get different distributions depending on how the balls are sampled. It is important to understand how this dependence on the sampling procedure arises. In the Wallenius model, there is competition between the balls. The probability that a particular ball is taken is lower when the other balls in the urn are heavier. The probability of taking a particular ball at a particular draw is equal to its fraction of the total weight of the balls that remain in the urn at that moment. This total weight depends on the weight of the balls that have been removed in previous draws. Therefore, each draw except the first one has a probability distribution that depends on the results of the previous draws. The fact that each draw depends on the previous draws is what makes Wallenius' distribution unique and makes the calculation of it complicated. What happens to each ball depends on what has happened to other balls in the preceding draws. In the Fisher model, there is no such dependence between draws. We may as well take all $n$ balls at the same time. Each ball has no ``knowledge'' of what happens to the other balls. For the same reason, it is impossible to know the value of $n$ before the experiment. If we tried to fix the value of $n$ then we would have no way of preventing ball number $n+1$ from being taken without violating the principle of independence between balls. $n$ is therefore a random variable and the Fisher distribution is a conditional distribution which can only be determined after the experiment when $n$ is known. The unconditional distribution is $c$ independent binomials. The difference between Wallenius' and Fisher's distributions is low when odds ratios are near 1, and $n$ is low compared to $N$. The difference between the two distributions becomes higher when odds ratios are high and $n$ is near $N$. Consider the extreme example where an urn contains one red ball with the weight 1000, and a thousand white balls each with the weight 1. We want to calculate the probability that the red ball is not taken when balls are taken one by one. The probability that the red ball is not taken in the first draw is $\frac{1000}{2000} = \frac 12$. The probability that the red ball is not taken in the second draw, under the condition that it was not taken in the first draw, is $\frac{999}{1999} \approx \frac 12$. The probability that the red ball is not taken in the third draw, under the condition that it was not taken in the first two draws, is $\frac{998}{1998} \approx \frac 12$. Continuing in this way, we can calculate that the probability of not taking the red ball in $n$ draws is approximately $2^{-n}$ for moderate values of $n$. In other words, the probability of not taking a very heavy ball in $n$ draws falls almost exponentially with $n$ in Wallenius' model. The exponential function arises because the probabilities for each draw are all multiplied together. This is not the case in Fisher's model where balls may be taken simultaneously. Here the draws are independent and the probabilities are therefore not multiplied together. The probability of not taking the heavy red ball in Fisher's model is approximately $\frac{1}{n+1}$. The two distributions are therefore very different in this extreme case. \vskip 5mm The following conditions must be fulfilled for Wallenius' distribution to be applicable: % \begin{itemize} % \item Items are taken randomly from a finite source containing different kinds of items without replacement. % \item Items are drawn one by one. % \item The probability of taking a particular item at a particular draw is equal to its fraction of the total weight of all items that have not yet been taken at that moment. The weight of an item depends only on its kind (color) $i$. (It is convenient to use the word ``weight'' for $\omega_i$ even if the physical property that determines the odds is something else than weight). % \item The total number $n$ of items to take is fixed and independent of which items happen to be taken. % \end{itemize} \vskip 5mm The following conditions must be fulfilled for Fisher's distribution to be applicable: % \begin{itemize} % \item Items are taken randomly from a finite source containing different kinds of items without replacement. % \item Items are taken independently of each other. Whether one item is taken is independent of whether another item is taken. Whether one item is taken before, after, or simultaneously with another item is irrelevant. % \item The probability of taking a particular item is proportional to its weight. The weight of an item depends only on its kind (color) $i$. % \item The total number $n$ of items that will be taken is not known before the experiment. % \item $n$ is determined after the experiment and the conditional distribution for $n$ known is desired. % \end{itemize} \section{Examples} % The following examples will further clarify which distribution to use in different situations. \subsection{Example 1} You are catching fish in a small lake that contains a limited number of fish. There are different kinds of fish with different weights. The probability of catching a particular fish is proportional to its weight when you only catch one fish. You are catching the fish one by one with a fishing rod. You have been ordered to catch $n$ fish. You are determined to catch exactly $n$ fish regardless of how long time it may take. You are stopping after you have caught $n$ fish even if you can see more fish that are tempting you. This scenario will give a distribution of the types of fish caught that is equal to Wallenius' noncentral hypergeometric distribution. \subsection{Example 2} You are catching fish as in example 1, but you are using a big net. You are setting up the net one day and coming back the next day to remove the net. You count how many fish you have caught and then you go home regardless of how many fish you have caught. Each fish has a probability of getting into the net that is proportional to its weight but independent of what happens to the other fish. This scenario gives Fisher's noncentral hypergeometric distribution after $n$ is known. \subsection{Example 3} You are catching fish with a small net. It is possible that more than one fish can go into the net at the same time. You are using the net multiple times until you have at least $n$ fish. This scenario gives a distribution that lies between Wallenius' and Fisher's distributions. The total number of fish caught can vary if you are getting too many fish in the last catch. You may put the excess fish back into the lake, but this still doesn't give Wallenius' distribution. This is because you are catching multiple fish at the same time. The condition that each catch depends on all previous catches does not hold for fish that are caught simultaneously or in the same operation. The resulting distribution will be close to Wallenius' distribution if there are only few fish in the net in each catch and you are catching many times. The resulting distribution will be close to Fisher's distribution if there are many fish in the net in each catch and you are catching few times. \subsection{Example 4} You are catching fish with a big net. Fish are swimming into the net randomly in a situation that resembles a Poisson process. You are watching the net all the time and take up the net as soon as you have caught exactly $n$ fish. The resulting distribution will be close to Fisher's distribution because the fish swim into the net independently of each other. But the fates of the fish are not totally independent because a particular fish can be saved from getting caught if $n$ other fish happen to get into the net before the time that this particular fish would have been caught. This is more likely to happen if the other fish are heavy than if they are light. \subsection{Example 5} You are catching fish one by one with a fishing rod as in example 1. You need a particular amount of fish in order to feed your family. You are stopping when the total weight of the fish you have caught exceeds a predetermined limit. The resulting distribution will be close to Wallenius' distribution, but not exactly because the decision to stop depends on the weight of the fish you have caught so far. $n$ is therefore not known exactly before the fishing trip. \subsection{Conclusion} These examples show that the distribution of the types of fish you catch depends on the way they are caught. Many situations will give a distribution that lies somewhere between Wallenius' and Fisher's noncentral hypergeometric distributions. An interesting consequence of the difference between these two distributions is that you will get more of the heavy fish, on average, if you catch $n$ fish one by one than if you catch all $n$ at the same time. These conclusions can of course be applied to biased sampling of other items than fish. \section{Applications} % The biased urn models can be applied to many different situations where items are sampled with bias and without replacement. \subsection{\tt Calculating probabilities etc.} Probabilities, mean and variance can be calculated with the appropriate functions. More complicated systems, such as the natural selection of animals, can be treated with Monte Carlo simulation, using the random variate generating functions. \subsection{\tt Measuring odds ratios} The odds of a sampling process can be measured by an experiment or a series of experiments where the number of items sampled of each kind (color) is counted. It is recommended to use sampling with replacement if possible. Sampling with replacement makes it possible to use the binomial distribution, whereby the calculation of the odds becomes simpler and more accurate. If sampling with replacement is not possible, then the procedure of sampling without replacement must be carefully controlled in order to get a pure Wallenius' distribution or a pure Fisher's distribution rather than a mixture of the two, as explained in the examples above. Use the {\tt odds} functions to calculate the odds ratios from experimental values of the mean. \subsection{\tt Estimating the number of items of a particular kind from experimental sampling} It is possible to estimate the number of items of a particular kind, for example defective items in a production, from biased sampling. The traditional procedure is to use unbiased sampling. But a model of biased sampling may be used if bias is unavoidable or if bias is desired in order to increase the probability of detecting e.g. defective items. It is recommended to use sampling with replacement if possible. Sampling with replacement makes it possible to use the binomial distribution, whereby the calculation of the number of items becomes simpler and more accurate. If sampling with replacement is not possible, then the procedure of sampling without replacement must be carefully controlled in order to get a pure Wallenius' distribution or a pure Fisher's distribution rather than a mixture of the two, as explained in the examples above. The value of the bias (odds ratio) must be determined before the numbers can be calculated. Use the functions with names beginning with ``{\tt num}'' to calculate the number of items of each kind from the result of a sampling experiment with known odds ratios. \section{Demos} % The following demos are included in the {\tt BiasedUrn} package: \subsection{\tt CompareHypergeo} % This demo shows the difference between the hypergeometric distribution and the two noncentral hypergeometric distributions by plotting the probability mass functions. \subsection{\tt ApproxHypergeo} % This demo shows shows that the two noncentral hypergeometric distributions are approximately equal when the parameters are adjusted so that they have the same mean rather than the same odds. \subsection{\tt OddsPrecision} % Calculates the precision of the {\tt oddsWNCHypergeo} and {\tt oddsFNCHypergeo} functions that are used for estimating the odds from a measured mean. \subsection{\tt SampleWallenius} % Makes 100,000 random samples from Wallenius noncentral hypergeometric distribution and compares the measured mean with the theoretical mean. \subsection{\tt UrnTheory} % Displays this document. \section{Calculation methods} % The {\tt BiasedUrn} package can calculate the univariate and multivariate Wallenius' and Fisher's noncentral hypergeometric distributions. Several different calculation methods are used, depending on the parameters. The calculation methods and sampling methods are documented at \\ {\tt http://www.agner.org/random/theory/}. \section{References} \noindent Fog, A. (2008a). Calculation Methods for Wallenius' Noncentral Hypergeometric Distribution. {\it Communications in Statistics, Simulation and Computation}. Vol. 37, no. 2, pp 258-273. \vskip 3mm % \noindent Fog, A. (2008b). Sampling Methods for Wallenius' and Fisher's Noncentral Hypergeometric Distributions. {\it Communications in Statistics, Simulation and Computation}. Vol. 37, no. 2, pp 241-257. \vskip 3mm % \noindent Johnson, N. L., Kemp, A. W. Kotz, S. (2005). {\it Univariate Discrete Distributions}. Hoboken, New Jersey: Wiley and Sons. \vskip 3mm % \noindent McCullagh, P., Nelder, J. A. (1983). {\it Generalized Linear Models}. London: Chapman \& Hall. \vskip 3mm % \noindent {\tt http://www.agner.org/random/theory/}. \end{document} BiasedUrn/inst/doc/UrnTheory.pdf0000644000176200001440000062564112640160171016316 0ustar liggesusers%PDF-1.5 % 3 0 obj << /Length 2703 /Filter /FlateDecode >> stream xڭYK۸Whbjœa+NU4[MEI#GDۓ_~ HqftaF$h4J9Sf4Brvxz5_)^y?PL)Q;z^Z3_uG`]auq@D<a*+~Evk_, ]kWG?13-Y9f cKfnZx_3s5_(m28TgxhXY-RP^ztm+\kYpg u(gQUvHq@şʄ*<1iC3*@-| >x: =iX no`OU26Tŏd<۞A{vmvv8G-=<#w_h*m 1_8g(ikI0Z^݉EY+yx LCzU f)󧹷v"U:<-[vVcqq&[~bdSNQ|Pܧ7{(qs:Ea|}8OM| (lHY@J$;C`&4q ހF1{!=#G-=IC^С$Y(J ;oҴD0ӱvR {,Sn ‘(@ɿ'Tpu4? &Wy >,KmVզW(U0i3>G={J$L.،ҭ@gL JzXR]mU0%jdw"݉3wB۲Dqt7ҚakRQSz5Tl]nєvlݴ.G[ɂUa~w"!Rߎ ' f#K uTzj$A\V&5hp|7q`8$ބ"ĺ9%LaoH'#iue`v*`le$x&$:s:^Orಞe%YT1뼏0ȴxiH<2]Y4kvu(Jڞ `J*\&qL&o/HK~=m{>YbD6&\1h_xa7N[W|E͞WdX9Dc,_QDYDDlDUr_cl&OLB.(b~ѢաQTk)ўl$ymٹEIDIMM03F%k V[*QSH#^R///5g.ʗ}pSk]Kqځ8Rpe=M elB$]OB0eA5S/Jx>ߝ +@2*x~`8tʔDJQWpL'luw-i'&]!vc 'm_ߔ'4 # z͈FUFɻzv'#!(..N7yKޤa`]f"8>x )_H偆H Bj qdA9,rSagvm7A?lNn:5 ,.hXL'(H =Md78&`ήoet1zUr⁾O/䘐{|91zJwYO> endobj 1 0 obj << /Font << /F60 4 0 R /F19 5 0 R /F67 6 0 R /F8 7 0 R /F11 8 0 R /F74 9 0 R /F10 10 0 R /F51 11 0 R /F1 12 0 R /F7 13 0 R /F14 14 0 R /F9 15 0 R >> /ProcSet [ /PDF /Text ] >> endobj 19 0 obj << /Length 3244 /Filter /FlateDecode >> stream xn_%2~Ipz=h^ebI>ߙ!K(ɱ탽ZrŸޟ֏ VTIF6fU?}_|N?o(>Q`G<žGrMi >,8 3HH`V31L 3H|8sZ$Esdf3Nq.&`.eD6+)nT|䆷Hɼec7g݄.1̨z7 nYX gk2yTJyY+R4M)4SapB>@-5 DXZ%]jA_Ƈˏ7qGr+vɥ7܍37xO:~|gHaM[_S„Or|bz 8A}=U5~Z9S6 TPY{,,wyWaYvyXȅ=<ƿB~ Bȓ,1-F~N0b_Ny9Q/M_JjU Ы@6bXo9~V@Iw5Q`΁7zg͌P~„A‚d5*6j*!}sQUJ.%RvB䔐qTAU*/" rf|NI_gwbLR@xϓ&^ΣPm@``>~F.60iuԊMZH.L=@ >MohSUg0q}hI(.AIde(&~iC/yΔ5xȄeo2&թIE|&yzwnptulsj_rm`o,C*ٓ:f3zXcF.\D2j?(TD;y޳|^9y4D3$gO*L&}f Ueft:9\C(`K_!Cx)/ 9DYPkq^5e9HMؐkS|Drn-P q0%7߱F%uM'IC$0&m6/Lڪ2x͡U2I VJğLj]L~I[Hd sbLl ?'] l"CFFuWrkW>MCQiN|`p&K!;iOdgi,~hy,<[1̒^NFq-.7ETpqْckImiDk4ρ_.~6ܭrjYGO"e3Lih2@٤d.S{.'bZ1iy]2q"P@Q$;2H?}? /UEB|mUGL߮zXACm1/~ *­ZKexPBXt3` V.}Gfޘޟr;@FR01[|G0 6)з{]B`t=ɟO~vgrl}X2QĽ-S>EAӅ(1U8[ǂǙ񡵐4x>OŐ앮 SXWЊI۞(L|=^4UXG^?Wv_ It y'l֕@j!6ZbJ9l7Awqޏ ^3PWy!y=x+tx2 ),!όLj]QJ΂+N]_W1ON.u]6%5V6Y[.G^v9LY(!Rއ M1! dM&H*O+= |D*NPns,R*e9 ^=SEe*WӔGjwV򵨉e(s,5~qb)PuT(> hNᆊѱ:+"Lr$0eJmyt57BIy Fۢbt Cq̇DYАWZV=bcۘAV J󯚷Ge = W:Ujv,{/gNYO0GPaQ=ito. ]aXK`8S^e1)z7ej^QzK:QG"ϳ 2,5}5.lf?W?ɔ EG ~_盲0w]iK]WzmҼtQ&vmo3*:v 1gt1[ބwݙ/mBzo1 J58, endstream endobj 18 0 obj << /Type /Page /Contents 19 0 R /Resources 17 0 R /MediaBox [0 0 595.276 841.89] /Parent 16 0 R >> endobj 17 0 obj << /Font << /F8 7 0 R /F11 8 0 R /F10 10 0 R /F1 12 0 R /F7 13 0 R /F14 14 0 R /F51 11 0 R /F67 6 0 R /F52 20 0 R /F13 21 0 R /F9 15 0 R /F44 22 0 R >> /ProcSet [ /PDF /Text ] >> endobj 25 0 obj << /Length 3413 /Filter /FlateDecode >> stream xڍrPPe̻ǖx9:qЋbNzչdM9 WVζb~*?n9B0希rU#5F"uA:oCA|:` MA2]'ss3іCA>DfA$1rƝ'meyu(( e<`**P&UB$ " |1y(pev)E`n7L,bJH3sgZ~-kW!;lL7d)e“͚{Y>qfTT1 nx$8C/s;.UC42%?QZw%ތi`N\u|@wRpc=؊}Å. ȓpzS|wMizG@CLd*qo\!p;:1'a[k+Twh̘>ym hއC ٦u][qT+~?Gm7tp_` i*6UܗY|xDwNu ;j6.f{2w=" ; /)oɿI -u5RME6b2.j^jOuڥLuړLP66PmR5kupY|MD7`1@\ F2J@#I< fڇ& :X>j+ 8wd^z/y3Pju! RG(rA%7UHb4w#Wau8W@c"-8O X/w0;0OeX91Npd:SPzdsV?Y,j.:0[E^{m= ʕqTjyk=N id9aW[qi4n'ANf9|CTT޷Vε{\N/%p܀\w^"7jL 7F}M#RЙ9ތVܜX0=~t*Oz8}2MXBvg>=,_ҲᲽTrX (E('hn|J2xh/Y\՝G\| ge8]Af/•C9Xw[oN\>Ի:@FZUZ2J1I ]ֱ)DZLS笇-q/'S3iR!§ˏ=y^NfyNǿ \Ia'"q&ʧoً(هiw&;4@HU1Ӽ&JOf}Uoﻰ;ޫ Ə; ZF&;U.E~[2O8e?5)Nͫb>w'Ⱥ_&Iߕ& 0r @rx%٩mѭGҺZvTJ-MUmrpR ,]s̱^}>sW#٬¶c_-4I=[RԞG΀|~n.ŀůvUNeoe_Lͽvvu*)W ԩ|J:enw,Ѕ"I > endobj 23 0 obj << /Font << /F8 7 0 R /F67 6 0 R /F11 8 0 R >> /ProcSet [ /PDF /Text ] >> endobj 28 0 obj << /Length 2892 /Filter /FlateDecode >> stream xZK7ϯl櫻 %5ֹ;@q=R#D~XUl91rY, OlHj}]3U۸0_͌T6h+3_~/?3 SuP-7?gKxL+׆KJPAs3͏7_T[U6wa֪5NV͜i9%9I|W _qvҘWd򃟟RSۻW[3o'h{X ֆs>.NwmlK6B쬏eR6w|=4e&|Y.idGE"H; ^%V][*'B=_@s'M 3UObԡ[??ᕂ\ ymGcqڗ:{& v$$F}҄DCgXPӴi>H䰤܀`?OL蜘 G4_ n/[% B th9F98/A-:pεVɖVl(ݒ뮮R[-&l5N9cWl)Qʯ-U-aOK%Qu`7hG#4?-8cTiki״Ec\wbfH'֫8R(lW47YI$d&ef`ʆ2 ؝3e|9' W#O&U)]W~Wȟ&t$hU~m 2:X+ =j ;ZƎ+'t[UFQ= DtNʶcFL51$x(谌pBiKC@5&eFʕ:A|v$Xx" E_=%݋WQ>"g>lk38 i1EqKqӭg(& =  ku|종Rx!Dr(v]^K)!hϬ[3 @Nϴض&z-𔏨ndi;vAnO}OW^VŃZ?hܕv h6]dw`&v&81BqG#zEG*1wS\Gq!VU;,nf1M=5 jML,&Hxšn|6L=b!zw>) h))!h64fAb:BO+!Jc:X3 SCwڹ6Nq"}<#eE"q믤de!jwU5G?Ѫ8S8"yb7s6Qچ1^TUe5GӁJy\Bu۲t~rp̘ȦXcns;Nb3o+]geCo6^2Mל쭋bW|>JAdލ ?oΞi#^^6>P;ag,7^?p=Mqi.L2 hqչ^!@XkHg?VPMW3m=; DqG%'|Sn&]f&4?B|_SٲH1UfFqAԄ$ `MJ¦F@ }^=F2\O)M\nyAӉS͗j7;\ r@HM$%X򄒰iڶ"8R{%2XpE؍Yc8eYg)B;Dob%)Cxta&r@7v?V 2U 1oJ0 Gϱa(B얂NZ 9+#G0b&-=ggaftH=- u ;I$V3\cSO|]N)P?ca9lC64hSWrL54vˌhn?e_ɻ<.ce.8.7B q6SLG9B/tJ (GHt98U !s(f#yj|Gs8aoh\p s9Cj=)W F+Sh"V9>C`0a)7 ?7'o8KN"r/IkZLhα(eș䷗y5Ww*fw+ݎo!07;Oׁ6K%pWL1ִ'D!m10&MClܷM}ݜSGbFϋ\<׬lƿTˣ~fN_kRՖd xGo|4?,I$ƔT'm\\R$tzoĂsV&'0>H OULd6ja 3l l̦HklPA쇢~X(෱5|v2䘺 ^쒝/n0{F nUN35>7T>| p } vY럥19Cc4vOCh~kB$>UBf?ߚF7dٗ^ʖa!Oe;ON9)mCy'@tӥ/m'n9xZO5,>?.&{wtB m{(fe%%T&:dS7DKwH endstream endobj 27 0 obj << /Type /Page /Contents 28 0 R /Resources 26 0 R /MediaBox [0 0 595.276 841.89] /Parent 16 0 R >> endobj 26 0 obj << /Font << /F7 13 0 R /F8 7 0 R /F14 14 0 R /F11 8 0 R /F13 21 0 R /F10 10 0 R /F76 29 0 R >> /ProcSet [ /PDF /Text ] >> endobj 32 0 obj << /Length 2509 /Filter /FlateDecode >> stream xڥZKϯV$-K6$$eOOS$eYE=H*^}?UVkd*)ReE|60ki5#[Skӳ5@/{\|z:ώkhWpx?g3npAøO`x6xWoq]4ξ"ۻac2޿Ȋ-W˥vi |AVYƬr >:|~0Q*ȍJ,sG gg 3) S$"Zn]@/=0) Vx=o# ^i*c23#GE\Coyx\l+ Y`{ƿ*-/x T=%er/WV1/W!wCm{s]s{z- 3gy0c%=I`LH$ ׽VBgwm uYܞҮj  09=9Zss <9٨@Chxـg= :cC6tdM4ҵpp|j~ժg/]C]Q^B@);;/p )璕ӟNۊr |NRDuJxΏs |i~ܨݒ'krc07{tɎzċ=ρmn8%fMxJʪܩ:o? )q*&Cͦer\6 y^A؆Ϋyi`m);Pp ꖳqλ ⑵5($sa71G.@F_ݢξg#>iN)pi.>pΫWCan{찯Ɓ*`E\U"` Kv $@Ej-i7uu =2E;!?:ﺚ,j6AeηMfEҺpK5Vt\ދƂ`c`le^2 W"2lh5+5ʅ[ /+S+0cV1ON>f*z.!xpDS){X}دZlSh٨y+~)Ow\Gxt&4,LG"wLc\1B{+⨫ \yZ1YR>ap;ApkQw!7ĥsđޏ@ƍ@f~䍔:%nܮG\!6MnJ\@?piP OD& ]OjXb#mE>@Z=Gjm=dFCP<./u^S}`ɋǁ=PP@՛V16`H<(| ڇ nH p NCÇ.4G.op8*8 ڸyfwR^#s7]#+#UU AIZa ?YbM「ש<]}g`zOF) 4+36CQ:u`UD?)ȦyBNno{]e}7 *D $2Kyv`iWaLEI)&pB3AnZE8 zBrǗpR'>B < ]v:[j( ƕ_cJX:r =>i'}jWk?Zq˝nEy+1΋ʯB;V{ AqnY5ADvU!(das=)%[3@$v#\\!%qJJĘ"N aѰ~,hnLU6Tz.bm`N7SMD+|.~?3,sq ~^#ǔg[ߤ!jY!Bd$1Bwg> endobj 30 0 obj << /Font << /F67 6 0 R /F8 7 0 R /F11 8 0 R >> /ProcSet [ /PDF /Text ] >> endobj 35 0 obj << /Length 2703 /Filter /FlateDecode >> stream xڍnF_[@R,Ǥ c &s(jAK"J[k)ۇjyUӧM>-no}a1~)K43{\ZL'@}^+&2D'F7in80߾pkt3@ ǥm/L$}ŵ~ oE%ɔeRTY7HD{HKpKn"3xH{hdȋ+Ǖ~!YEc&09rpҰM≮Ӊ$]y((i^OUZ'h oQ 뢭+p#Y!G@q$:ȭU(_4RZ'E%=M1NU#l̀8TQ` e. mSs9;&3 .Z N24D-"r=%Ev1ƭg#@}:1 L;Uwe 4ݾg; [@mڣF֗ڠ9 N>0x9I ف@ )3Cp&PlRncͲʓg"u;i~TfaScȋЕ#q#sA'׆2WAʥs(m\/N^T:#}E'uLama'DTT+pB LI 8D)oQJϣ 2 CMRDu)41Mf . XiQ@E̼2Nۆ8iՍe%mTތra,/ ijA5Ȫ&&-y͞vφE Htџ 45JFиN&(E\M₺+)&RG+"OFO^z= k)(M>\=s.&cq>RLX͜}ބ2j\I׀8({m]Z[d:ut+=͊ܓ~ Ҳp˵ mkPZU` Fq'O7Wny/Q{4)].@o<*6'J%RC@ҩwn@5q:ҝ7nMwQ)9y\b>6;CgwF1a#(#|‹_I6&nTMxv`,A#iѣ"r I̐Uuak};{"sd?S<.ҸT7NZsŨCm0ɷ' b(avq%ά'L1*F_D53Ĺ;Teb? қ,UD82EO`%]أs_Rvav)S"u䈴V$b3 r[ْIZ*$AcgY@9܊8.sIݼ)DäB+{(-Lx5!&Ť/(ohM 0^)#5&/>NJVvG7hC߫rQGZ]o}\: ȉL0vSө،2+m~* >bÔF3tp9ҳZ\u e䃘%x':B†@-4-DHn].}lF鷮HTEgt.<}^iwCMqNp>&\?"II^n>o[pcG"2W|`'tbX~.P085GЬ9ܑ n6IaKH0+ŭO>}?FH/ endstream endobj 34 0 obj << /Type /Page /Contents 35 0 R /Resources 33 0 R /MediaBox [0 0 595.276 841.89] /Parent 16 0 R >> endobj 33 0 obj << /Font << /F8 7 0 R /F11 8 0 R /F67 6 0 R /F84 36 0 R >> /ProcSet [ /PDF /Text ] >> endobj 39 0 obj << /Length 2318 /Filter /FlateDecode >> stream xڥYK6ϯ07+NA`@:agMmIdg֓l{EbՋzբ")IEIv,s,am##vJe?j颇U^o͙{/}(pDiY-b^&)$W]Z v :nniQQa==N$}נhɋ(Shs}F B\/r5EYU&wD]DwwFr &xRGUix RQ]qTR#j-(i'gRl($R{Day8 a:`qBֽݒ>a'&hi [ 29T9D(?"i%X*J+gxAҙr0G=a@a%{ihIh 4' fXB1*Og=o>b'4-yE;I=I6O;ZnZ|Q[X'd.5j¯(19;.}ƢglGWs܉'Op_ɾ#4RfJS_nw A+ ~jd%}mrB?|dJ<'>Qf I;E h8 k~IڏݳS p>Ό>y<&RX0PW%rk Pʌh t}$Ny#BgKE=xJ}?rj16[`k!=P*8D;nàk3UhlM4 _L1yTֱ7p3aMwsN4*lGVU:7tU1=`1y}r<:<ɺZ`I5= |ȏHb] |ROj,JBk4DTV9~0\``n*xc`T+f12P2ۋE j\(\UdRE{-j9"D8Jc Nq䱞_.-4,5rw5/_]|ϰ2rb/'FƢ@,Atd9`C(ԏ5NgTȨ.* XJXX=9ڧ %ӊ`)K2MV$:~W{,"KW3ɵ/G?v‹L>N% ԔiwL$moI'KF1dA[;x =heHA%WUzK˨ ~r,?2V$VIdL-B3Q'_~*RH=tYrB ;p>AHSE|!懋>ξ_~O JY6 ;45KBgǬ2aMO"t~k(ճR:;;U?7YW]u] wի{&ˎ[v<,<>`8&[MD?*> endobj 37 0 obj << /Font << /F8 7 0 R /F74 9 0 R /F67 6 0 R /F84 36 0 R >> /ProcSet [ /PDF /Text ] >> endobj 43 0 obj << /Length 1313 /Filter /FlateDecode >> stream xVIsFWp*޴mƉrI)ø(dĐOqT5¨>I'75džyd8USYq4ɯV@u."i lEs\86>gFCHR *7p4C{c^$;STd3㫡ktlJ/+Iۤ^.Pz+E#5&+ݍ] uźkTj[JqECus|,Pk^2+0%ܜkƢRVnڲzEEnwJd>Fֹ t͙TjIgߛ?a诶=-5A}Z:nԊ|DέEιw;x]kZڒ tpZ5TnF55ѷXw9At}T}jҴ`)-ǜD+0wk!_:= Gw=-t$iʗF N4Rd2 EfhXG@2I.,-%eHX sfI ̖h-Z̪Rc㷸Kl~-H ,jſPdBM/!d9eYWd0[ST{Հ]N,\5"`;dzؽaD7@;|9Ŝ%4}_@g} :X> >6N]y :,& 8@{`gʘrB\%s:1>0ݣ euـ9z<(`Gzfp2K> endobj 41 0 obj << /Font << /F67 6 0 R /F84 36 0 R /F8 7 0 R /F74 9 0 R /F86 44 0 R >> /ProcSet [ /PDF /Text ] >> endobj 45 0 obj [306.7 357.8 306.7 511.1 511.1 511.1 511.1 511.1 511.1 511.1 511.1 511.1 511.1 511.1 306.7 306.7 306.7 766.7 511.1 511.1 766.7 743.3 703.9 715.6 755 678.3 652.8 773.6 743.3 385.6 525 768.9 627.2 896.7 743.3 766.7 678.3 766.7 729.4 562.2 715.6 743.3 743.3 998.9 743.3 743.3 613.3 306.7 514.4 306.7 511.1 306.7 306.7 511.1 460 460 511.1 460 306.7 460 511.1 306.7 306.7 460 255.6 817.8 562.2 511.1 511.1 460 421.7 408.9 332.2 536.7 460 664.4 463.9 485.6 408.9] endobj 46 0 obj [514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6 514.6] endobj 47 0 obj << /Length 149 /Filter /FlateDecode >> stream x3135R0P0Bc3csCB.c46K$r9yr+p{E=}JJS ]  b<]00 @0?`d=0s@f d'n.WO@.sud endstream endobj 29 0 obj << /Type /Font /Subtype /Type3 /Name /F76 /FontMatrix [0.01204 0 0 0.01204 0 0] /FontBBox [ 5 5 36 37 ] /Resources << /ProcSet [ /PDF /ImageB ] >> /FirstChar 136 /LastChar 136 /Widths 48 0 R /Encoding 49 0 R /CharProcs 50 0 R >> endobj 48 0 obj [41.52 ] endobj 49 0 obj << /Type /Encoding /Differences [136/a136] >> endobj 50 0 obj << /a136 47 0 R >> endobj 51 0 obj [666.7] endobj 52 0 obj [892.9 339.3 892.9 585.3 892.9 585.3 892.9 892.9 892.9 892.9 892.9 892.9 892.9 1138.9 585.3 585.3 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 892.9 1138.9 1138.9 892.9 892.9 1138.9 1138.9 585.3 585.3 1138.9 1138.9 1138.9 892.9 1138.9 1138.9 708.3 708.3 1138.9 1138.9 1138.9 892.9 329.4 1138.9 769.8] endobj 53 0 obj [677] endobj 54 0 obj [533.6] endobj 55 0 obj [777.8 277.8 777.8 500 777.8 500 777.8 777.8 777.8 777.8 777.8 777.8 777.8 1000 500 500 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 777.8 1000 1000 777.8 777.8 1000 1000 500 500 1000 1000 1000 777.8 1000 1000 611.1 611.1 1000 1000 1000 777.8 275 1000 666.7 666.7 888.9 888.9 0 0 555.6 555.6 666.7 500 722.2 722.2 777.8 777.8 611.1 798.5 656.8 526.5 771.4 527.8 718.7 594.9 844.5 544.5 677.8 762 689.7 1200.9 820.5 796.1 695.6 816.7 847.5 605.6 544.6 625.8 612.8 987.8 713.3 668.3 724.7 666.7 666.7 666.7 666.7] endobj 56 0 obj [754 843.3 815.5 877 815.5 877 815.5 677.6 646.8 646.8 970.2 970.2 323.4 354.2 569.5 569.5 569.5 569.5 569.5 843.3 507.9 569.5 815.5 877 569.5 1013.9 1136.9 877 323.4 323.4 569.5 938.5 569.5 938.5 877 323.4 446.4 446.4 569.5 877 323.4 384.9 323.4 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 569.5 323.4 323.4 323.4 877] endobj 57 0 obj [333.3 555.6 577.8 577.8 597.2 597.2 736.1 736.1 527.8 527.8 583.3 583.3 583.3 583.3 750 750 750 750 1044.4 1044.4 791.7 791.7 583.3 583.3 638.9 638.9 638.9 638.9 805.6 805.6 805.6 805.6 1277.8 1277.8 811.1 811.1 875 875 666.7 666.7 666.7 666.7 666.7 666.7 888.9 888.9 888.9 888.9 888.9 888.9 888.9 666.7 875 875 875 875 611.1 611.1 833.3 1111.1 472.2 555.6 1111.1 1511.1 1111.1 1511.1 1111.1 1511.1 1055.6 944.5 472.2 833.3 833.3 833.3 833.3 833.3 1444.5 1277.8 555.6] endobj 58 0 obj [717.8 528.8 691.6 975 611.8 423.6 747.2 1150 1150 1150 1150 319.4 319.4 575 575 575 575 575 575 575 575 575 575 575 575 319.4 319.4 894.4 575 894.4 575 628.5 869.4 866.4 816.9 938.1 810.1 688.9 886.7 982.3 511.1 631.3 971.2 755.6 1142 950.3 836.7 723.1 868.6 872.4 692.7 636.6 800.3 677.8 1093.1 947.2 674.6 772.6 447.2 447.2 447.2 1150 1150 473.6 632.9 520.8 513.4 609.7 553.6 568.1 544.9 667.6 404.8 470.8 603.7 348.1 1032.4 713 584.7 600.9 542.1 528.7 531.3 415.3 681 566.7 831.5 659 590.3] endobj 59 0 obj [719.7 539.7 689.9 950 592.7 439.2 751.4 1138.9 1138.9 1138.9 1138.9 339.3 339.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 585.3 339.3 339.3 892.9 585.3 892.9 585.3 610.1 859.1 863.2 819.4 934.1 838.7 724.5 889.4 935.6 506.3 632 959.9 783.7 1089.4 904.9 868.9 727.3 899.7 860.6 701.5 674.8 778.2 674.6 1074.4 936.9 671.5 778.4 462.3 462.3 462.3 1138.9 1138.9 478.2 619.7 502.4 510.5 594.7 542 557.1 557.3 668.8 404.2 472.7 607.3 361.3 1013.7 706.2 563.9 588.9 523.6 530.4 539.2 431.6 675.4 571.4 826.4 647.8] endobj 60 0 obj [525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525 525] endobj 61 0 obj [622.5 466.3 591.4 828.1 517 362.8 654.2 1000 1000 1000 1000 277.8 277.8 500 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 777.8 500 777.8 500 530.9 750 758.5 714.7 827.9 738.2 643.1 786.3 831.3 439.6 554.5 849.3 680.6 970.1 803.5 762.8 642 790.6 759.3 613.2 584.4 682.8 583.3 944.4 828.5 580.6 682.6 388.9 388.9 388.9 1000 1000 416.7 528.6 429.2 432.8 520.5 465.6 489.6 477 576.2 344.5 411.8 520.6 298.4 878 600.2 484.7 503.1 446.4 451.2 468.8 361.1 572.5 484.7 715.9 571.5] endobj 62 0 obj [666.7 750 722.2 777.8 722.2 777.8 722.2 583.3 555.6 555.6 833.3 833.3 277.8 305.6 500 500 500 500 500 750 444.4 500 722.2 777.8 500 902.8 1013.9 777.8 277.8 277.8 500 833.3 500 833.3 777.8 277.8 388.9 388.9 500 777.8 277.8 333.3 277.8 500 500 500 500 500 500 500 500 500 500 500 277.8 277.8 277.8 777.8 472.2 472.2 777.8 750 708.3 722.2 763.9 680.6 652.8 784.7 750 361.1 513.9 777.8 625 916.7 750 777.8 680.6 777.8 736.1 555.6 722.2 750 750 1027.8 750 750 611.1 277.8 500 277.8 500 277.8 277.8 500 555.6 444.4 555.6 444.4 305.6 500 555.6 277.8 305.6 527.8 277.8 833.3 555.6 500 555.6 527.8 391.7 394.4 388.9 555.6 527.8 722.2 527.8 527.8 444.4] endobj 63 0 obj [656.2 625 625 937.5 937.5 312.5 343.7 562.5 562.5 562.5 562.5 562.5 849.5 500 574.1 812.5 875 562.5 1018.5 1143.5 875 312.5 342.6 581 937.5 562.5 937.5 875 312.5 437.5 437.5 562.5 875 312.5 375 312.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 562.5 312.5 312.5 342.6 875 531.2 531.2 875 849.5 799.8 812.5 862.3 738.4 707.2 884.3 879.6 419 581 880.8 675.9 1067.1 879.6 844.9 768.5 844.9 839.1 625 782.4 864.6 849.5 1162 849.5 849.5 687.5 312.5 581 312.5 562.5 312.5 312.5 546.9 625 500 625 513.3 343.7 562.5 625 312.5 343.7 593.7 312.5 937.5 625 562.5 625 593.7 459.5 443.8 437.5 625 593.7 812.5 593.7 593.7] endobj 64 0 obj [272 326.4 272 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 489.6 272 272 272 761.6 462.4 462.4 761.6 734 693.4 707.2 747.8 666.2 639 768.3 734 353.2 503 761.2 611.8 897.2 734 761.6 666.2 761.6 720.6 544 707.2 734 734 1006 734 734 598.4 272 489.6 272 489.6 272 272 489.6 544 435.2 544 435.2 299.2 489.6 544 272 299.2 516.8 272 816 544 489.6 544 516.8 380.8] endobj 65 0 obj [654.3 667.6 706.6 628.2 602.1 726.3 693.3 327.6 471.5 719.4 576 850 693.3 719.8 628.2 719.8 680.5 510.9 667.6 693.3 693.3 954.5 693.3 693.3 563.1 249.6 458.6 249.6 458.6 249.6 249.6 458.6 510.9 406.4 510.9 406.4 275.8 458.6 510.9 249.6 275.8 484.7 249.6 772.1 510.9 458.6 510.9 484.7 354.1 359.4 354.1 510.9 484.7 667.6 484.7 484.7] endobj 66 0 obj << /Length1 2119 /Length2 14392 /Length3 0 /Length 15660 /Filter /FlateDecode >> stream xڍT%z I&svmζ9a&۶lv΃9zZ}ݾn62PƉ ,+ `ddgdd'#S9Y#'S:8lma!4tz:L,&vn&nFF3## m". ,=@O&lk23wzJc*Ak kd~hlhP5'%7+#-dP:\&( FOP19Klkj @@wg=;@YR o̿ hnW Άƶv6 3) wrsژehhhob24z7tC"9;AVqd+{EmLm6N'rݝõu2٘EَAd ͻ `cdd`@7csV2%~igk0}{:N@o*31L@N#Ow1_} 7617 3rcUTŴhMJ!![7' `cxov?*]㟈6x{3(}6T g@adc4~`|Ho=  +[ﳳmھ_5U렅lLNBm̬F hr26g @6@[G_oQq|*IoJQc[n```llO#5z;9o_eg0%0A? _`X л'3Ab0AUE\zib_WL 0kd K2MR]/?½S4/d}hngx߹YGuw}3/OwgQkG ӮG}IL4Af?e. nqxO'38;w^Npx2]1w$c~廫_\J~o?- h 4ok%Ȣ&JϕnowlO=sɡ &2-`N0~euGV`&%V׳VIڟpt*^/^jRdYΜH 9h}n?KVFC+٥K龩FΒeap#FtCA͜x#A}%SkZ c)6-aւgQATHD)|#_;=k5QOp TH6Бrf6jV-G ~.b GDlC әshro[J 89?|)b|~,2e;iw{!u@p<оQHbz)rC "oMa``'Rh/I̦Ԃx<ofu, ^D2B,TRkNUEOJ%2Ʋ  Ա I;;xèb*1jq*_vym{jy28 a}Bn@g|c@"N'~J䢠qΔgRKXIbkH%/֕wqj.͉0[ F;yu=]N&k:R]eBwEt]}󜦆lyZ&eD>yБGӝ?ahy[hFJİY~T pZD0?Շ>`Պq haWx'58}]L:i= 2ƘOx-˼k0P!u͝[7Y1j kWFdʥϧp\ +W|WߐFP>~ı󑇏V§Bt\Vx&~lD懶hx:Cu|O>uc ZևH" 7S)E_[~=rvkPG=$Pr`k@E]~NP%Y{iG#⬮F6:vK纊%+Q|!&uZ>Veᨭ&Lyc O3"ZUoH40\,jxoV' ۈ`D_!iK!NK @w`p[N "P@b2`KЎR"1^wMj'UA-ܨW$Po}q@J0 -gĠxD_d/ _km[4hk;жOm,OftW͹'8m'/[s#a%]nK% HSCU:AI ^kD]&DDDɝD9B7-]g~9*J[r)Ec ?N/{?nK9 1zw(p4uB⩩t?M9XeǼ;>$|?Qd.0@i#IRZi{WwjGp$0a#8uM "ܱ} 5ǐ|8܋p$?ۯ|hug2 ~%3W!kϫ<,="!,KҤ8蹇pmZߚ5tQjRd":u$/ͥ;ވ=백Ɠ,`hkNQa`J*4'j$0D7!}M\GsbPG_t..cmRZ Vi3k/k-も 12oFQ^ew$vߐd4F6< 2BϨȰdM噑*7ruѕtuv+J*V|-5g3׹;;Ww9Ӡ[ՙ5y8b>H}.s}ޏW{ŠnA]˘^2#䂍٢e"n ;zcB)1$;`>%`΁.^(^iu)}PP?m4<.KA~SI=w 8ErvMɠDtVQNCxg* @B^Xhkg΁j?;O-*G}[PÎ$ 6ː[m~I}eV?۪駣>Rx˴ZiԧՎQIpt緺_O0?{+~6xeqҙ52L8)hݮ3zsl$z;8tk"3v|AnSôm qQ!n)h)he A*F;곥'Y!Ww9r!9wI9Š|x'7 J(k#n? C:MMݸ!j(8 +߷G\KAR,gȩoӤLgH +CaŗFR|L1iя v{ g>߭ g7ABz~6EZe%,>* [lI>d`l (/t4GӪKs.m? /?W^3 ]8gJFyitoF?}۴(oVEv뤉QL/of9?|IuICB|n\wf&ilc_^`xʟt#&=fWKyXmv[I f@cҦ Vc!A p~RZnȺ bG<6Ǎ.VU@RIYA\xUf, WEYqjehp$ʳgH.kzݴ]_x7PAz`ig@uVL++b4 ۢ 1h\g-׵m92uzk9#_)BEՍ^>s˩ K|@ԹGu}ai^).߷qǡU1a9lYpJ[+Üjj-Qb²?я"P5d*T纓[Yba3h'64i]vGp#Tu V)R >߉궽wdkp:FS^PČmT0W_vi~IQՂsb/_Ա]J:#S(to\m7_pC'?YW1o7fxZiys*1o'εi&CYqKvv7#h9iH_S-krpvؑnZ3YʽF2D{(%lϴoq[Bvv?hSvl1?x9WԸ3hBKאsL9``%AL^BEeg֫k-ERVw?wlɡJ.f*sht<5sID mkW3a=zV9F қjD~@6!FYliC vL9uw`|gLIlp ͳ(o <*z!>Yt듩$76_Ad8!(v5sP(ml>,'L|vg'MlUu7;a_ִ:I8A;pz\ 琂f{LSRUeRr0?. Qpiqxk݂p /2rڣR6$\;X-Br&4FB*K)HxMhWNkS6g2 vYP 8]mx v">η2<|%&Ħ][ޅ^'k.7]F]7V+!1ýhin:Gou1eنY1dSZ;$%458>**LO̬jNT.HG2hN!pExM's7LNL=e50`8&gcPe?GbWZhc֦f9D/z)Ed(T}"z*WMRQv.N7\4(uL7fܮYqL5.UaOq16f!~$E̐[jS*K"NNN}j42-k %ez\uW{. e =#eq"2/ IqhuJ纷; }=߯W1OgvhW𓥧uW": C+{!_iRM,O9>`S.ִ7Ӏ5\xM5,FN$O勶d ҷʸ|U64 ^n>OW4ONZrC_PY&"\Z0S]'>MDg Cyy_1u`Fj1Hx QbR_ 8(FLχF\y[V][0B䚥)VCnFu4z) ?*sB,5&&%Bwc|ju#sXaP[ʭ(Vd82t*FA`~"ҧeuH",L}RC-e=4JP"d;< Z^!hYi7fmѭlE+@*V*e}fFI 'NY"H0Y[g#+y>F/aoբS/.nRîe:q閵Ƴ|y! b3 7pkC%ۼbh! g7eއi_PZ@rlX"ے Et'<2ZwͻIKX㕲|lFAmt'<(LPo{gZZOhQy`Aa*~^V~wAAYk]sҌʕȵnv¤g8mQ S3&$(J| ׶t[t,%Re>$8Viz :Q܇pxK5 M='0~aOgi^g~K }%UuY50(Uġ)Ӹ鴒À%t/6}?-$5:[2PbR?R/jZ*8D"̅qgݺUEޡ{%Q]]V\ v5`>Mom(斴`cF#%*6S !VWt!1̱wwmj4 zk/ mu /Λ)}4 +nb\¯*W!iGxk*]q7'ꞦuӏԅbId :ꖗDLE> X3^~xV3SL y'h[20M6C{^VqɢwB*>W bo{+|Oq8.<3%d݃ipQƁp ](4PU$_?umVa~#Ҁp^J:(:۾~ja1dA\"u/ќu8@c&h°[xI،϶#e(x,P9}[<c?b2tdMѷK,B-lq{,t[ĮC+uUHE~}3-*PGSk׭odGݖ4K0, >yb^0^hĈd&11mĊ(nxSbߑ>ꎆL=7(8KJ=R z^q QSEZ6'UAEv&.YT'p/lghdܿ.x5y\9T;/УO w?0?1aPٴvz;WeC1#`\ 6T^#_E:H7-rzdY截/* X4~Af+ԓ`OX+R(v/['왥WNƄJgН6דWl&)WTx>恤*% ):n\G m7: 1/ ztR-e~shm &K.ڠ?ηɾ|:!y7rW6p_'1syß,OLX 0D8XJ^I6Dn879yPNQ\KL3x棎F P;^ AX 1=) *PuC50g*wYmQ٢LA`[+w LΔ`;E5]5q.E Bʃ[-V>ǂ^H9O=W Q6}W!ķ'fBd5qz)}HI d4Lnh&/}%U 7] ~^Lr-YumǗ9^0CkGPeTF" &  i|e 1[Tlo7p;kjM;Oh|яZm15[IFuIz(7 7Z]CR3.t iCZ Nv(@}V@=::БNPbxY`^I~\Ք`y(du#_)N Qj)H *2<0FWU׽Dd4&GuRC jpn_ %o{Se4 -s4~A(D>7tG`*d|Hdbk''ZqUq( _D)hs\(qzY3&.T{ lV`BzLM;U:R(%wfEGP)/|^Ɵ;CZ;g$oEfO~F-/{Z<ǶehWadDfyc^$捞xNHSA10Me Bi Zi${u(m|hͤSЧ-p60ye"z;`pKǑ$<"lxg7YJo2jFFBꛭ _J*,2#>8OjHX':~FsT20{s=_I.lf^_64Xf bJ屹Nʜln=>6ӴV>2Џd}w7A3W^wYh{эǛ+^{ tX'L|T҇QIa m0>׼_mڪiʏ (VXcrHe_(zm\Ve2֚znn%=aY/$),yX[-~n\nD׽vR]zjYHW_Q@FrUbXn1b*nhu)5u22i?c{mD{`cEnJsӧnߚt>TRA,{vxo ix| j*#a'm^Ke+_6Ö53y*|rZ5;ʍ 7Q2\I@'WC.d|flCӛ_]:M̏ FoS!En_4jDBKͷj/ir*蠜9dVg:sE,ȹ~3Jr_m9 n~Mf R5uf-f#CZ"VL0:Ci;.ҏ-"%-mKb1g RHinz``? /s/(,rքʳ9-|Z=by U}i }6RM2wD"Aa -&s ":NoK;q0MDC;FH$.ƜԤ.OJeHv&aɚHZNJ^s2=@ }{m`1"جuG?w46}4ikj;24@@(tB5^ iܝ@~6;j.M"R8zԓIn Z56h-g2Ek{0Gv2A`4zh "iܷ٤$_6VUX3M >Ϭ-GMRـ8v]먝x+$nׄbk8W|G|CcvkTJOۄ6VhM04 lf.@}N[PT}u#mg -~JBr9"2L;3IbfsJTiKnT,g8nUV YHsFO:D p- U }_Pu$ۤ(Wy'`2m>pSK_KCC< :6)5Gy;C]ZkHEU^zBڧ<| k) ds2$\;; 竌 >c@ 385Am.<(I JUCʶs~e g*P;?rS0ɰ LX$IM 0-pG6@idH|seaeI!]jס7kQ_}lO(özH['ԓMlT`{ .Y<𹇔Ӵ)S{'QKa҅Ġ,0pL=t%rƗCBɃX?*#/cfqWK(RmO#]צ.+/{*Q݋gk9Pz_2#,1+hTv&5SQGGdҗA Ҩ;}ՙ34AE^-mIh/bMX-/wQ ick87J2ko IA7+Hqu [0xx<tlgr,+k\+vròqog&(UDp~'kN]ζBzhSm86TpGJ+{Y>Cw6x%8p^Qx tCF#Gt{*wD'P 5fHP@vch_lQ]O\+ELfcȻkh?ˏʗKlXʿGC?=EF'2#gr˹P %]<м3ù!5$f08F/Ѐ9!mwpSR1=LyV!]u<[ѹ|c쵄yL[6C%99Y6k~Wg!C5 eo.rhb#PE#% ^yu [}ND|Bgd4MoMe,3 -771܈D6aFa YSƻ[dٺ͍c=.uEҽ\l1u1x Gԯs%)uCٰ1<b߲.L:/ , YRxEscB^MK3R7U4j31#\smͯ@)iܰ3wXV$+f?Зp1We*4d UJP\UhH9F_`J,&YL T=oLtnoA|bUZ3.B=^=*֗UmÑoD/{ endstream endobj 67 0 obj << /Type /FontDescriptor /FontName /OTBUFZ+CMBX12 /Flags 4 /FontBBox [-53 -251 1139 750] /Ascent 694 /CapHeight 686 /Descent -194 /ItalicAngle 0 /StemV 109 /XHeight 444 /CharSet (/A/C/D/E/F/I/N/R/T/U/W/a/b/c/d/e/eight/f/ff/fi/five/four/g/h/hyphen/i/l/m/n/nine/o/one/p/period/quoteright/r/s/seven/six/t/three/two/u/v/w/x/y/zero) /FontFile 66 0 R >> endobj 68 0 obj << /Length1 1675 /Length2 7734 /Length3 0 /Length 8802 /Filter /FlateDecode >> stream xڍvTk.]!5tww#) C0twH4(݈ -JEO]5k}yv^GKfVA\|ܼM%>^/7//? KdC`P0` ^D5aP3O','" [&7@0)\}{Ľ^ 6ou M rt@0_&X%Wq///n;7 n/ z`w0l 2@ 35n&@f{3߫x@mpw@ gq||S!2>= h+kp# z!@{Ёe9]>?s!wnwy~/V"q~ŧAuNPﯓjk+ [WC('^=`o/> /}~0W}`  `>l! llp7~~YO- hi>3Ayy7_/& mogx0|eh7l{Ђ4?mYGg?8'~=ˡ _Sl&ߨx$rP{ qWxmu sW;C`;ם/~@N}~CK%(fk@8s~Om޿ !U`p_= 3! {yÁζwWgߘ?A> 6DD?i0[⿃w2 =Uvn/_yAމ{_w N@aam?j娼6G0mgq=~cռ Y˥ ,+4bF>}w*Yol(Y=>lj.٭g7nόP[;ՙ'l9I5onn-Vz[}`(49^ԀyM%a'z; ¬}e Od臥%:&qU-GbP2.YVb:9lgl:#Ili\@ˌjo{7jW\Q h4atЍ|<yz,=#eNc͈>Gi1V [-x ^T&~EomTnBD+)V'6l.x9tEDk qVBIBex=RN;~  S՝Ak }%}U(v7䗞UOZôI+tyVO`]f]I9>dֻ_hfӂ %;[R̕cޒw=^c钍']h?|du~e5^h)j<3kV*Q\g;َ~^!}=R$n-s:1 klۀ@C~`wv$N,7 OpcwicK'OYu،>5sfY\O*%d,A<;]T" o1։),yGm1Nd. lC{uiN{#՟Gwk;;+L5 BX^ 0oJ9ʭUA$ /9FQPi ($GZC^x3`e,AK ԚfOxUo-%ְUԿie>d{7f7:`OL!I1<^,>桓uK<_]Y5q|%_oZBrrf,{-1δeEu>=ﺾ,w0#}Nᅾ5gL$ckl _'HazӜ SQT=XqފaJSyZ?0aFȌ^_rϲsX- F*J׍Ԟs \qβP eZk }VcM;Y,y]53gZGB# , X2!O}tDwP k}tf% wiR/< q ~8l\z h|9N1F-Qg Vc^Jګx-f-T~FgHѶOsYwpeFev ؛?O!=<0"$h8:Qm#| le4.nfUxjLʔ)r~!)C.J4ӛo* ȾH~fH|`0 6|[Gn >@3x(ӂp#(҇ig  Oe@ҠՄR05+io)x rƉ*I:]Z"NB:Qg6<";=Jќ!QJ8RM CMp{p~t9bO ȃpح:)""3l(ʱLvי+c? AQ~{Ղ_8l:FL-۹]2"!E2wӏ&C<<>H)Z ۮ=\7F~ t%ȇ\pXp㹚Y6wTy\w RAaRhꅔ˄)x-XwKyVS ;z@cu˕eVo`sY>=mGdX> /L_!GiF44םOJ!7^rW:=^ KN#ߘm4۳D'rɁxHTFjϫ'e(<ǥ`ű#+3P`"[쌜zed c'$m/8Ai/DZ1hZ,6>`ϰ(ҥSv#&fAUL#K#t~-gFgVeSaŸu}x`}|,zRɺYOrtQxvqs ů}ڪ`HFqMF%]MM7Fywdɵ~L5~#32yP#I"E.,tEEϚ ^`_[p5ge DϺ|!)brujl坪Qt(xJ%CW-E訧+t*0sbϺdn61RF [vmKh،򯾗᷍B{:Ba Z`o[ h,$LYbOCh'ޣ-)a}fBO,>n7Ωƻ=ܲ#kSLi76aۣ3 |0M;Գ/ Z~YE8>c1C}H͊ĵ7n'd R_'uJ(ÁhxVFX`,Cu#粙e3ޣ FJݶꞼZNa۹BvQ_4jشs 6nљ-+%ЪߣodD͉͛O:''t? N_ƽB|u(ݜi~e+%v wO*XKp&WW4pgIqN@z[5u9 ᐘ} ׎#h *&:[w{!ng:k$=Yͫk{<u=uiNʠ"6;S0=@ތojݽR.IߜrcH}\% Y0~[;ⴃy0è8㠉Si.iaҠbmEueuurn~qpGPh]gx1%Ll 20́SAhH+ORXۗSεod~S8vs/rg]\JmJcB|za1uW9B;UƩAKՆ6/-,J=1h8'n!1iìѾ|?E0s1ez"+֭’F `+±/7Y!5Cdjp0G*tM-Z07eYz &]7:ޓlqLC i b3nkoo3!^ 5)kK{vms+mM0rD0ASCϾQJ)1竭QߠJOBp')l\{] W/:ƸuyXGnM- x^y9s[cFCh.iM32|>ބ*/; gzaaZEzPR. #dkM_'*16q&Iį+uL骳Hv}+e=zQ~c*mΩ Kyɉ#<$c@*k޾o~ޓh5S݄f4ҧ cʯ%C y6@ 4r鵩 ! wJ@Z\IS4,2) uCJ{b7=[ُ&P[b<G(*H9S~ҦH|r)hs%5mmmOBcIwA_X2SY h<|]{{5g{2i V\| ' J#MfA#slFcDxg1KY MѢ@ufq9|8!d@- t ["W䖪WPn%c|-h”3 ln,H_NA t͢#S49(1ʎ,ˆ"VSdE6E!4 eAND:YmtwHL^lXό3?9~CITZ z!i>VeD86np1XvYy(\$̵Yގ}f(rIDMV(c]=XQI(Hdm2)=7$v7Yug;0mSz^^ 1s%nP;f;{RqS{֭ng*{%9VL/ɚs io-] 5bseYf`bLǷ ?xyg{\KbF]A~tF!k\9G J}CД'ͨ@8X_<3ݔ|9Q-V-%ӋSwpSˠfTb+UNEi/9RCQVЂa!ӌO|5mswExpNBQG^ u5ur}А <*w5q&#)OѥA( endstream endobj 69 0 obj << /Type /FontDescriptor /FontName /LRIMYK+CMEX10 /Flags 4 /FontBBox [-24 -2960 1454 772] /Ascent 40 /CapHeight 0 /Descent -600 /ItalicAngle 0 /StemV 47 /XHeight 431 /CharSet (/braceleftBigg/bracerightBigg/integraldisplay/parenleftBigg/parenleftbigg/parenrightBigg/parenrightbigg/productdisplay/summationdisplay/summationtext/vextendsingle) /FontFile 68 0 R >> endobj 70 0 obj << /Length1 1574 /Length2 7981 /Length3 0 /Length 9017 /Filter /FlateDecode >> stream xڍT6R"H1;Dr`i$. IAZi$?}a纟 -k(a(n@^CC caч X !H(&yWukSn503' xyE nP@ XOW=_6kvHTTw:@ `=5 BP)&aB!Ā@www3j'p$ bE vIoEЃۢ j !oSl =u#X.x@3W!(w2<0;- RRAy`ͯ@~vCV( 䇴v"PH$G2cVÝ!0۹{\GllѰy. * ܚAPA^a~Ajv~o9z#- /rA(g_;@ AaxT5Cl Va6p?`h`'忝rrp77?O>o6UQf jb4v[ho S^A^?-'_U)=srg#;C<3rhoWF?6Zb}^vIdavB a"m(1u=06 Y;޾\w ]D!s(¬6vOPvu{J AkyGݦn9lx.ZXeDE@뿑/t-N  [AaC~~ moĭ2Q@X[?suoގ/x@LŃ[O+eݹ׆%RNqz,23fJt5\NWkk=6^Mߙ>a߈k$G'ڵM6WƮGϣdJª!m4;_uQMVk: Z2 OLcTh;Ës Z# Pu \"VQ[a8w2vcRmI՚f l  Q3Zb\kNzlV=FCT Ұ+~+jXD3d`6.8:wn͏*W93ط|mz2B&LDR[DAS -4>;hkcqEDy-jSܝ}*<ᅾe^΂ߗcb7[3xT Pg÷R6,u{g638^* { e}kA{& ? {ᑦS5b=%A\smNSx=N^0݃vZhLE ORlAt=/5].T/f?cyU\&0`)E9hstxj;Ky "Lf)x[j=;\}lEGLѕݺE)ҙZ]]e10tHp7y{=0̓fFa}Toh{eDχ$Z>D-f"!KRҊ75aR\CoR$w~@tmucl6ƣK2u8(8Mu\O,-₮cLzsPå>|Tg&)6s0 ȿ?SP)EfuQo鍵 e%i8*?hDs; ^>8ܣ9[aoѩq;iv>?G]w/OIhlF!pk-=f+ 7|jA-Qwg:y^^;J-<ْl]ًFU91݊QAG %^woӡ;UXl[,pfA#n,L`@}M~ ^T76|Zb#$dِc5ÓWm}ɕ+0s}e~صgz7Ġ"91TS{5k&R%<4ԅEFUl(y%0|c8M y,zUV*+k8Xg+.<w=ޥ`zֱJ7gnSҝasS;CrLȽlSImU8Ml)%5HYZ)'w))bj7~EIڅNsVG8>/PjXБdDR=OZ\X4Wtl]CMu=I$T=ޑkk?92D6"}""6g-$07'u} wu =W5"Jz+T<߲F KR:`JvgӉ-pEN%cn[g1Wdf g:W*o")qL  3A DC1AO#5/>3r6!^_g:TZM'-r0  CcoܨԔʲj>ɟhaxzB(PSeUzZv36({ԃ ==aGe@x QvٔW=Etq3l{=ؒ`93Sй蒑7QH®/A_y\p*1Mpc^5*zҵs\ ::07F9#4cꬱa3!^3e^aOZs<[@krWĎ-MYIˇ-jtΑ2 ֧;6wp1Bp'L0ʢ;~?c?qr-ӦMSq5Տ{4 zRq=xOٕ1݋>BD'}mb@|hOk^\p Q~>[_ZӎbF`8wnwB8 Ւ ;ž L<<(e{gt@<5@7ҽBQ*[Aݶ5r;ٺ27&k8)ii ]-n!Bzgd"vR~v՛&#cDā#v^pl=3UiDdsF'G>yJ{ *FPz1_Z_tԋ@|'+? K,Տ׎MC'X7Iʩ-3WdD#R2`d3]}GT'܊Tk!}킫 ڤyw.}@-K|ghobLEskMX6T)dcF{hfBstnQ&:ea/%UVԗ.d E<=VN -D  I+\j'V޸G69\EKd Ҏ7 #ŕCUK;V[^i2@pgQ@*`_Dhbܕp{{s4>Cc/Ncppb簫zԂ %qYͼ_gdBVpǙD  1iͷ*%KmlO{0ouOT9":#.)39IQ棻?)9b]1CJ7:o$ ~fvR͒Gd_fqf_]|La[=&xqϮ< t0^"~1=4اDM-gow1](졟iDh UCTq(lj-Zׯ뱔R) NWSf+E~ba@ +*3bp#"*íV$)l&$m+H8Tv4/~QY;C/^څ>a7q5JhMU%rZLJ'{ q0=pGyf싙p)[u66`{^+Kd ۰;ALztm*ؓj˯Xu*eq:M!+hk K+2ԅ$2n-;2g*bRcr%H+H&_&+Sqg<ZC>g$ZP֧)[R +EH:,8@:KnMN\0^"DzjpǣՏ2+8uE)` 1 TC|.R*ҥDFx^oiѱ/|Z#RJD&ieKzT6`E~.X'L] 5_4%aebN̊tt5hXCO/w,"7I>*K˺`G5S/+ú);@ 6vzGx5Jxp9D!\+|aߺ#RG;d*dM˻'5毃4+/hqsXJU(&\[Bt,0{AmJ buoy6u3w<|1 `7\A}JӞ)ׅ~'sXg;Ih}bR׼X{"MfbHbvd`t >F si6$baS{|fl;rmVL7A,䠕QLN(ii) dƵ{&*K^YLIb-0G)Z`D ] kzeLid9rHDeC#dr2m:`|C0y`( @N z9OAnf^1'z͚|ɏ+~zvŊO <\C e=N@ߺ~mcNͱ: .mqV |$@ʄ.Z~"r1 z֑þU)$ᒝH[o!Xb9=]:EZo `K KM<#\ FYU#n)85$RO&ɭ{%toQ:L4n44>Q x7V\\xd [`msYMa\l=ԣy(TBwml}L8 ٣2" VqB!+V}sUqQN4g#JxQڰ9yxo1I`@œg"ix2~*p1~XzQNd5S7"(ٍU`YdU``~բq'l+{zL*oq.wfAfנI{3[w'5f][W f ]Њ$3AƢRՌyfXhZp&ݍ禘Aq%T/+}&I~2ƥqV! xݯ0ځA<U&ptR+@),bޗt<+a7^j a!$RHdɗN)8UʵORjgiL2~ 0&Pّϔ)Yf[HUfTX%5%ܷUP0,~6"&*G G][61=/!LWaY{`< rVUGD]$hKLUR]:#5.kbh.^Y=id#Uy#3{jdΌt1WwjZ &`LG ܽU*!}TTr'*sВ|xG}#f v#eDȹeXC#yD,Pu=8IRra{/z zE6:t8+2zN|-$=GD!\>G<|ij ^J1J?4$kk*b-2;hk^a"gx*p=Y!` r$ܡ\:Ҫȵ =h"}-ґ){i.&nN Q%.],ոQW)dWnԅCH+ikGTn$ 7ϖFmQ3/}`_U1<+uaR:,ea%ڂa}*-Q:F{[j̱TGDC+vgr~EZދ_Vp-}@=-!.)y_dsEw.^gTk,!v+?;"&IG#;rF&zdzBM- ÁtؘBg~ \Y=O>uT#u)axgCԸq?[[OSɡqɷ=(z#)4oGAz q_#)Z|%j])ۣd๲u'W>:%V,:&3Z\j+:`ەP;Ī*aI|Lu>7c!5tF-X `#Pd|=N 졋n:B'"*K'׎ q\{=[7HrKɅ.XEKc;g{g@6{WGkf#"B#xC$d!6橃ȣ H?:G߅څaw%jr endstream endobj 71 0 obj << /Type /FontDescriptor /FontName /YHTTDY+CMMI10 /Flags 4 /FontBBox [-32 -250 1048 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 72 /XHeight 431 /CharSet (/N/c/comma/d/i/m/n/omega/period/t/x) /FontFile 70 0 R >> endobj 72 0 obj << /Length1 1407 /Length2 6193 /Length3 0 /Length 7147 /Filter /FlateDecode >> stream xڍtTTk6)]6"]C72CH %)!HtR*tHw=y_֞}s=um&m=.[5DCpr9 Apg7.! 9wɃ< 8 Ptx^!1^a1DN`/- a\&9;+j s*d\ P0 # .ȉ6`g@n |ՂUpxp8o(Ѕx@ܽ O&7.׃!p@` O-@T-WwNܼig#(W1 @ah)s##80g"{`kd¯E;u g-+l..ެ cAav?Azn?)H?>{yl󳽾+W  !A@v  =!~;o  k=OwbF.0! ~f-OjsF,1/ p t/cC OCƀqxɰ GrC}s vQ++.Pg? H*{"Ѐ#T#o)k@l.UA#)+ z(BClD{PDAV@C U@nw쁔 r} ;I%"ek y7 @HyA_}m<ݑ9o! xcuhy 7ڠA1`%6SaR^5e_O~[8WܴN=EK;w=JQ,X{'6m 'zLD,SdoUÚ5?||R➨.GM;KK|JyTf}5Iċݽ=$1OU#H{ `U^gydV"ޱ,Y`K=x_GbZ/ _]k-|:X8sYCVDFB5]NzGֵ{Ldފ&Hzx: '73^I{%d*S/ ^`zQ%bx G>n);x+ub&}Jtޠ0c&FtcH20Xvܭ5qZ?lyP27ԔRvӬg5Oz%yY.ZoDִLAg&z߯Յ۞EbҢ 8ĥi͌&#L=4YS?.k*~=Okm܇@J ugfJug,ʙ 42D?+&X\`l*[+yɬ;9}=5w 6fS덭F" ňtt^ajyzZڐa P3 E$cq"nuj-_bL8>1w,&&x#}I:HCEZԏ(X2gId䀞5&M=Mq/`QvMuAF#QL)o+u_/=}3)uނ7"Zx$O"(Ve( LPX-='Q|x r3mySFnܪALfK( =ULYv}(`\`╛<^vQ7Uy('4֞is5/a9zW{bvU%?3B$EiŚZͫ5HyT+i`WUGav'ެITz)S(nib{/JOr[e'2-=db~0K ]XiORǤ?iHϕSsϡ(#,ӷ=F{75^G׃,sB'on.C{igE 3=ru17Ԥ*cq*݊ѮUC/Q)jzaِK#k[UZ@+WCdbOgemrR˴ W= ӞX-)/q;B+6}dtKͱ}:4-ؚP19eP|RMSMiC5#G|Lqa6ֺUS"n:[-~ڵV_3xwv  L{X$fV3BekOX lazs*Ję8D\t|֕[kfj8?ʶIYːGׯ j{u%J^)mϩ a~p5x)ORwOw?1tʝ iK}sn-ͪ;])則d'a4\SWUZn@u˰"9جѦ}Ӕ5 )Ē#{ ˗<M\"wFs1?lNdu2ț]N uVԹ`̽^;^;<%ߟqc,)<0#,ͪR(c[EpX1Ch`:]$ejh VC z&R%s9 1O/m>X3km.ւl>RK /=(֥ucէ̸m@n~@DmW tClƤ76Ols?1W M|LsHޝKJ }&FNjO4T! I^S]F ;)QTcũ+XoV?K7򰇕I1:9TFr[>n73x&Kխq=#A[YAm1Pso+P_A\:Vo5yڛ^ng趻gwxІ{g2l%E.#aqL-FmKw F,Z}Y[4OLY"Ouɫf^zoT̈́jM$#yZa$~tve;QEZ@\LŶhXL`lhx09D_e>ZMykfa%>ZC%8=B&*CMFTl<ؒUa"V}C{Γ҅I/nb/ګ_*Əs[u%Jާ+vuϽ{@ϡ8ۉv/7\MYOrO_]&멜}mZ,)QI!Ѓ<>GD%}7AE ON/6ާo1՘z̪a3^ Se5QIfa-]S* qw~Ux)(Lv!sYڙԮ&W&&ɉ&n@RYkžn߷+y?Zʟ5-2,ǘ߼F15V:cfvhֆfu`;y/<{Cіhƥ(61<{nMsZD/8iYSHt;B>Cv蛴U=g. 1iuY؇+- u# 2znڟFőU{CI`A.b4x_]C5ᅉ=frp1}|##NRʿz<>S(mLّ#F~i8ČbTe*b}DWƐh {rIeunR XW!8k-bK`2BDT|ӵ|zbqJѭcX]ErtM6S,A eb]P 4lP~LMel]hoh*jp酨6ltΗF>HM>u(Ʊ|Cx |54C8#:p_>Gga'(v{4mcd6i!Vx2б\]ƅ3Ә'>Tx]Z:jjgE$+V045={FT !՘A:>|h;Kp0LOuad|/-.ecvYEEH/Uk:*ׇ W>T%=puKh) Aãθ˷1 7~>7eGCm\FԐHJ4--KqN le+nn2:{,d{=?.wQs|W]K՟`&)L9K 5:D]uZz~^V&-|sn6fxax`<EofG&/"Qtrn'T5gTP¾2Z@xPSPϜEol\QsZL.sUI}jQekeI2 #:V%ZKʧu[R~BSR=,u J)VيN_R ~Nޅ ZL >WV>o|9P[7 :QCzT8Yg)r>ʮ=b1$|UGuZC߸| <19c|*b6 n.b=&8pa-+٣vݮvi:DϯX8yҴc1NĢk{֬KʸX8r-uG+&Y4 Ӊgհh9*bk2?qYcLR9ewJbٸz|>v$=̒*/?yuʮԯ}S7.ؾ%rTgO<6(qm֏|I.GG$pq8tYt]_'FЗj rs:`%s=!6D$SuO?geoܧlK.9$7*fW"H4CU1^!'~L69PXs_V~Y;?-oLi9P9MQGjg J汞C E6@Qd#-H\유8/s,X& Mm[!bR[ItAHr xG)1vA~8 y:һ!ػe_2Qw61+ˑXm.1!< ԼXFJ/`c8blS_ڦJbKWT7R#f3Eо+O⾲P\{`϶7\Kҫn޴36 2Ym^J=0}2i? endstream endobj 73 0 obj << /Type /FontDescriptor /FontName /RVPZIX+CMMI5 /Flags 4 /FontBBox [37 -250 1349 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 90 /XHeight 431 /CharSet (/i) /FontFile 72 0 R >> endobj 74 0 obj << /Length1 1502 /Length2 7221 /Length3 0 /Length 8234 /Filter /FlateDecode >> stream xڍtTm.)421Cwҝ"0C3tw HHw HHI" JH9kfg}uk?@MnY+TGqy@by55%a0/uAp n16N (:XX @"\ 7@Cx@y u{߯6KvXTTw:@j-DK@a <- $qD \lع0-@A!?x][FC\[f #o3\VP%U'XO௻y+W!w2{6kʃ@q p_$69@,n~w(j t9x^#"" HSnS<~Ѷ-jz@-f&!vu!-54k#{i|#GcfK :Y*e3`ESvu9ӗ_W_{ p+~9AOI8IԈk"PإM.V6=:@"ֺDwEa5%Y;ڨ&>5c*֜eǸT F3}tсnAka(G} 8y9n$I垰?cO,_1p\/`]v%%N)\k׵G7TwZe^>)8|v.'-Jbwb*ֆz wXv Ew$~;+J6ֵ堊\ $?h:!6\ r9Y&v[{VςV\-T>롹6Dg>{'Y W~l/2p3⍞VY*9>]R#T-$`gi̽҆HJ5L痺wUȽD ZŹ>Jtk(%V }zJu kj~&!XLLi'T8 \TV@?m/@iS4YKC`Eki *C*L҃^L~c.qDS%&Q<眭|۹^|TRnC݋ g.s1ɗ 7dVLHbmL7#Re̢/0~=* 롻 rꙫ/P_K{7`#>!'E?K-B}h):0ɝ)M?M`{qa-:<=o-7a߈EQsmf1 ~i؛oI,]c)7W*G&վ{,U˒0J#ICŇSI*p8]gV~wq0AyԠÈ)t7c">)B# ߊDeǰ,k$ס=Y{ZT6o ]O8):EaN\Ks 8२ʥuj*P"ff5\$2T79VY'4^6o鲚LoFI'=mG0]/Utnq;"C0@zzspPtAȐ'xM QО48ہ ηݎ3:8b]bQDbIW0VBwџ^sHXH6b$P-~#)|wm.GBw` L-8u#HU~Z)uQթvg鬝 7g{d>o{jiLJ.N0ؘSv/TOReDy aF 'ǔ}|+qaO3MԷ/.DNmH<'̡'o-^i`\.QY-s ")'HW#'%~ѫ iwN.lC>d $hO͞]N ~ɰu?چ6'}w0)_Nn{?6wTD~\MCп=NnZH%_=;mF/L8*?TJ*fH-zF+I?‰EBe~ V3Hw r)ʧzwY1Υ 7H[~]!R$iǻW{DϳqYq6mڽ)JO^ьfj,h}#Xb2ގL i4r9~Oƚ2_ոR5oNhQĎyǵT g(VjY"tiw۠GDߞpA_)vS즸90 dދ~-rMdM6hZ83Y l*j;18>ޖ)yay]'l_L#kqUp_׸kD >P㜻8>`:Y5d^TG7Y$*tG**~"Z%(3c? wd6(A&ErDUҾs H,GRLQu2䭦/k ᇭY8[شHozQii2OˏW>mGZNxyҨ,Ų)tpJ2c*_A5GMi\v\ 7j1ڲ?qIm-stojNj=+u/!u?n(a/20JoڰWr%F f~}^;HX&cѬ7w['>[׊5NZτvNgz$C̙`VH+}Y"Vc6,l'ʾFsqaOccڬ"moz:mU wuI-=վ>;MWݟ^iս3*wpl*rVIv1Ǧ:$"}-L[U&MYfStܚO4*Z[Qˬ|Z+j̭ɟ* Sem*4{v%/ED8y)5Nl |Ii`=I+Sӊ9NLo~Rftp^Iju?縰7c>IwggS-\/*.4z 94@'xz¼l}&@Q6eyH8R./ ٗ07f6Ըee qR4>w|wf!FlcTNrgS43q0=QU;HZ\PY>؇T%oz_}:;݈Srs?`S80j!O3TT~G˚K$#vHK,%7 _*b=8l[!?Lsj!S10V/L]3Rć=38HZA;.KhW!A]vYj:58kA4B\– PGCZBC1¶W;v+o\Tj˖ICeo(wߔSS5[j80F+n%$T)sd,y* HӌL,kbnqz@zNTJ$z썯> f,'Y.O@XZt|ur]w(yu3wÕJmL(k&Lk6qjݎ=ų޸HBb84D7|=POσAX'6oQ%ʱ.S[0K3q fR%pC\'oQ٢%ldVω3Nrl1w~hq8XvM&Ŕirjh,6/MQ7{V9,a6EaqΘV\|4чL3.~'KIm"LsNH5ԩZUPqgCc^ƓK`EӈnrvzU_ȉʹT)Do&|_Z P;}7֩W/LBy  <9Ib*?C<}ر[l;tcD=m{u3̖TGbj:´hhz,Ukř;B g2=]Ok#<6k26k=S'o:oX5V*:9I[H Ymױ;L7bCv$<q'5I!EfLp1QOۛmt8}V>*ӾϜdM4 <×ɩ>"XrwkjjpLwxMtdjf=iR))ϯ^<޵ojΖ&~Rnc@h;8t \sj-i;!mb2a݀}l*/ yOH%f %Wj]&aqƼ}p1cT(a}+^])(ʠߝqHV7:`eI8f|=%DYc,}|>bzE@'㱮9QwLͅB\"rtͶ,.ش[i NtHks9]IIMhx3}.)ėlmmB%٬ iurm}=?ag.b'*Ľ.?C`΍ŋ d#_T-2za/ I mc}&lg%VWswҡ^T$AUQ2Ioc-0D K3IeZR׃9l7Y mLgLe@* S+'RXj$ aeBjR~[%nV2،%P3Wyuw{ߦzOX ĀJZ:q㾵tˋ]flw6 (5L=!ӷ8l:bbqy-zI/ѧ:򸩈Hi*aI7@,+j P8 ʅUƠBcWMbdU#w CiL8oc? { ό%!sukV=mq۸*kL yk5+ol(Ln]'IWRl6ȝxԉHZr[5Vt| _\L $u'-*yFOrɦ/-~ǎ}k>'iUOvZ2n٪"H8k@nIXE )J=`N>̼aa\=O+wV뎣8m9>Fݻ@\9(Pi ϿԩF (<_Iq"pq_S5Ldf񂾇RPUEG:jw}}=0Z}cC'E˫ߝ3Wա)<6Ne~_N? endstream endobj 75 0 obj << /Type /FontDescriptor /FontName /ZWGVMU+CMMI7 /Flags 4 /FontBBox [-1 -250 1171 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 81 /XHeight 431 /CharSet (/c/d/i/n/omega/slash/x) /FontFile 74 0 R >> endobj 76 0 obj << /Length1 1414 /Length2 6744 /Length3 0 /Length 7700 /Filter /FlateDecode >> stream xڍwgTSm6)HgA:H*BB!E@zGP4HKAiJE@vЧ}kΞkk~l^Nc3a'#Lj:`Q@TT\DTT ;@kz"1haaK:iA(,r_@ VP @yaHgAPA,++-;PqaP0x!`n'B!( E¼UB@.@.}!ra?^>g!N*%Mo7@O!QB.R KjC֪t 2QA;_0XBDT?Ss2FzA,~祦~_/v@C1N%&)@X?^Z@RN0 D@1An|Mqqq9CD`WPo,ߛp_o`~0(G fKUxK_A1 % &UP5ğM+sdu'0YDw\7LsS[lE8əkikB{Z|G刯["Wedį7d7WR0Vs_yp>1Ʌ!\|A6)f;ޥ6 Ɠ$ЃG~r̉n uzUxk.$oSR);FjwA~tYpDʽR0w_EYL &ԽQ;6jdb8։۹[TB-u&)?o8~pm`b.5^%7f}Y10>~2nƿ;Ũfi+b"FƔI-.cٞtK)JXhNS|]FCA[S> 5x$He-'hs~JKRᬾ Y{3|h}PsSbU~s{OOz=Qݓ5?XiD-n7 +өFMRyۥw8+{.J}Od}f#6/K;0*%},7[OzE_$FhLy׊7'n-5fz)Aqk{e-FޓwT݌??_^OYV`]m\޿7=V+!@aoi>rgU&+^pFwaÿ.BՃ3bRMDoWe}Ә^7inD :I7Y^- ; ~*x/4g2v0љ~Q}St7CYn֪<'y^}b^tK!|L3ߘrQUWvQhڹFQ{~5"7u4Dnv?xK{Up4[JSɪUZaV5 DhEGse&B'Ly'yFNv!A/,B2R&AoQ)F//(ii}?2m0f&ˎy)sm.<݉Sex I i`ۍ=l XKMnЮO pͤic'e[#ϙUvռ"1b矈(/L(}qC(N{o؃4ci%N=ugʾR 1ڌQYNy!YCƧ^c9DzbяmQIv.8Ǣ_'nj6Y+<֭~L?m]CJ_ L߅OߜG$"&d">}6c`ڼڝ08z&->eS8~ZL{jDVъzۅ%nv7}%~@rW?jλVmM U8"}ONznzMܸ{9IA%T/<tU<Ǟ)Yz{Е+ѩBN8 0(^$˰`eˆW}*'Wuk{89<"ý bZ2By.H5SZǔJ7_68S2(w57+Flh"c^6f`_C"7ڻDO $5u??J_y%d1%> jZ|?YFbv3ʺTɧDW5#GiTpK FÜ3Ŀ̡FUS8Y@;n)KY6ѩxtoxugbs{p+0<.пP> vѼxӗ[(`w@Үڰx^ŧ9rJǒk& :.g ^']YeSmP|%N1~ۧc+0Ŝ:⩟{+kmKKnPߗ1㜻**{gr4w8e 8#mIR48܀tG+,r8 ً'|&ͪևM_S"&-nD5r+43o2=&:7O1\cR4% gSY$?q:6l8S[IVZ춾hѦ=v`OqhfU+xwBniŏ)6L\PӆYmWl1+FJaJ[}u~o8RӞOvM-Z/E{KM 4-z^*2I\%z@b1aEóDO)鹪x:P.Q{xq {S J >Ƚ| >S1 0=$=`4rvB47"+R4 o(~7/Kx{O]o3Q\۴rC"7@˻S%%ӕ\nH[r wxs Dž&M]DmT C󒼙  nN IG.^_V底Q'%5fyL7v8Qykx%Q_en |?TjT+q}<0Ep+Pdp'E'6Dž ST}0/MSlL {CQHFO݈˔:HB p^A(}.aqtH$ZB;;Ӏ{[2ٍA&>̦}Ž\7be g$*5 *; ;IGgX3OTZ-d8` \\_K@fml|{#}c_?jRZ뤆lRI Nod0>9#!shZF\9 D`= bY9nv"p/Z|m-Sr 7rCgcM gbl_3Aq'Dv!s~Z T }KH (g$T /pbʸz3"P“n1J-uӏU,,m 8pdNX;&%r )#4!ƒSHCW\8~6H4DXFeA+Vj[/V#q[5v^CouSOuRNeG.?p.u㸕mBU%|R^!{;'۪Y%=VPmP1zxE i^ϕǢ<]W+U8^ǑW^YF.߾}D%\%IKPGtg!3媀ݓ27ٔ;EЯ ?mm(p9gT̀eW6+y<8ʙP36Df%u7&^k\pu6洱?5R+ 5'&(3+ G4mK׿R/I5*(V#(><fjvh/u;T8qf>OO0C|H6v%Ĭ䣻BFE>qLgE[#ֹUj m|+Zs~? 8kuIzXItoMoaA9 lL-{K;^»LM/$8/Yk_5&Z H?,V] pz*adLtAhiǥּ6Qj=[tQ!Os0le a{/sH'@EF;k_'+ ~,Otlt*^)MMkes{۩ z@ {xVT !ʕ[8o'ih4Н]H`(I1SDWj[37w Qe{ A'k_1IŪJ+Ғm̸53,]MbUZo4=W!{*&2Ώ‘\ G&paM)8.|!zgB'22J~1Nmh'%c󑪻>D[;^;t~&,2Lҏ2fT =WO0)? h5_~VQ#zbx1iynmg߳w~)VOFtG(E+hZH,uҎKlTw09f:p2&©n`&|"'nP/C琐ͨx`xؕVh`4\-T nl<@݉4Cv{hj-pjSrpI؝W*׺z\/0C`Ƶ◺S*%n>S%3#I1kap'Fk#A.yV達A,R\+8fo0'#;) Vby>KEQ]O WXG #٧rP ֔? =. `{̞{f ]czmňe<Ĵ*Y%'Ǒ+K\BuoW,Wzjy/'n>TFԗ° ?|[3|` X)7d7 ph9H>:\Vʠ zo]xMjOx\Z,Ӟ}FpReKSxyՕh'0(:o`?P2xPNz>V~s7VkszN}Gi^K/"֏EX8>efAY%g.:i|B^ʸ^ڎoqJm/k>(ˀAj]^߫M;xmc|u:H bvųS#: 뭭w0_h;&Ņ`hjzTC~_p[r1W/rŰ/[Ж  *sduw&~:%4𸝯ץJTN.B)3,5q l͡v50RhmU/tgM*yW$dqf#M\hLҒ\\o9\{ð'As mXOI[٩)Df;DR*ĽE{ѕwA%vz⛗^ yy[>S8 L!wi* endstream endobj 77 0 obj << /Type /FontDescriptor /FontName /LRRNNZ+CMMIB10 /Flags 4 /FontBBox [-15 -250 1216 750] /Ascent 694 /CapHeight 686 /Descent -194 /ItalicAngle -14 /StemV 113 /XHeight 444 /CharSet (/m/omega/x/y) /FontFile 76 0 R >> endobj 78 0 obj << /Length1 1358 /Length2 7249 /Length3 0 /Length 8181 /Filter /FlateDecode >> stream xڍwTk6!!(%1H 5tHtI 1C !! -H7{Zfg}^FZMNik%DCpreԞyxxx@8P#o? /+Ɂw@58  A<<"ᮢ@9T n8pg/Wߏ@+V tj;]G+#Pn UEpF"\`'7.+ E!nW5e: #PW@n@]!;# sKqYC\w݁:OU_`տ?O?ٿ AaVVp'g0 @!@ U.'Yw`0ly}t0PAZ c+uőWkY 0ίA]!Vwg08eYa uqw+h \ 7 Kޝhw50^/_u]]]ӿ xBpfgVb!!m?)O&X9}f]/Y2]O|Yg9mzђz{e=ފyw`Wm}JN] k_@fewa<ͼG?=ͬkmT ^}~eX<Řk5 DpRazONQgۋ+1ZŜO{/u3O'|dR>E4q HlGR@J Iڒr)'9=T0Λ om{d0ȆOB y||+gnXkuEp8#bRdT/iD=]Y~XT*ls~ry\͔h ӎWKm)l=*]WFӽfJn NK:?yX?Ơ@{ H,7Iix57+مX$`͍lZPh!Wn\@7#U=YlZU dyU{Fz?KgXRtM~:Vo8ffZrj'(lrknSpwZQ-p q1(.}Sp p@iэ5d.;4ٽ"8>Y{Dž<8lT!c댠J;~ 0gr4eSʩVfxGErw`c!Y~unB;rAI_~ ojJ?%!%␪ۗL:b-l\Ǯ"%ςψfht]L [|Ya9* ԥ. B`'>-k[ɳwϰF70 0\MI}5!ξ)y:U2z޲M~a#I`V'4ݍ^鄈M=]28L'[ `0ʊC)_L5O"YW[KR!<Ӌ=:9/x*^4B1a=JҳdQ,0mst(-ʏ$ɘ /FVo|ͪOƼyAC/0z &UQGGi8dO̕& /=c!*?jC/[ҧml[2Pk ZyXra3x@BBeF\0(ݙ3`d}⻔{ y-7 _d}&c d+Tİ֔T:jKiO8ېMGuRI~P.[{%y1)tWLq(%խC||n|Zzв _DMwrjz%l3)8x4vV[ `w? wqEXb5VlP)`wOt4=t16ܳvlS=i10\5`}SIO٭yx?プ|A q{:ǨZv^)RØD&I)@ /T^bB0?'q~!Rez9BʻD*i.Ϙ6u|Z &KF:S#Eҹ PkчnGecT!({\SOÎz&Qa D%&65e|+g!Ȳ%cɹa[# 6uIlswd:aT?.+L*bDzu/*|Kgn4Ѹ`~۩HhU["}Fﰮᦠ'<;MϮ!pE9ųz]&6o134o)61m*>sqR)Y ΀$Q ${6O[8i5չnG9qNUmƷuw'Ig+uF]l;۫t=}ur")ѩii@>~WÀ45ő T("@Y}> Je+AjlT褅^zm6 X*>c,*9L1=] )?nOQ\'g m8/Gs892t8&QT;\}u᪯:h`|l(VƺbrF+VaK AH %yӎy%{)|qJlWp+nE>HaŵLBWțILqׁf/XJ$ 3Eɔ:ʣWtȣfy<Y>aPВe{]wž^TL(ZDH|Çٰ6.?WAg 5|UR IeB{MSG2*=(9"$?{{-ə3C#`Y[ө7=>BSFݺ ńsB[SU  Vb14'^j}=Tt:}W'4700bʙ#qTFE"{8׭^L:G]&dwf{F3c؜S]&Z.~䬕GvW|=_ʙm4R?qZt\( ʖcx~K̑n,bnb9P/v{7ǷvYqܿ"' gz p w6 $x*Pp|x*3rgz(+XTf ƿEj$aNBFm(ڤƥ׉$g1'v'%2UXw~xP(hP}C I[ν<0 oÑo!k%Ymӷ5Vb~UOq9$Z!j"4pCo䧳l[(VX"kN@iRa\*m1IvoEAԻt·0$2eLi"Y'+Q7ֳFb,ޫ z>)0DV*T8;UޡǬ%_%X\4>骩A+ԤlA;*b)ms{uMc=u"&T&?@_q70A;tw]r1ԯS츗T5z,ѣll lDŽl6DaU=3~]vF+R0@,Y s*Η~:\0l?g-@Ȫɠq9cw)e/K6 u`恕UH^ 阡.m~ӂ}S$IP$vKit2dU!3EX~Xa29cK#t=ǡ *Zl{;,]?ay|,3q檖*QTB8e$If/ XZz1s+^|Z WGFz/xsnu{[J苯*-LQE-\]X1QPXS`0<53Tl/}ɸ ])9=csV毻ዺҸTk'D i){MdֺdAw/}Օ7;D\\H.J_Dţ:02K }XW.ׯ j4wbKoԾ:LZwޤf*K]'oQ7 ,(A8e%+6h"$E{: 74cb߫-&G}tJ{b9Z!#Դ!sD\1Z_E-~ nJ {3_| 45.z[@g6 C|WasBV͆K+Q<&Td$IK}v3̶z(zV YM%^눖 .<>o^8B5+̵.wKm ( ޏK-8bQ_5.@3Rƾ|$zz-EݔХ䱸$rKB}e.%VUPgD%% vNFp K/mV_D[i/,"AiqҜ9]OQnuxyEH(6Tª2\pQ SB앾jKY_yxt/V.{912;  ,BW{!qhtEb1ndmd f9M7= s2O1%Acs.5|,L)(]:V-؇sk:\Qc!UBH;'!>WZ/&6X3,Up/;GsZis XkpxQ3s3ޡӪtg7Jv7D]$_89A(BS*֕nl-%|jon P/>erT]aMF;D EhKC4`a V:s ;'~Ne/Ԋ PHl8t)^!XM{D |7Co5ۼW W׫^rE|XZUW2d՞XpY3rJ_:f1s*eGǖnzx?|gGu!rh`5"3b $3qs)]nDُ韭@WkםgHj- t,e`&ί7fQXj=:N*}Z3RAGj:o\bwM+:1Zso֓q CH.J"U0lߡTt(FǕ!fq0΋T⥇ 2frY1'69=+9Tzt y_=\Ko:h"{)a| c:y2^|-`r_GejV uD4/kCYqWM \*֎m>` |m4"S#,N=n|Ƒ}zggm1)~U`t{doV;h3i #V"7[̞&KqPmr~Xŕ j< ,Hf*V4Jx@ism3> xxZZ>P*ٺ]Pƻ^< *KN j/ota6Z7@\Icp.lN vnװfw S.m[- ,dBw $R#LT,.[뙳Ru z /Qa!j;_62Sph.Ϫ+hC"gMu a.f^?_ѢMw_wʩi`v `-N.kyiDY)h%zo:dv`Эf4_Rj4ƮmCԶ޵[l5Y wE6t )vjnDJl֯fRߒFm!;x<\ewNʥ,2R\Y]n۱%!F'ϬPv2=aG)iUO( < ۍFI^^l\RjgoVLPʗ,PlZC2M> endobj 80 0 obj << /Length1 2603 /Length2 22170 /Length3 0 /Length 23643 /Filter /FlateDecode >> stream xڌT )"04tIwww3-%!t#!!%ݍtwt7qۺ߷9kbyJREz!S;c3=37@DN ĂDI r#FT::l0q9eF`;9;[5`ab#7@d cH(E=A`=hLh\\rA&F9#g bg:{' =7#9?; t:MΌjr[bgf Td @ۿe6x6f+/g#;{#[9 d (28;ٚ24v .0'OzN& {g''WYTh| G w`55=-(% X[ft311qr̿ |f$> 3 pvtx/BbfL@s-`1o n#=fӯϿOz2mWE$$5_; @`5dK/Qw/Ƃ柕A<@ebg2a_QFH/5_ (8BT*MA.6W+l^![srMA&o *9~]6zpp&V ܫT@>RⱰs<#v3xCM60sDQv/߈(q'7z`b"N&o`XRQ7F`v.#0¿=]7F`>̧#0ƿ iF"VɌl+,5 ~9+{OU ME`&vxl$66kxM`JTawp/op~C]_ƿ!;//&@p@ ;cao, ? F.;2;^> ?jp2`wzd< ߽a`\윁`e/ +?u0+w]h;8; 8$KGrv\p? W@9,d,@pq<7.FGp/zuo=݁&H3v&J-R7p28c Ι-;$z t,ak˧iRUv< =no,t—ӈ>Ö8Ck0߼[pM|kx&|ϼĤ r=OY|ڬއ/mOO,X Chr:>DS+Tk>0a3{mϝQIItmϖzXq15Ű)nF 6۸UXkN-LxӺ*gPVev' /7]G®6uѨ|_ޕHRRz͉t}xURբpK*'Ehr:g|a\r5ىM^elhX*MԋU>g57ʴ^a09| +&ȡ$ :}Ee&>r3C$Ij7+n$Ū@OıGĬ w%۾x[ ʙLq$YJT?ZH`@=Mij3e EV zJ4j1Ҩ U"#%T]^p1Hc]c3ŃgT(+^xGvG>##~ ff*FHymڷ9K_8]Z-G-M`P3`(V'⽻"/4$* GJC >C,(Fҹj|xׄRw_qM͕T'F1Iu#VI>*s9;,-ҡhW/U܄.c@*+ tBꄖ Ò ڎw82^Fa"-HD4eCX&?sH)RPX?ߗL"ndfX(+,&(Ґ t3c h/h:6e-kW+3ے(h9>c{!Ā2%V=uu( kw!plŧ˷&H&v/#~c۪ɚڼ#cx,j~d:iӝ3η!_W ¡@Q4מey3xzNK rK>ʋFIprQHɂ m9< Cjye> LXRjmPϏ@h,mje zv>Aƕy\}%'q#ک oD4a~Z@7%RxbK8?qVEYC('PHj2bC;n~ɫ:A84XЋ=w(X4N0ܖ{_da ktG[fbQT6I d }/65ȓ3BZ-(]@2sXدuՃqi#|Uq3x4"&{xy:)}U2R[IpUj~͙2o%)]1b6U%޾ԢQwծ3jMGF[Dhild$AcHeD^2⵫Vi+?} e+r z]7NdWwr/)0m^1;{/mWߦ4 :]ڥa zz #Dx 0hi?s.K6U9i$Ȅ]ĞSI։89e;һ:%zI)80m6k$m{ڂs(x!va @`+b̓YD0O˗82U:Ina0(њl8hc/.  Z[1 L*[n`sRi,THJ< qG:)0]4'CgR VQH'rŁaFqڦ.KI.Hf>&]tOz퇯ޕA:g%ϳ[i Dcp.{kagݞ2$u)Վ\!Q<7q~GyP˫ng-42O bOenw NjRX2uk1;y' !KcEzgXxFt"GNz~Zg75HsAW$!6C Y$%hw{@j [)&Z]29,V޳-t3+բAZjn?L- *, қPd%87ʼBvJN>yݲ5*f%6ͅB'3*,|x3:զusKe& wp?[-{ӄvñ˟];ɐxC"&Ĥ#%?),uhr., ]SU"7- s~訆*$N6So^7.A[zKt+ݣ ǔ'u,,-q#d*%B`Do a}:.Æv8@ovY@e[1b\DC7v=NĐ ܘ"gN֖}\^jǍ, t3J^ h uo~y} }^_ƃ @$v\j^?|8T. 6>֪T u o48JL{Iwg? /P:/ 71ktcP^YH O2!J!|*!Ok!:vI3kPsrhAN)Ya$?7Xj3L_|G^n`r$T,o.93;iV2A,HbU몷) o⟟_M Z;ue)4VtMW,pBo.d\IaBQy ,b6SұCDw_k944N 1P>u˚K O$P0Dθ1u&4{;Ehŵ{8 Zc)?7TT28&-.)7qwu*@DQv-NPX@Ƶ$a"?ZE2_LYjp"tBFxawD`eX9ƃqq_9S7%*]u2υȍ zJVwtis7 oA`eiG&Z`Y y>aN*ա k{rӋٝ!&1^0LynsA9杚۷3Vf7v -r ID|a"fd(>h¼N6eck*/FՁ CVLt˧:?>Xk=20t*YR]" SDŽM΢"!nJN-Tm:C^˜jpD`A'vSFi{N}$(TV~>oͽs,\w[fA+qt ֏ߗ k5u ;~!-0h-daFZz'i- d;XR ߹ fWDjӅA[8 8+s۫%|76(I.lu .hbVHa*U)Y7IA5/٫TE L-A|oN]DaN87ף 8Ӗ,JfCSD0N 㗾eF­n2 wKHa)MaH&=Xڴe5 80<)GdP[J]VFoMn_:_̥IvN8uM}"&aUߤL. |Ζt8D'GU20!^Y5B{s%&8FiYJv^ \.;G[ W=[,dvo:1/=ٱ[b\!eOOՎi];F9𣒌=A0y=aI?vBO&,3,$z|eOsת:EJ 'S;L~іo{';OM~'f|#(TzFE!6Ρ|eoҡm H1Vk&r} bq%^s^i$+K>.Uv޸$hrᥞHw)坩S5 At߾7;2,8h7<0CNs!?D / im 6ehDhHI0\!09Pg!]; (ԑV"YZ~ !lUHow'6\#لƶd3 sN+'3^-$9)@[_r4cWО H;6>!nTRt !_N[h"&k԰Ϸ`(yk@FDϭ'4L_wlfԍLɫn=|m*K2EG4 b+:U:zN,8:;|$,V]zYI*m#ā$pծ m}3Q 4nԠv9a-CK扔$MEW.;!Yg)& ΕQF/ECvw}m6#[J6Ck9bN^gr͜;PR#>fSE` &YT;vWBԦ?SKzP(iKq}Mߣ}LKen};,9,DT}2FM>VvFkR$k=\ˆҿXhfhgL_ KQ2O,̙?|Y֮\']56 ##- la\.|og7TigRqZx YEҴ.Kly(UbTvZ#֛ !bf\*])߿G{S\c]2՛.YbZalX43H4@'y!d)5ed9QiUa(À3BtD2c:cM[ J^ē4$3ܱ2Pܛ#5}l´Y\x Oζɟ00Xy;O! ZԇpUvLu8>oZ98p87C 6(!!A-(τD(=YMw= Dɚ@s2s@p ´/H物T u* W^W[ߤs@zmwA6D+K q,Yn0F$dYfɣ&DŠw=HPaK=+4f'$ښ2e?QܬEh)s;g~uRǀ`X|ݬ\Dχ7nJp$G܁w4O72ݏ'Ή7Z߭c$E8GU Y=w1_Pj/`U0FjJ̪A^hOvЊGv|pMX ip1ԣ 9|P@?8`H^YMz9oԔ:(kJ ⸃Gh?E˩ĮjL={F*TzFYERroқ\h<֊tZRVPYP]a  S!U=k /_@6'a@\38k.KyWrUc,Z~&xg9 0/ypJ6qry:8#\8 }]禷)W,M0h+uG[86= ݄긯ֵvRO1R/8Xa Sfm4NӜu'AF݈c1Flu<+W^drd;giOb;7zݒvAWN=d@t}ko%{d a]m_.Wۤ(R/JjGk<~薡p|21RGpmRn0ds%ljFS]Ϯ('KB<޽l 囹(:[igN-=HUH\8S$4эŘ`ߑ42M zU?oC'%>gI~'czAMO M XI`n.IZ7 r,ů K[QNDŚxK 5&ddxy.̪I^ܯJ'9= wZAdZRl))uFUZxadݶ]w91L߳3 6mz!7?>:oE )'ӥg ݷ«T1 )CV4V~}Qs8\'.11RDf'cmڼ j ]*v*\q)|C/t_A3F*N&LYV.EС@Q>ټ\kGfr|iP[Pp_QQվyY8lWa֗plkG-hr9?9FzaMr~"`B U8 &'vrџhi&q;BʏԀ &=9'@DE-7dMA^qZsx^F[C;W&*+n,׾ 10˝ n~t.p4(B1A̖ =ucKeg0w1W3 ~.Zp]l! qmN:} ׳zurZ] -= [Gds%KGk^< s8nׁd{wW 9e- X!ZaSw#>֣_SE7$4Rp镋DHǼ#ڜӧ^%w鋣~i^Ěm̔Ԫ8p-:L?NL8|LhK]u].iE@>j(*嶣D;5X5bi|L <41Á`W4PdXhD^ giM; b{b ]pLjfj8<:DKV3 `w߷A s.XYRtY_D,`rSe/oۏzÎޒW ashwi5K=&yZQY1v[זV0+Y;Uf&QMVhxK\w0hKMKAcUpYEgǝɇ"Kw*\sCٛ22աcά8BxiP)xT²޹5_mtv?U-")ctцjXGzs`O|&"ki< R {;Nne`Cx7V1=XtYb6K8^0ws]zu@`->ANtR70!pB8Ru3,pݯCGa?!v˕7qz` lĠ5s?On;Jli ,RaՇr1Z~uO;%_[Kip]X\uOm9,ֳzhO(r s`5}~ѶW+T#Ww yW{'INtG(M X-SqQs2l(+ Ugn^,n%c6pY T};cyyW`nGmRyDVBwP@A<«TA~5\117ZcF0鲽#LmB;w!o8htpGu2""b6:yj6] ϒg䖐O#jkwVZ#]VULt1-G]-)\ $Zߐ!LR YސsLhaeDk$ZÌkxl8t$aZkMФgPP."!W걖.8J]գ>)W[}6\YiJlCkpQAv1_f!$ϗQr@ؔ\PAs-/yK%"9Gj.,7wMm9B4 Fig׼IoBoa@ G#iJ +<Q'[%3h :gituozLw+#r&֢ѪWAhSoFcg3y!72x$1 uz_-"}[jMEW3)hݓp5bBNM;æҿhTzkIPpvi7SQlldT Hi$(.R5NzR5OJRdtŖ$;QV:M O3oNTszЦSnh"y)vzg?HJ:U]deSi5nm!~9 JI )j@EE{)V{0]mKagTӌ"SӻiB2p7䆊i.AU:#]/2󪢶ӱd/m(XA2gu3GB` {0ů1 o.yo YYkIE]޳x|4YVN ϻ: Zrah>>v$e 7 W]}OjEԸ]36/dįMRLb:5k&!fn1No 5lͥIwt8e@ְ+hm1g\! پF Ģ!MD ql G.U ܯ=%Uxc$P8EϹgM5G7;HGڊm'CzMnNt?c {Ô"LdoO'nҨ:~Fx9(123*+ʛ @b"plJT=| "6rwJ UH_KHBtx .rш51LchpwFهk^s_fng><Zl؜abҨ#nO)#q|'H,6N@g9(既Vʨ|xXD޿;٣ح w˿dWӱ@;~{MwĚ\mxCW*&8èƴ{ m]o7w *VF"%)E:#* _puK+M',OQAws y-p4Ż;E[$ũw7$ a%6Q$r`{̖tEI.mki|?f  p;aF0֍¹E7_ym0ǽmz᠀b 0t(oX^걠ae"K q<^Om4\1jEcj ,w,Q͔<۬6ڨWE!,?_68z S8fcN$Tr}@/.k9?IScj%&$X@֮ڲ5ª~.0scŪjl}8#cysg1>6P`nl+Ά')Br#c_]o6w0)o)grMu}Ecߨ߸» mgSA mɦ/,{&-z*k# uc柼1c<¤$=`rBOuAqxid4h$٩Rhx*QnB/9qosIO9q.؎$f0v7uS \~ QY3ɯw2re`LqmY-d{WВS.I7yAVn"R&9ބ"/pZfo`)B@B1Gfr}iPp[L.s%0 -^2S0HKP( B.L-gLb%KIqU7N¢;Iv>{- wzJz!h-,o g+pHӚf'f]+ ykHrRh=F1#X, 0-\ITw.r\*"ҟbqن|aSiH .VFb0yE1uo+u 466)jߩdFȿ]St?$pFuR;> ϶L< JK%~:<*.dՓC93هaW,uhO t&EAY;{09*b$ $zkK!2Ϛify$Ws+zg:BEo1zx[@FvZ;AdI(wCAQֽ1E4a]0Q]Z4yB r|C#ਆ2#Ip -Y ^0+N4؜;\$j2}gl:J,ǼB3aJ=Ih +KIvb^:~ ) Gj,yM]Zh<g:y4S`:O Wv-r !y!|" }uAE=Zm3-"pSN}EoӪ/z.ux$k,z?iFl QqkѨtSUn\c[˨'q? ~0M:D8 \5u9ͯv{S?{HE jy=Ȝa:,&R]`U.:9lw.Vkw(D2'k .{KOjȦBu4-m/KPKWgE*hMB <6G!VfrN)X*`#4 #%SLxcrrUDz1|NlP4g&RV,{hem A| %/P:ޔ~A*PSm Cr]0vˠe}5ɑF< yCB{մ__~ՋTh6eҊ#|Dz*kh15/t&Q?eK*匜fH>fJFK_v<AV"SqŽZp!${}OfBGM&<3X@GK1㺛пAr[Z :şJ}@$MSl!q Iy 0/|ct+N GC*eNχNDZcv\c-݈ݫ!fLyWт R|څ5nVf9fk~Ebe9o;Vtʈ3 S\'wUkx Y}^vѺ3?N4k /ilIW `V\t5@aMG+y > endobj 82 0 obj << /Length1 1632 /Length2 8758 /Length3 0 /Length 9824 /Filter /FlateDecode >> stream xڍT.w8ww(R(N!Z)-Rݡ¥3sf_ޕo~w}fr;al\U-.n'';''7:=fKN:raO:Ysؓ#bp s sr99Ț%G0^žd xG8@Y0[SEKs{%L0D͍j#@+ 0@'2vtz-O5 <)A@S <h+!@*:5;#bm { @]^{ 0[v4wv|7w5ٛ[<9ѹ9@^J`/xΖP w)ˁd`3dAP=80|''zY9=q|9uYDMZ ` 8>oVWo$T[;4pLm 3+9>Q`o88-Gg1wc6w{dV:>]n* VEvHm#Y,mN)= ptkl\c{7K0Kʁ-~7? 5@|7iA0v=O![$[p- =,KOӆzb0o7?'a r+Ic/?"S3OtZO0?ABT8-]Чk??wD_u z[vS%EƶEl~G?kr\J]ޒc\u\ڒ4Nkb}+xTm?%s6]_NzvJN.7n} %K!;%lQo,fH_ (QYOq/sX}EysGxp;wёR"^N0xI'+y},Zm8$r3yi@LDžH9 Gw(G:YVZsW<hp~zT˩Ga"1` ղ%JR2` G\Y!o6ln۴ɬq?Xѡ^vR>U s=b'C9^Rtsj)ehM|GV@~_]HtJ[krPT_pDLƨͲ'm!e[Ic>!5Gfyd)SLbrbYyO!M > "Un-N䩶h bdqMJnwj4PhMi;[NR$D`GBA#o+V)?zϽX# "̩w ؤjژ_hʑbz\;#봏Um@]^K#]Kh R^)P=aX!7-ۏ87sL8tL}OOZQ"r$\,j G!$AXcZ2po*g*zh)T ;H]kWDhRq6Ċd碫")?]EQ%aQN!1Er*&* פ]:!xRJ ?xj"VY;-$ w wDaI_ټ7̅R(bHsN<(hD`WʳNa{~IYWHVª2UIϐK-g(!-z Lx]g; 2t/Tpg:dz?K1Lkt In!{!I?NuFcf//E7F+DvӳjRuq%6qb|!לX FEXT폔D)]s-^{+v- ߰z\dm\~Y+^x ;X2-0nZUbKF~"qGx+`жY^W)BD%.) !R`@ ݳrU5CCb`/4}6`P7 0SBt#uiDGn-ѕ4X8T&FtV:o@{rBn-(Cu46'qח,P,gKq\ؾR/\8enu6b5ObB$6|b&cLHu}rTU݋0A\Yhّ"NXaU$> ]q r:CZ Q=Psb~*}L}"/=Y %Gz4}Kty8Z ̖Yd⋅3,\yrjZ L &?6z߽=ǏGw}7W>gEy:j 0 " 2A>:ZgouuGD,}i»"GMŢi@A׽wt-ÊWBS.h#BHhv- mokN$qO)ݯKB`\&<+@/&(Tb;?@I:8,R km-S0|.M6t1B&o::)Af? ayf^a?X?~ /t+]q ĩ}Fr[ȥK\U'ƾ(gKKwv֮eWF Bt 1&xA Hc)wCRJi@M! JrY˸Vb!"Aͽ 3] GڳeTM5W8kOIK"i >7cYLK>B\] a}.H${U΃ Xao IdΔrֺT)mvy&uL"S[R_$yyw_$0Uc@~kGژ>FӼEjo&e/><QO f:X\a#39ٟy$tñܻ ӴOY~=794dl Cb Qln Λ{368@t}ТeQ9r¬y~hbB1\iKF=̋_,Sx9\^l ')9!NifN[VHy_xz[69ν'U")+1?yڼ;~ p)1?crl[xD!O= Z5'5p&VhVEc턳n@ZKR)r`m7ZDyȹ)rS8=i=ouHh$C+.u&\8IB!-+tճO .p TR!tQwBo40_(0X,uY i0i3Ȝ ~MM%z"/꣸s_Gli;Щ,wehG"v:  - s{sDC𧃙/q#t*ؒ V1sD7&WΚ\uSK%;6|kgg6́\wj=I̵Lu2{;H& ]/ViBJ؋-r=Ԯ7A[~˓ݣT?8s\Jb諌^h*PR9iNI۸f g)JF<^V==Ѵ2_en!=G%etO.Oư4|5J귽->B43Hg47bQ6n|C$tD x!~Um0o SDH꥓+(Q]9dD9ߕ֪+:Z[SDl#1U q&@V#oa6j>,{6y j(Jeݐ<k@:>:g3Z~1,$8n!ps Y|PJ vwu1cܬ"eatbڦ)x:>x6`,Y4Hg>L@"O-QL ׉WLVCoN~~.MY+l7inC#vBDC'yST~w=\X6)^||+{~Է*+Yj)?i/jmqv^Ya;zט0' IbP?W2M|2U8TEf7CjaKF|u~aχ(Alju%]ju%u3 FX z g`>}Ysl]j_ƴQJtGdƷ,ŧM\*G""dϝKS$tlF* P.&eo8.71 ?imH,o(# L .(iWK,G2TvH@A `]5@bwmqga\A'=[)8!p˩pnvMǞpEg~5C)$*\/5[d4Oԯ:fjU(:Td1^kEj+nɻhHW1h?\T< 7"Rab6 9z+zғV`nz-q;D4|`U/6956e/6YL71H 4z-h5H(Vϗi!Z!('QR6{~K ͪƇx1H&/#g*B?ojĖ.ί"»]G(xܴ2)u)uS 3;*H_Ou?GdKW"h6K$SrLrdsd(ў[&B5e ]| O."S V) ":&MaT3zf5)܅?W.)K yU?f' ɟ6/H}ޘ$K'[p(~jrwg?ŏL5KZ]OszU9n3.=Ot:DgQw_^n~ + |&=gh6u;?PJe# =])Վչ۽:Qd|G!򳼝0N>1UڈѼC6JgP}!4UĠ›SC eD=_fL1#lK7 7yn~ryt,J<%%wɠDt;Z*̢JɤToE=} @)K_f+=|˦{Ii#xt/ti4Jȩ,PL1xgO [wޏ\VxRgb $&.[?v}̽ ('{)@|Br8^:`he49au?܊AI߭f׊Z^ާzC-L~~7x:A+9fB|]>sO$+ tD:tcuM<4Z992Ϫ,e D#W;~a-Z* A~mޕ'1j;0 !_2'j}Cҗ(8Ch6@ޫ39{̩t浢jf/bE zmS(9'DjipM-o-_gAe*3WV3bNQ)8vU}]@Q6G`jo&5kc7yS&GŨ?m-T2/p8mZ)#ua*7wV]vbVf]11g_߼'b׍'d}:XkG8^ mh3MZ`MhQa8 endstream endobj 83 0 obj << /Type /FontDescriptor /FontName /BNFUSO+CMR12 /Flags 4 /FontBBox [-34 -251 988 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle 0 /StemV 65 /XHeight 431 /CharSet (/A/D/F/b/c/comma/e/eight/five/g/m/n/o/one/r/two/zero) /FontFile 82 0 R >> endobj 84 0 obj << /Length1 1561 /Length2 8193 /Length3 0 /Length 9211 /Filter /FlateDecode >> stream xڍT-tH %5tw7 1CtǠH4JKwHwI \[5kͼsss;tTZPK,!VpppqppiAtAn`(D_Ү G1N (z88|BB.B'PB@ntPgW2=,N Wbnrz\}SAYˋɍ j+4An WO5afltm;v-+hp[ nk+qq2@#Xpq]_VVP'g b ;jl, @ G7c1-Gsr;QdU2kik@+>؀!6HX{8@. !&l w/ /y[ٱ* e~d u<m@?n ߎ"tNN5` Ch 0x''GyYC!>>_v.P]S_Vnn+/@#oU8)ػhx ?'TRQ1/WwC πG%{?N q6 cU@`*[:ǣxyj l;x:Q>>/o$`uFvѯ[ rA+\cc?17O<\]J}l_eyVa5amUd^;ct;zi?P+߆^J&YޒaX=hClIh3לiE_ /<'G{Ϊ-O7I"]z>Wwm瑈/|JwStbf,fIYQNg..r(_q5\z}3r\˭Ԑod^"o{N0Wba4"NPR7 r=7(}U?2K6:Tp9n'ФOlV8~׳GED` ׄ B٥oY< ;Nme]{ p ԧœsq>w`dvI3~ok%{%"r;'y;XE~f{~P=[,vFꕿ`<!&Qo=oԵuf AJϋ- K&M5zrg̡lܩ.g lwwЉ(-zXkg)-? i e\ASNBt'K.ī:[%cDS',{$P+el2ߧw3vl+/yhť'wھiV,`enZ'4Vѵv*lW|`'ȇobKѮ~6k #Ąae,x]boP "'LAwxM(0+tQgk$ïDxs-xO)1.2T#-.dmN"a1n$YUT|qV_d-ؔA^odן e=2]&}i;`$qe=(N$5NR$Bjw6E5$O$24E _){CѦ(bo=-T Ý4/o/\R5L˟p;<$ĴI+@xR"$RPɖ髾(b1:~yP+/_P,bmf 1N^XȝM]> wnl~ngc1*ָ уCvi5Ӂ<ƙ6IuGRMnXd1v|O^Ez=[ATfQX&|xe۳yOG6^,i{D5-u(jh$ӟ+較s . JK.j^:/{&BJf"#\Xgb˗7=|>f'P+TW:?$[/3{sEAڧÔ?Ci^Q&71|=zp?;Úgz5L)jIiZL=͏r3Ó񥪯bFå5IiZWq;7"/:U/t1e0#)uo*W} 86)!fSk}!]X5%^ zK-\lWA1%С_[-je Xs~g@6B =qQcI6~y"/oYK7rQ oXEIQGIZ r3j/ZB? lKc4=}5uZ-8 9(avdGB_4h{Ê@puϵ\nv֦dczu8]8M C4q#HTjZ[w V?iHv6S(Xp 7^b"&2ۣYLTz6c^Af;sZ|v ,ѴVOW!^ENV8PRB83 c)zQcӜ G D z3>L F@&3S!q;4@^h% ԛu'b!YssՁ7U̇AXO$y;'uwtFNquXIJ,xdEŋ`2ĥ0 Jno٢9:nZF=oB7!,ƻK~'tĵf]Hk؉bLw宸h-vJk{< }ITrjb~T{񨖩-P*`g4+MIo]WTQ -SO"7F+y+7@E}g^ܓڹ:\rӁà j.ɋXަ3R#~H71O:Xz,V.v wFbndClxqs)ګ0[jԬtȵ]|~o5]S#15ߴ~-QVmayR7zbQFtaKOc>WTOu+j?AIA3|P#e^0$ 0OC\(H~ÿ"V>3gtFY3/nb'B7; .䧛9pd R:x!Gĩ7?1|vqfl>CnZ,BG_۠ыwpFȠ~-ԯUTӭA^ri#^<ءRzG@ɺdZz7Jܘ*.^cu֨0mW`^1r;!C;<)ކU. `B+tt=8-U& ŗJcO5p3E+߆k Cdh#LQo[ /*rvc+Yl>t 6+sw$#5E-iJnX@T2|Rc'fx]a DS!G[`OVf F7V^£/GLrDǡ{X r4͡BN°1#8 %uskcsryyf>CKО~U '{Nd52J \r@ok%\ k\h9~;wfԛF#F!$۔l練dO^5؄%kxIEIV*P%fS5 C3"ZU[.vÖ R 'Eɩ[WZ |>1Vw7qo 7^sٖWhV;LK9|bao:~bR8GZ2^k!hVu9|~mz_!ۛ癐a{k7^9u#>y0_ 12>z 9}n}:LA0_jͮP $y`3 [Xi93<j(R=7 T7?]IzD'g,41ʚ"VO~a8fymzir?*z2cW_Mi31#(㲬4<uTA^Gp (FKE vlֻKmZTW1Xrpva 5Bfut/J8Ѷ bH=wׇyP(;=P v |K|RhIN蒴y|R_:qh3T;si ЪEQ;=2 .11Ir:z4;kjh<;X REI ca~^BqS{- 0$t\QD`/v@l??՚vW miQ%BEa [06d-'/A&԰{Wŝ( ϗrQohLo'WH#e9ǡtp)( ҅JE Dƅ~e %p*l[:--z0ɜ2xAG{7lZm$ Dc FBh>jɢf`V@4 (sϔoHTH ]ը-FQC9:0agd3F 7ؤ5ic\pARYm,b%UѓNļSyTox4 系{-E|NIzUio%h&T',EE0i5\ݰ|kYrid)^ώFMEhPK)wJ]vRv 3#FfBabanR)'IXBFD+pXO!3\yDC.baK?d**"/ B#t]Y;лrjUM84K4dS%>lt<JUhMy>1='N[ѴА|9h&ްsÍ$k0kag֞ Љav}Lq;yidX E;u!\ލiZٺig"'M%0㽴b55YQ@uԔ.|W2ODE\B{`t^YȞs:.L\j'a҇vf7`(1ɏ/>'Q*쪅Z ubpEԴZ{ԥ2Xlx)OUƁܯݸF}n!̈́|r7qDrM%eT/iNm,KJ*3i&k˿P"GjR~)ԯ6v'`1q˗/4$Ix7(D\޵>p#'nߟo+g5D{3r8B<sqgQ9m˝I!ӛ4A\Y1۾1 ̘1eRdKL>DQ_xh\*[Yܫ씅SςxNў^nw0گi-g%N)+9ЋQx+ ÀS8/s.kBeS~RDڄ1!LHkv涼VĎ!q@%43, OX#]wNΗ^dg-ԲafrO່he_R7K'i!cw+UPNTCd O)9x3B1¾#QY&̦'n֣b򳯰2cCfdLm{6zgu)+6Coul|BC܌r !F u5my5Ɠ28(Jya5NRGkꩭtnؐ>ڬV-b-j*|(Bz[ަCB̼,BRRňҲif/:,먴m^]̚lJ(;B$św6$yr;WWRܚClǓv>q[L#GD&N-aHj $CO.w=p}(1u+ߋ0}<{EwA® y=`[f)OWzLn>O yUcZ~G7&`M:mvPB|uF\XYvqk~} a4HF];mV%9(:rTî]d8cE9hkNl0${{dkl_+XIG^ 9q"\T Pz3qfr3kne8adqPm8f&v9QL8&fJ\ S5Eu@065 \5<Ó)>qO*ڕXOLT7_ʈ,,oiy*e蒥ЏJfs8HblKo}F<v! _07ֲɀϙy[RUCӽB]^w99ro<!&8sA:}ߦY(% ? W K-WdDfe6Ne}L{!kv!%=z Q<%m hwu!w&bNĤ[֚VRLEvތ ׍K=)4}heRy| $Ƴ`谤77{gk.WM=׮thrA"]rђ; }of ]Rօ#& _EYb8"//%<3h>*\+SJ-?Q8o'f} >ԧҵvX)-8Iem׊w.Poq-'Je۸屳s[?sME(VUB4)u<̔1؝|rMpr".)SWvsKxJ @ ] lӭhG9@16ތ Fn9F\<$8'gdU hGe>V*(M5箑z^-S]O8v ! ঈgl2MpZItʜӮ Ǎhӊ1B?yڠc%hnG\ԡbgsl>\0e]Jh$@m!RZ2ᒝ.JFz0Dx’DW@@gK443N<\_z~K~ܳa BfESLhoXX&^1Y[2,Z3)~;dͬ3Z5m*:6Eiߍy|1,{ݿ7H6[w;=lۊ.pk62.a֍T;LO:? A W}/3[!lj^NZ>KT>8)%xt"!2b@mXM endstream endobj 85 0 obj << /Type /FontDescriptor /FontName /DVDPRI+CMR17 /Flags 4 /FontBBox [-33 -250 945 749] /Ascent 694 /CapHeight 683 /Descent -195 /ItalicAngle 0 /StemV 53 /XHeight 430 /CharSet (/B/T/U/a/d/e/h/i/n/o/r/s/y) /FontFile 84 0 R >> endobj 86 0 obj << /Length1 1496 /Length2 6992 /Length3 0 /Length 7995 /Filter /FlateDecode >> stream xڍvT>C6 ؈ J R"H R" DJBB:io=u\}7#B!B`i &7 FWAXLƆ颐@-7 DHH@a0X@4Pp PH7[prFcwk qB$~a^( E;ܱ;:@݀( <2h4'uBy9 hg s ԃ~pM޿ac& a^@@cM ;XwϫB 3g!W2E N@8 WBP@7 "ܠ؀_ P,?y;x!خ#!gPiAn>d I (//R_9&Pww\':(;ʽjW0hʫ甜0UNבbz_'eUCiͷu1Mg)F#̀a?o*bXYMւ/=ãQ꼡+6~@VHqJavF.FKVC#62?Yĉ|nDZVX" @Hc_sZF)[5|B"Wlm|F4ZNPv\B.ƒx\';4=ӾlrlU 26C25rݺP ~'Q֑#; hT?`f)3}c&ޯuu.uh칅KzK uV>BmvP$QqydHthi %-\(iZ;KL2\*0_tM~+|2=ju[zK{s᱁&g.u]AN̖ܻy-qݗKӲΊ)8QMs`XE +8o+ S!GvuV.ȧvAst*}R>ϲ<6- oyߴ2=ӳ3ob$NbH`7h~vbHH{H@I]Vlůs'mU}@_lm7j+}7{N{:.?Y޶)6vW0j%vx7`DT@(hs<(ny+SJ'̳#Yb Q`A~)DB>ԻŪ'c ~=ӋpPlmM3.C22:_8B$r*z>R+z8f^P;/IΌh|r;:|O I$bC>Ի0LUVwܵvc 9j$:qfU)֥|]|d+ gֹ\PmeiuBE?@ʂp]rO,kN]TW9֩"_.ILCQg ZI:T7&65Wx%UMdb۠,6,HlPQЄ(c-M[7 e9^[ڢ*Nƶ;Vb>;Օåj9(ãLa1O3 C[GCy3wi4 Dp=ܳŭ Z{5M*AR{5"4>]2<}78a#]!7*?q^#>,"P(=i-;-۠l ly4+G!zd jXnv+MQX]D~]Q,U5ɶO 쇧j00i"~!ooA4j ~ǀ;6}ը3 ݼh9r m=JhSţ(faZ~]KA$#S1XX-j|},V)Oj=*ۡ<p3|LCwZc9g )H .3N>L;+(,{0w'fDhf2Wx)8YߔJ{~3_ uV {Bt;|#aO&(~r[M=7Cx!l3=e8vzm` Hf[)%% Mm}r¾3cPLQQiЅ2S)d.JcuxF̂fQ'Z)B~)?6!%4oZ^C?4U>99ÍKZ*+ |=RiL~&ONSonIf~F4@ :{g/:yD!1'z X2lhd3ț1<&܉c'K)AZp~ꟸx#)N0,]lӥ7m;6ovSS}G(Ĥ3zѥȕ ='GzzbO0 "[ZF>/@*հZg, 1dZd([!z@|=j3ԗ@{o" \[|^FMxEBl8a ʴduMñLz9m2~B$ڟ >MSO3NbHYx6n$y9$9pVnk#(;c;>Mn_J`ʊolљ !5Z{ D1Mވ=.{2`ξ2 ͽ=Y'x_PM>ӤdsGs_w NT, e{KTe+B3=;yʃ:n6z@- 1n+rm%$5L'h&t*cA1w$44Z` WeyE}_8%ϵu$Lenk,'܉ bfDr`puZ|mFԿBmgdyjn^:Euq%6L fN{?ζlk(|JZFIǎI>[n?)8AC~3Q--sy@88cpop~Slj@lz}`z˭ǴM%+yd Vw\cFB1F_)$2W/BUoBzvo߆>/J\w٩<% ɽd#2I#^ ߗ7|<nUJ=z#8@/KY 4|t/gixYSV8-c_3X%8O]s8ll&-V~8y+|l65blQ-Zͯ;f't<' 9q =Tta" / zb?=U IYq)Ys~Kl:B\q,)MS'p1 VC(\:Fab'H^o3ms);Hy7:4 U|vMpxٻ U.3V ?vWo׊1nn*frP1eJ2KnNɭ |>',\ %K\\|ڄ*yO$Kybo[vhWQ6$܋y-BjMkȤc,Gu)SgdUpEH\`n?aʶ[r]4\懒JonÃHy7k,"6MB敄$C־d$|z޹.H1JZt6 #pBhäCժRc9;2-fCT<^f[r; v<Ǡ]Ern(kA&b)#{tNMohϝ #YVbR*ulN}h̡jOZ8}D־'g'\һh47F2{'U-yj*S 3"]9\WN 5OK$#Q{0#5|0p˽?hrRDI"i)YOmM#|;CmlV{;pak`LՕ$m?RV OTڼA>ܷzCYܪfMZ`[SR+j7p_ \bQ%5f,=B}5Z"ѥ}.ޤy|Ɔ:MJ"5𕨻 k@VPfG[?%q<)7rف'{V}=l[8}eD){| ?W U/89r`꣨J+HV&DLi(m.\}P$_mKI1+5- ^kw̔Untū>^c=J[q؛N%~+>퀦n~ .; *ie{sQ~Ziнל. ib~.elK]q $ ,d 6 I>ճ:E,?VXP3\b8fsEZ?#\]6T"Fc[̊㚖/II7m.p4!itX7#җ>7%M7p-?>]L+Y/,gdvs_Rt yK}lы'{ M4n)jO"KSϧ)VKS>_SF)PlT W{E}՝6W2rbRoSHzb¼2NtwHk]8fq4{cN'vL$;裪 驩l_Og߽u[C;oXa\/| o#n[_X!~9m4 ՠ\r2/hk]Jk|*BY8Gx-jqLHuYt: q"YN2T &^{1ÔJ,e<@%LllS3^jW`/=^ $>aEN^('yM0RMt${Gиks㊢Ib_Tyk1핔P^Lȶ언W~94<11aoY5L+zzF3A=8UG=1ez;6S䇉&v:Hm4-é nRs:*+\ OMb,h o$yu^1Z kUQ&Ckp߬xhz^_Qu}yaZB Ue*-frYgg'٩rx[JC?!ş9IgwE$p٩˞69Oq$~PcdZ7̶YE]2NXXR~N"%B%4KSzjiPl/ ޱ0bn|Z7y}41]@roDyn=Vַ`n:r|m#~mj9)' ؛}R~L[*->L#H(nI1^I|ō3Gw"z endstream endobj 87 0 obj << /Type /FontDescriptor /FontName /YOHNWT+CMR7 /Flags 4 /FontBBox [-27 -250 1122 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle 0 /StemV 79 /XHeight 431 /CharSet (/Xi/eight/equal/nine/one/plus/two/zero) /FontFile 86 0 R >> endobj 88 0 obj << /Length1 1512 /Length2 6785 /Length3 0 /Length 7804 /Filter /FlateDecode >> stream xڍx4־ zA0DFoc01^C^ {ޢE-D$AI޼k}ߚf~gg}}fְ2pW(P20@!> P8L?`[$jau(@@ "! *@pw #[O=@xp7wUG ..; vla-[Ud A0)8H7 ~~///>[WQA:'2@+ aw@zٺ(=0P踁a5@O_DJn0:ʚ|Ho$f h EQ񶞶 {ey=-~; C@8J:f%" C"~ B^0W/nF0ڣ? 6G0  '_ }(~np78F}!l=8?\ ! $;; vk;`DOד%Jap-15ՖC_N7WP+.DEo-#&GƆ p( C;_YW=~@ -8jB` } k!mQ3"sDW!_vB ׅ ANifj@!0.uF䂺[vQϺJ0 lm}P @~Y{8GB(;ޯ m'&z`(&AQ'R! w_su<(A~IO?bRe˜ ;k~>yg9 N29?H~&|ԘKIYLO /mT4_bN4".4$]0E5%!"w9ZdtHtXɝGzIzݵJs?ı(4s)fWG>L>LS0 >_+P5 &/jQ#y(3htZL1YS:wU_`ۍH 1@^' *RFj79>F `~)p;jIۏ' dB[5ZAl~QƁN5М^mCe5S6ǐ6|Wq;軿JZ_}tQ,SWh[yxW]Oh`E>\/;h&-2M+2U:Ѽܲli P{P w{ .?fQJ;-=nIE?eTIeI$A9Kidw$PPZˁva0y/O!*{ĵ|\c_Ѳ5b,LRgx&I ?Z#gKfw}xP+#7z^Ўr9#LxXfS-bE1!sٳ5SloCdZ^ OVYUsշ9Gw=K09YQwQ9@wծt+rKՆU}]8@B?b?58iLT#h Mk ?y$NXdhd);V H%ZeOP1<3dT%{p(5&I@-+R!N+N:J6ishFp5VEg?ΰㆩO}A~v9eEi\j/;{S!}`>{R>BЁ]gmzK9KXj=V {(;Q]tn)+PU]RGw\D8O03a}fbqob-nԒT ßiřddKxQ}4հAa\(~af'/|- M\ [6©Nlg  +!sSp /o5~$ԮAĊV@kY. ީ6~=1e[cy';C~tj,f9$ԉ.kO2Xa1]$]\H4eu n{.2&P5I>^: MIYV(2WK3EGKuX>is#A^={uNokht/ K]tq+f״EDbKѳI8zuLjɻVY_s/,L}J r[k5`Ɍn&.*&.ڏL2]8MZ .o>MC]Co?UcYHYٮWOgÜ&cס4OGhϒ?/v۶cߏ|ښ<q Nu)7>9[w5:Ҹ v.lO-HPk]^]jʴc I(@48KIA}bxBb -2#T x+]w?Kkb^zny\VD!|1Q&z 4y}JH d\jVaR ~ [@66"]؇$4K/^ hTU8Vԕ*/7DIO'f,MGz/WulыlwlL='.baΰ=/;iYsbH#HyBJ`/5h :L< =+ۇRƐʅG&S#\%(L8"u sFmS}@}~r:Q`QR?o5H79x{X=(WW@~&PlSrK)ˉRQ+U4^,jZkbacٮs?ɗWmtm652&Lo]_F&TD2+]={B=|W*Oۃ6 ct3:R? *E^2Z8AǟK&ڐx,9r.dkk7Rř ӴGud?*@D5A ~BHe1Yw鵿^yn @xe#LDFWvQU;!}j;S%1qr+f ,Zu0f˕eqA]s?ʑX%lR>J]'Zdޅ ZJCsZ6Erg?]d1Bj}̎ƴ(w;taNi1L9yҔ.!;E ~lRs]X[ѱIü_عnށ"\Nqd+]i8G'[j76|plڰ#)cjc!ֽ[vc?+6GNwѸ;+i ! yrB NKJ sh\ZhK%_ldvw렩p)P&%#G*엛n5Xy֌9Es-sKZ zT\F{ih2KBN]r>(4ͬWjtܦ1]>c %Vq_@r4%]{8Lx6/KQ~Qh||TN iMuȯ+tHt:9r GKƴn>ә-km!C XK*N O͛1FqN |fpwqf3⮃7OF/CSMbnoRc܃2>ҵ\[vO;tPWgw,/ kꦲ"*ߟM3Hdob1zrUilzh2_Pf {ECo6 H<2[5-}v WXdY B oV4pW龦i0B伜O6,SVqw4'cǏcKlyR(y@XX平L, Z~,}9ʵC{|/\g16ʕ/EB y'T\[G[vEnFp gyEpbExYC(H̊ފ]br<43렆F["R؂nnvh=@܁J]ܲ¥QlPs])9l/2m1 Hg4H,j^JGT&wQZWTyĔRFe4ˈ"!Ht_2&J'X8qb~q-#i-$PzĚG`f\2zu*M;o08*<X=N8TKԩHť/k`y6HtZ |k1{&$WRdG/34|0St6eLI~Ax 7&':ɼ( bVd}BdiӢ'VhĜm tߩ2Pڎcq7BU?[ +#J?' Sj8'Q6p.…E](oSbXT{O#jG%R[ۑwǏ[DM;>6#K$˜PrD|{K{Y-R"JGx]w;̫z*Z ä&=5l3ɭ8AiCҍYv뢂8S= ފІl-%˯y\MZ1CF߫+vʈ;z?5ϋΒp?t҇+7e#|*3ZxZC#<0z JszVO {N^/ǚ╡=sj ;Ehv-W$]4tiz"r9,JG{ (g"Z'U ws}}&SX0.s™l8<:ږ\#qgw)J2N|D+Llމ'w*"}N/\>@GȜxqe#Ц( ۽޺R: ΐJkQ9)xAC%fheަ2w=n}su:!V>P3(ʔz}eqq<Ӂ(YƋ'<°ut<뱘 BK[_6\:zF5\E4aW qP^Ơ|7]ƢK!qޞ]p$c7ƌhҐ<#ie'j]ULKjLD-_[.W3$z2冯h粭Y&g >\3~Q"Ks+4~\ߗEfr SE&c*7g-b ^SV>{ytmq}dm!|oLpwl pYiL3ѨvN]~MX 4ܙ%R}g~ t#Є[j/V(}685& ۅү9\j\EڈgUkY;Oڋ-#ŞM0[`<[0N}__e9XKh Y3oP'7[՗Ha4'%1a˔d/ψHKV10\uk^ O'[5xՒN7+1<4cz@g*N%M7}fޮdMƲoYbte55Y.w$W4}-Ӝ*.Bȉvy+,) endstream endobj 89 0 obj << /Type /FontDescriptor /FontName /OYYNAQ+CMSY10 /Flags 4 /FontBBox [-29 -960 1116 775] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 40 /XHeight 431 /CharSet (/approxequal/element/lessequal/logicaland/minus/universal) /FontFile 88 0 R >> endobj 90 0 obj << /Length1 1413 /Length2 6038 /Length3 0 /Length 6999 /Filter /FlateDecode >> stream xڍtTk6(0HHw#]030 ݍ%R"t(% ߨ;kz湯}뾯hH[# 8'U5 Pп`"6}(/, F190 SG*n$,=@0k:/@"0[;߯'i'(` v" 0(_%8P(g1 Ãʋ@Jr>xPv+ ;A(%b\ G wEgH9@WY !!<u6/?U @N` n 9B j(OCnvtE`# Ms0@AZF K+ sFI*>ey, Gڟ f_ k7gS8 , BQ!G‚ *  |#qC("0 `6G<&|h|~y3Cw~O奟qQ <@臈(?esjamp [_kd8@{ |B|=SoUeސ0;"B:=@:Qe=p[y@|pjCA@pZWد/:b詃8* }HdBBzL (t `@Vt] k~~ch ws  D3׿ Bǡա*q^x$o5#4X>Xd۫h eb$]kVnѝٜh#[WQKiMBrc3j$ИOvt)(s<6x4% ϸk[C~dYJI$rSBl5㜽hlU'5 p1'V=2$FRwo8wDZ?^2Rwc_ƪE'gam1+ rnq$nUPY=H߄n ,һ dMVj݄Q`A("]ztwg2a9Qn hZ'j.Oc7{wf(ni~{ri`]v1u8L*p7B0s| [Pbԗ'}Yݗtc:o(bi+H:0d`a8N0)}(iV wAR?Ni$})I+oWEġ>&A+@JB;ӷx/Rkf)>S)05@?/SY7tbUHaQ GiN񍟸n>&>&H vu;AfW~;1-^fL߃H/1 n_^HDm~%j*Lfl%Khbۢу#| tR+ z>qpЎ X7,)vF@dբQNYm &~"?IgbD]sr$U*cc*2i~?&.f-,AvW˔#aI;Nq*-dú4,#{KkFpFkSwT]=-3 7PA[0&K-Eb%f" _lerY[|߾J*Ku$YMc{"Gb 1 zBXҟ GdON/ܿX(*ad_.ђwN y#]}PL~*RE1Hb&%Cckwnm=J-oJd̘xS<*8uc".Po5…1>w0s/ku-6ԥ> ` nRJO]BAkvͷ^6X!3i{lz,ra8BJYo Tqy~j :4TĽ$FƟiI]*!|d2D0c}w+Te!=ߛ(y I^V`%ؕk`uc_ M&WhadC>@Wm üKԂSH SIzLkN<-"?X0Twp+0=̑?ӬA $)w͚v-]C$ G̟Ӣ'+bqO%"V:pf;hDR#ˮ!隙W|\R/)Ғ琄%OΦl %:c2HoxLY{B/ؤƞ藟&?ɊXWd>35L~V[vќk\zĭ&#o7as=3OMG䦦ݑ/%rc)WY^MbHv2n!:AMyRSq#NJn\{8v|u),< 4`4w˥""ZMpbtg צ!w:s˯7HiJM,'}[u>~F~@nĞ. ڢW1JKcK<bǯYQgc~}shzFXƯ+&&ԡ90aM4Hyc3߹޳ۂY\dL;| ؾqM o̔i gK6?E,drY|gĆU!Կ!7aRh]4sUr Vv]mh!xX>3%WBjLPTL"E3FOm a1. c̥*7U$[jKÚ?wLkWlV} djzel5iݳV0,U8U4JVʂZٹOqV|f3eiX}IUMݰI]ϸPs"լd$ f ]͝DCw%kcǽ!Xњ}Qiӧ$B;?bU|ԵXNͫN,G7G~} 9OjM\p]/|31fY23U69Nej 8Gn7bϡ3TFr?4֓zgGuS8fy~dn_G4:F< á9_KRUЏmٻ=k3[%S"'13|:&1?.f9c|Q q^ؠ"7"_gF}0ioBR[ |[xI} o.T#U&;Q棤#֚1^] `Fo@:F]Ceψ//ph.bImednbLv>~VQ{5Įr)CzNÔsھdCξM\Pj!1@;ibdLp,dk7"Q-?x/n2sbx[d.CD5rTy:ƛkȫtA[UJDqkovvi"yxFeCz؞`HhiS4 L{M~)ay#NHͤ9T; :GᏊq;ݍ5,doʉ7P.'iݣ<'Q';Q 暾]['oz$: I*<91gw ,G$4c =?x0IXɶN ORjkuW:0 /Գ\]NS/@2Dd w} k?{vt\E[^\w;h?#kSc9 1l KT7Wm"iqHHޥ,Kyѡ<ַ{$sLqݘ/^vV@wT6ivDbsO fjD^he:Wff?iLًğnJJh'r5yzlsz$sOZͪfګb;[nG(6'-4B?Qh:i˜xYHqj\'']AG9@™V}%N[vocrͤJ9ί #)FY],ɻI',˪̳4he*O+D+Ř|u2э\g-4%*=NTr$bkLWSZFɮ6lg\i5ϗ=Ur?Jٱ,OV5y4J/q1[V>$]%Eq~ʋ0uX?']fr7х" |f(f3,Ge86A25ZMw`Mb6o3wPB=ABEN9؟p]p%0{VTt_[OMQmǯu,9D=.1dcZ׌ $92폖in] 1Re eֺgŽjk#($'\jj7Z|,C[d<,(hP%r~NQ OͰ-w8>H'cpSI< V@<xR'ѷK{AO&z;KgsԱLcǘφ=ʑcЅ`ua`"6CqQ3AQ,Kb+dNAt:jMB +ͤh8 K^)8=чW}YL$_Eb %?S+7|:P#}q.CvwurZ,>u\m<~nVѦ4ch,/h麙cuOkIh`:5յ .bXoңs@$J0"v~ ݾe;^(`,.- :ŬC~x'g-k8ATн=\LD0pnYŦM^:9K,KRz>n9i @2)~z"r֓UkݳIR,c 8߱83 pϫH҆7,Xw%]bBdZy5E ^ڊ*RYհM!μ B~p yv0ul!ܝp: ܲmNts+fQᒵFx|wr]AĞrJ 1Ώ̶ C\Z:rXr)Йw)\muOщ@ Ձ& qjʑݹ#IїY&EM]t϶rx!~ԌE%LKS7RU*C3q]x'dڪׂ}^%(mɍAM~wUKqYǁ<]؅63VdȉpԪc6Y܀ł9 oʈ5@A9CV1ppP8Ih-[,8(>(s2;Ųh7[CpI<[h${MpuFi\f_¬]U"0r%<|˺j-DlHxqmp5QϨ,KSikӧWӜ {&]9T]R*Nhh9R];+z,&5y@}嬦SWEjZ.C%R> endstream endobj 91 0 obj << /Type /FontDescriptor /FontName /UEAUSL+CMSY7 /Flags 4 /FontBBox [-15 -951 1251 782] /Ascent 750 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 49 /XHeight 431 /CharSet (/element/minus) /FontFile 90 0 R >> endobj 92 0 obj << /Length1 1752 /Length2 11807 /Length3 0 /Length 12920 /Filter /FlateDecode >> stream xڍP #;(%@ Z(^hR(P8Z;be9{;Ig=kwL-k)A!pn~> *?OOY wGl򀁡Y{'d^z"||>>B=$ @/@ 0n`GS<l\d]A`[ ;\2]zP[0?!؞;n<@WA ;tA0GM+x0`_ ==< \ b}yn3 ك!vak{Tya#s|||bb;cG}_7ПJ?O5AOeL {x_؁mO'1/~`4~?>}x0;(?[+jwUA}܂na>?@!SRm +* O!^Ok Чys>a>ۧ/K#)ygGtm4ϞЀ>mZh jU8<97_r0L m4) ҆wil-=mUBXAa4O$ U;ϟ#@O.P?+" CxK^H=iz0$d 2C^=?ݿDS")˿)?0S(P/|:ǿ)_tS§cxOiӻ {)ŜJvzrU!KcD@$ hKkG'T9َ5}zgcR>gՀX {M1B}Z{ ΁AًIv2.Y/XxFb^fUNN2N^&(^ o-p!Өp2?TL2ou)߾c =ky6'(5vrРҿܛ,' KIv|?Aa֒Re")% 9 U<+-a)i\Ngm1c<\r4aYqhN.VˡJn<,fz[}P<_Cԡ[Vo(n3}=FVQ=3]Y@l/u7 {B\@I  1LhṴ\8~qz0us(r.Ri *bJGs,m_|I :Zy^USuΔ\}f`:zNp^'Afa'IA<Ģ@*ϠU-eߋd֐*B!S6ic/J7}gr GI|^ q0FߎJV:^ʹSALY-z:%洺cYy*44IҶ%]w{@9 D\c}sl秼=~7I Ae1|G e?8#/@%x/k24M*G]i LlӸ<ɺJI|F5a,uRugI?Te9;~ntŽ7"UEsh$Ȩ[**ĊgU<{xEJ۞9nq!.R^Pyqy-Od]5c,C&^Bp*ø珵񆢢厌)Tih19pgSM]'_)5uxXT3"fɜz?m`_[6)Q&Qh#ҠCz 8C#c>1SIKᆯyH\ !Oߗ]x8k&)3BD^@9b8A=NY:hJVZa#wbyw@$H6 =qeEa%<@i@v\X,SuVSxM/FSs-4Pߣ8ԏ|KKw9]5/Q:I};zՂ֨KkR<ƤTlftX4V~r R  No՘?lF5w?}406`GU <Hv4ZNa^U7$" ӫ_5Fcu`&^+a^$C> ^9hXWR "B +'ݝ:3c#ǚV? %|չv# ށr|,n^B:j[8!SA^3p(BVuD* 7„\W:W 2.)wTc-)qyM( Bֺ*p ޫO=**;5*+H6@rc'Mo8/ެS:k8mW^ Dڈ%L(tZ-SȑeR /H`FGܹ9SC\3[?q#˚I߻J6/9K{gCsWAed篆< YtRf>jXdOoXƂҶC o^.1ogЗIK!?#WTJv/㸭(1#o#@U=à2JTXi0񒄷5!gc&ݡL39ۀO[WĭbIN4` ԑb< o_OΧM(;ێ\(mFWGIgA%/M8W\Zl_VL ?x[Q-::G7lY/iCggD$oV'YXUH2+pn [nqG9&)&b+I٫8נ%K^[TDB Z9a9 ~^=!බҲ`}ޙExaޥXS~U}k,\#M_#/;'J>n]XO[3!]#TWe=ݏEF#@aPϘɁ9#z!pS+o,25hDA-z@mU_ qb2?O‡?BxkwqWiRbf+4qVأgAsIS)V3:H DK9E(Iw(v_X}Y.nZR#{eDz2jvb[}0bݶ@~eگ[|m!b,/!qJ6XyAFȖSX1t z1= M+vN|-PӵpZ>-LߡEt9*s!EIVɹQ*1APkٹU'7%/*}*G}v( D(4ɚsj "GEPc]HLWԿY{$O&b$䁆*%W[J =C10VtEqgE+:ԣ..jaX!w^͏daj@LxdO7[ M4fs(tsB ^RRW wvހzS<RA?퓕LA+-o;F^_ߜ&Y"Jܙa%Po٨y0yNX0n13ѩ-]gr@h# V*Kl*& sxa(I9%~0[7PSY] .\]IKH эBr%'p1? / t %]rY2sYf!$ zk-G,b'Ʃ*mbET*i,l&y ao˨=R"oRW,j0RwXEhGFW6eW`JxG/ݾMϘF:y/" EAM})F}]e5ZB6MM .}_~IbFD@`zn*E[l7c5, uY~"kF4` 7HuHa]#s-3_;"FKus)~eQb/;{v6{A{Q//ֶW"+HXg[ET<'ι#FZ!s@6x#iѐo1n-h37RM;9Bq _6 VDҎAܞJ/H|γYʼ-K>U}hM`ͨ Nj /u`g.r&Uc;dB2;SwX$݋T60[}&]q`Z$o9}= 1:zA7XpeNsZ,DD/GZHlfHƶ` $N_V8tTJ)Sm8#g,5CZ/nGLܓ2T:]KUM(xv۔WLw '̪xIr4֜(\HYAWPS(?29{I'?%? Ԫ/mͼ>!A!f|e~mDlI CRJ,XԖ#G_h$Ȕ(bV|){}SSyp@GṰv4:؈I&HFg'sr*22t(oM5q~ɪ}5`XT_Τ,nskGw[MZt?5Ry50][.wUA+>&?{]|øKSw]JhQ@*uC,ubL#ougqOI2 n4??u`*4lE)^ qVY:t '=Y0rzuRu _1ZOD@@R2f k 4ѕq~ !ƻT5~[hv]qG~)*T,`M=,cεۡO5\mj4T^oI\HqOt'XnïFQXJ92:#} 7V+jFao4]%8|SGXkq@Vlwē'@~~U],}?6/`Rjô_@Il@1R8Zhɸ(9xH0"%r SmQ+TKP7:>&3 =χ_eiJ9Ǎw ˰c܈f-!8(탂@CGVܱ 2Z\h U_BoTH MۆԈ͝8K}5 xj~k[8cwC=Ak9,ʽjK#ă&!".>$;=d`%åiU}T`.j>*0l'BtdkzHk%Gc{13ZΗ/8Bl/q!ƥEB4cY( +ϸ: ${'ː:?"]o'/8hMn*H?C4}Bc됫6J0T@ZirO6(#=ّAC3#a~*B8 Vvͩ/ UCN:5d/dpcwg4Q5hZÃa/՟TV ؇V0%^L%ȕm5ϫg+~)ѫ^߆HbtD,bI3b27'8O dʨIR??VOnhf!3^ i &F,Ϳ0d3JP &P#ΈT#fTz\ep0 @6(]*i2npP۾aO{h̃phFPU Ǎ$ u+q7!/~pj]l^tA;״`)w\#4\ny!63Sdž-7ugC5Z &.8~J*fP}i 3C˫8VZݿi*0Xt2"4T/Wy!2cUr0UH\Hz%-|ub?up̃x/ع.ǧn9)Up2֣XNhvfCi'Z6d3LDc>uhaW'pYF-ZTyJ!&>h+lG%.o?g~4[s?. d0?7z:J;tʸ;l3 cPp)!O P^[*ྖ9Jͬ&%ZW]ͽt0yFf_>:Dzl!5/vDi[l^-%p.UB;:->ߥiI—=Vèӑ?E{mJgZw_;BCʇߝoNrQsA2Wo^⵻+[ŻOr HbJBn K:Wfw;0]M ʶޔ@fPВXsx%˲)"GZO+Kmg*zim ̞劑:\}{;TZ*y:?-]2=*a ?R^w-h>HՏRIwX[ʼʪ!%=}@JR<ǛK?kPzl] sRlX|$3jﺟ6{荋Eس,Pʨ.nⷮ[6ɞ3D$ӹnT; 1&']$F<D)V81~Wh|v3+ Uݷ/s8k`{f^f00]<_9P2C4; /WPdd.0ו.?l 8p͘1f17e#Ca k$Ut}ckFTvjp.#rp4kHz@e~)*Һ[N5Q=Dv ƂGtLIR>ŊV+"T)3CcJ 6ĺ?Ɠ6֑>I.Vm_9)Ƌ>YQAкl  >2). ?qU$eLi8 3 +_E}1>Z==:!soV'BԭM4(V[xUm؀2N3"E5uojwiU?k^4)FD8˔ Bj89Nj߁|F&GK "/̌D|Dz0V9W7"$뙞f%/}8)HL7<Л 6r4nZޗJ3wX"Ԁ#&ןpM>pLYl %"JR:*G_26bC),U'uՈmdkfnY5N#cp_!_>+Wu92nTm1qM4fvι,7,&Z(gGJ pZLA&l?Rse' !317xa2R:]g 9&oËMۑD'U`ZΊlU\ۛԣ;<(/etD*,'s bgKL~|{зOIQ:1rW+.rk)vۗE voFkZ~7*,{Ε4WQ9'/ؑ?5Xce 5Y^Iuo2y6`*-"L(WKv^Vq,˻0V˱f¦cCRN-F9)fbT/tr"+o~#'h5^V',MRT-S>tpqun1sGirr&ڐwjԷKˆ8L?8[Wfol~]EpMu|]\Pk7IdY4W-"6 4y*- @^HN0L;+%zPQC|iO6$γYG@ ]Gv97DsS8\'*ȗn`V,zzH\jT$r* f j `0(<5&a ⁖elQT\znQr%ɀa|I lE-7\^vλ<֒Ɪ J0(šNѿ0UDž9U}NcTjnZ'!LH)-bLV ۶IRsV#^Exf >Uq~qYqlqّo,jKC̾[-F'PmZ"* {#OF"aIU :%,O,lAL}W;vt2ev%ZDbtΉ9kO&R7zֳ~) zuُ[ ΢"d_/&~*I+Ip̠!oA;R&y:h^Mh3]#AbaU\AGŷ k$jzU;:CEV[tI~qKCZ M#5 f`\Glh%hAԷǕJ W8ٙ_?kybIJ##, E hvV"ݓ1c+sfE%:0O+? ‡ xQ)m~H \4n^67c&~f `}pT O#kp~p֚5OӬT9Sh:Pm ?Øp \[ߓI_KůH;ٰ\ 0 <G7Ԏ ^R¯";&)sSd{O8Zl2B?EqZ:bdec,7)c:V1b/>HmZ˳$;MN3$[lhjiq<5%HPW󯭼6_]Ea".:!NJ13~wGgt}L&ϕ⚬%~HHely.0@%c;YcYGbP]UN1<o5D ڊ 7~XK>_=PR#NEW2@7\T7%fHNdB&hNu:ͰY2y6_""t\QAXֻSJ'%<_+!@rzFIih)H3(6` HA<` y8UJn0BzZ^؇P w*,yc og%8d6|.!%IPcaGObztHǡvFO"gFLxTjȼ) endstream endobj 93 0 obj << /Type /FontDescriptor /FontName /AEHEIW+CMTI10 /Flags 4 /FontBBox [-35 -250 1124 750] /Ascent 694 /CapHeight 683 /Descent -194 /ItalicAngle -14 /StemV 68 /XHeight 431 /CharSet (/C/D/G/L/M/S/U/a/b/c/comma/d/e/i/l/m/n/o/p/r/s/t/u/v/z) /FontFile 92 0 R >> endobj 94 0 obj << /Length1 1768 /Length2 11372 /Length3 0 /Length 12485 /Filter /FlateDecode >> stream xڍP. Rܽ@;B@p+P܊SSܭ8Ŋl;g$߳yZjrUuf13 Pl&P`gqq QSkɑ?! ,$ @c㋡ d ` 82C 3 @l t@۹A@/yzЙyp! Sc[%%5@l :W:!KGG;VVc0B rg7e Oj,H K`sGc"m^\l̀Kv"@hc0<; d) dk0Y*Ҋ,Lc[߆cgcɋ_st`qY;1KٚImlHA/gs?ڂ]l=B [34̜Xۂ은rڼYlll|=jj;%o /; d|Ap0v!N@/+!@/bK! W.~~03?UGBKFEO+f.3''(RUcП+9 /g ?ϥwe4t 7 7_+vCOd4;9le?lTuVlW+h!b$A 4S9Z11%5 voll{Y9ӏ/wKP_63Jٚ~71vCb{/nnˎ]m+- ` n)U?*7eJ8 >߈EoF/~`I~f5d9\VĠA~?e7XeY/\/a2 /^%ӿKq.@jPS'c^b]H `S 1"Sۚ V;445ȕX`ݥ"٣ac BpSܻ{f C^Dbf G{a婳Tso\zd\{Ff( ?}g|?Mm>C@L}j +sL>(: B*BKIDy9sl,Pk#d?t٬! 2#T^լZ(iFv Uvhs..29* y=;!F3%(e7KKßUC曈H+^8J;|VTVGvS;}RNhH )ع_xc.+M:u /؟I8L'L[uqKH/w/7;7HjMVrjDtK!ʺixC]"j) BS~ Q%^mw-WP~Jљԙwr( դԍڇJn'nTjYk4b1|Z%]݉48sRbpi.K>ZFelcDۙ{Ivxf YzO䫉V(LڤY_,h.{>HY9)&IIj'ZI䌖V$WOWlY^E-EJt#(H2CЫ*&gǪW[RjΩ+wR\KFv:0]k$)l שvkw◌t]ljC_#jD,/RL6H`|QTQSC|1( ?z<+<0LJ-Ɩu6Kz[=ś.؊$=IO=2 5a~ut#{ԸQ|vUj" ]yxi0 .׻\yY śzK,)|å\iCMZqlϚED>܌qdu5T |j>]|}pw_`nqDn}/:#S!(Fs)~RQI> OmVsux^K"b~bw&e#.<&DAxLJ'vojߌ rڈM0f}r_jGL`iDb$FZM-HA9#? F~C~*|:M&`'^"BfHFvP 6=@c:l. XEY]щ0椁)T ]B-M -*p&fԺ2ҞG: (^V$ޥ4erkm{k?vF_+[|7q!LBiqU*k7(iO vi3z-C2Z4BЈ+ Zl=|ݝer5s5- YC{ W޸sU}HGBhT?UySaՐ4d;*k!KEF٦57ɰɊ=S @%bwQYZG(i}R"{süU4_ѤjgH\~ {9Kݷ*W#7T;J}Ks4bL,Ŀ.+Ew1!|.5f(5} @(Gli3BeTS.l jLJ_űN3Ѯo~a-A3^RO*3x"ϹTgw=Y6y\Q}:#!s_ y+ڭbv_8p}y Tx4C;n&Fz͕th8 ˘H=h :+~Po z߳;Ҁ1iPvg:#GޣuP08 )c_v4W ?,&+;3?/sbɠMv=vuQmU =KLuswEu|VnE]LDw)p;OfC5,k"?JȗP`w!/-8 z3>瞽ڦ$Rs @.XvyL=p G5,o2oU#m`E|tV^GY'yZ䤛6R#,rCJŪb}1>p"'|XCdE(83Kz>\Vqc s8r&SGz%pX-6hV5**z{_M5vm&/#UW%[%Օ=&Y$۾ xSrW21x,vru m N֊.u@ϑJSn?bx/"ȵƴoE%FE;:NJ"Zl4|ʮ~n`[8Ј>r`NUq{>\GT+ 8,tH'i,0IԹvEx%LMpY}PmejlƲ AEp~W ǭ^<AxkQWBE beGú+s4sKVv7k-i{!8'6+&Ƃ7qpm7)J"`DzvZ{+Oq~W' WQgۀ=1Prs:QcnNku ǐʳ.nYm~#ggHC o /HY)|<1KcIr67ek;573J3nu#ɟi8N9`|7WdVM5y׉F|hnZ?1 i-Gyí]0W}L I4${Far|)|^\ ۢ*rkpnfQWTs;,^ٳ-7D&ߦL? 5Ė]}7N%7UJVD5ԯ5kO*hӗF*:A uWbS:(/Xh8iP}IhĄhP LI51{/}B) Z̙O_0 9>fqSDVMn>kvҴ6zjL*"t 29',_.pFp&eP'Mv۟۴W{i9άvCdBŖwat S ; x+(mțNz`"{Gh";x1TܸK-jA˂W5yBt':e:|cDdfI Cg%~Ek)ʓ?s[H-ơCҖCP ajK>QS!CPԀގˍF]?4 qS Ub=uǦɎiMVM%d2/k.nF֬(3~׹)#iXoVPGez&˒TiA~gz\WEep=r=f&{z6e 0p]p΃ws =l'y-a _酧a<Y<c:m,17v{k./6shr7ER葆>~b̨$l6NK@^yvB~R CV-d zj?(lNwkiJQ4Sመ&-~Yl |Hdz^~tn$8!$ǃ^[B!+;b5;LwF xu⼢Н$OS\CW qDW'JاCoێ"}+/UU"CsGpL8&^ V,lO#Gϸ N5,NT{OOwB&b^)o)jM޳b OԴ6AYDAS]0%<(yЛ.ZwCO|5 2 tv)I>@]dMG\ ,1{*bf T@5Կ^ÈHֶ.d#f/_CAʾS8V"W9(.Q13|ܫ&CTklMY >b;mEz 5 o޽ Nqv?M?,qE MD?Ж⒢t1l!gC7 Wږ -dNB:.Qʽ9s;Ub&L1{e<1M\l e%`Z)C8&4cA)Y׸S*l_]SC : jYA~t O?0ebd$oY|ԇîMΜ72Qf5G9#ұny JACxf.Q4`Z$àTBjZO۟c 3+*]즚))&{Rvl'\f,H9c;g"=cID0Oi wfrzAᑺk:GVAe_s h\ЕB#†(`N 7\ǵQ>U۠\W#ON )LAL=otlH R9w"#t*-y-TGjϙO%w3ia7L89ck8%$U0)D߶ON x) 7]x):y|Z;ȒchrP@xU~R58?i:PXH(za o}"Xy,q` ~֗"ϱ.e(mh6@_3kו-6 Ko2\zM0u_C}(&َ&mJkf/P}x ̝ reQAbak:?!*1t2&clDL0%Hi]PQ(4ݔL̝Ssoifdʂ1&Zdtv6a|Iy>̍CNs|:ԯޕv.sSXx0%slrt!8i e?|_ E#=m&]D#C)-1c/} MȻi-E8j+zߠ_11u,!- GM$ |+?^K76ɰ(E䵴yp88=DBb,CAL$%n~zIb-GEMjM%DX. ߝOby(?OTt-vW3ͷ݊. /|],CZOq S=eaG#zɍOmQbӣ|91,glcn=y-6 hTlrhL[Ihn:S5c mKp\t^!]%v%NEtXfJǒ{LX{Z?aJ>o Vs\6- |߻dlp'+\H߃B;]9-d{g=dzUnWs6ht#A#~ΚI mN1Y~j #{zX + fSqϯ^ᐣune|g=b#0g7=]:hlp;VH:1(Oz9_/aѐ2OP#.]X+3 ?Fc}@;=L@.H`<203J_FZ؛pz@s.u+0w0N&vzzs_Pin퓒L}YY bR' yyX^NC$B}T#_\[j{ g1uZн'ȇ=L|q!^Bq<ƠKjOysid8Hlb-:/ODJ]95D:?9#sY0CzYGRyn>nAG us¨{H T t+8 7MN,ؾf䪗"Sp;E$.炸H",% kPο }PڮM! $`\pɤv]vQw):Al@Ť-W>Knm(j36+U!o|Jr¯'o|rZ;a<ҨIh;nlK.mk'tD8e4eJ.m'hu-Ñ ͻ2C%EN/dvCWDÞ"ߝu18HN8F҉{oey߭6€Xe9\56HϞL=(81elߞ)k0f&s;F+ا9h䑋`X5o&V ^ tupՙdww8VZ4d+ ~XWzr AD9Ӛ|'"By?c`bº!(8pM>)z2+}qjQKz vZ,y,5GǮG}=*$,tx ]T畍U$D D.&6*쏷y]0#8),Y%_0b5tطk阼 t@.%hjClifaFIKp*Q6|Fg;HazOZl-ZƄ8†-ˋ*p,%ЮYi|ӯS%Q{wʙui#UC+?c>*sd-"IĥtTʶzt6>^Y*G|Cj$Ni Nu௽)#ܒS$-[֙$:౪>Do=-_CpeF R<iWCeЇn3eAW& igʼnƦH=ª%%S3B.ˍzxŐk+=6 yx)=1ɭ_ ksr]jC$_7؉oمFvrV|;0saQ.j}6??P%Y:u2ᢴ`'(hYfPչvuهl\贎G!.?iLFRZ_򶞘ޯs(3_Ci/mtzlфH_m$mWN#w)7!6S2[ZV&/_X< ?WSN<#WW-HPg 9MQ OŃdyuJdhCZ@#9U,]bʁWo|ae14DT׃bhQ/K@Yi*mWc-LѮr|v ]ѱ|p>IMgJD|ovGXRj֞kD[3d^ 7iׯg*hQ|2_ETkdОَ#[(fW*[LqyJ BK N zNz1.kX'~a(<~"6ȇAi<`CxOWYp!@p.o ze=͝|>ܠI7NFّA? yԭ[pQM?LJ{*اD[H|x;y{^ɭW܏? cm?f?e ҷ^#EǡDG8;-动X. &Qs2>94hOe.scQ~m~,xx7Iܦ;V37\KJRHy{t_HJf}p:}5du">{Wm`)JzMx#}j.حN3zƶ OCt軉wqHnHTr4ފ^{D{cFeX9G?ݠdtHX+J׋m]uryz |ِwN)x >cNwW=1Zڦ,bkA&Ae5zSAjпxͩ>>\wq% Ck >"=) YؿF^]t5dȟ};tَD-dF c&HiB,^S(];Q#Zƒ jҽx¦{"Xμ4ɎЄQE;_-49ê:ֳ̍l1Ax!N)K ]N_Xêà` +^!mOZ4SBTF#[kmX(;k},hӺxoKN ioY?gbYg#[DJsu:;[0%.5b3};*Q'ai:5IVcnk| Yʯ݁4iK_WS k!7_@}:l`sJ9j5-N8J٠gȎCW'ATeDHM ym4H2N2c%.]S;:>T;}.pJUp4 Ὥ`VjOHjɼhcmMlc7Ax\RWV!sFHSE鳷\=g\ig~O!NkH%#6APKlW|uo;0bocUϝ1͸>]#K}͌F)<9;Ϟזˋ]MT1#~CJ`m9H[^zGiɖ ;M*"fg>ޢP[]i߄W?&a? g)x%y;fyc1yE"3^~N;oOHdb߈b3xGFCf. ҜK/Amqlg*.:#$\2(LjS:01\Lsy0G1 0]8544Jg8sU*PH>u̙+3\ (|!aFW'[= \Q%ʅQrVZP ]iGg=$ [0/O>FwrC$yacx0o6;Qy6 RQ39 =æWlKuRƁfX:b%T{uxQۣeixx7ྍb;JgCtu[|_ê7XȻSd!;ZdxZ'7E3{z\߽i'2!(.,Rj MHy~b\cY׉ F˒['Dc|Nul[q"p U 1xKu&y+w8)#IK͉=:SS( Ɋ~u-)n)]2BӹUg^SdC $";?U^ endstream endobj 95 0 obj << /Type /FontDescriptor /FontName /ZCXGON+CMTT10 /Flags 4 /FontBBox [-4 -233 537 696] /Ascent 611 /CapHeight 611 /Descent -222 /ItalicAngle 0 /StemV 69 /XHeight 431 /CharSet (/B/C/F/H/N/U/W/a/colon/d/e/g/h/i/m/n/o/p/period/r/s/slash/t/u/w/y) /FontFile 94 0 R >> endobj 96 0 obj << /Length1 1861 /Length2 6103 /Length3 0 /Length 7225 /Filter /FlateDecode >> stream xڍTM)!?EBIIfbf. iP@ZRiA$TPU}z5k}s><PLz&&b
8  wBÑٿ^1T௒UTހ ,.! HKפF]\5iO aS-W_+3Dbi~KQ)QKy~nQ4<\\~qp_n`'Cކ3z0(Z0vB.ր{àp g{ .pxoa1QaG}Sia'$KI` C"/q))O ;P@"$V#Q$?TZ )X ?t Ha=S7Ɉb;I ?$ L6?y7] ?M?  / zB ǿbE8X.!V@Xȿ+7JJc ȿtaB_݁ <86_- hl+?_m!y;ȅ9Մ~Vf^{%.IwsHt{Us0DUDarz"xFg3zQgXYuVGNѺ:3C+ B&rߐ}VqaGU|,e R6圶JcZW)O2{ĥfJpK[[dn:9[36tlG1.gC[Â/ =d79h~z[\|⡉0;Ik"3*D({Q#wU*+r:>򱽚5E"@,Fyh/LxWP}!*nt4M)WFm 'upt9w6{y>{炂w ":˱pyXvxs'CP^ q61UFb=4?xu-0~iN iF)MtgVdljCԐܳ1gdMb:c7 džw:{M9;DHg6ioRGsR5.WgU1GE*(hPΞLN)o}/}j.en1\LSx}V)HTM Yc1Q-FzbSѻ5I&݇{0&t<.=z Fx]=.]-zǔ"@^fIxE>0-Z.8$\=x6U!3]iRuȪwiRz1b$DrbY8G?1$z@wi^2s!Ko9JkE&nRն v1Q9>Xlyu|#Ebnn$i). !@3b";IC(Y1#Af'ѪJL!/f}' rL[t2^].SXz1;Rd^R󆴹c|c sMX:e|gR.lJ|NJv̤՗f\ؘ{RC5qyTգ"|Au_OY~XlQD{#?sdU`=gj,cN jKKteNDK3ͫ8xiو:Khdcql2o3(%9H 4nH=M+y>{zYu(򚙐_B^0y%OI`µ}[9wO6*DŽ;m*mH%7 t~l6 <e1oB8^Ӑ$Ã~!v~kq.w{mrLJG]rS \q <%AtXQDa?*PDo{Bw!)s=wƊiǜ}pdI *w럻yKa!?ݽid׃)"Mnֽ@|ȇ>UO!06 lsxŷ`SB.acEtL}:ru3s 㒅[Muf7WhфotSq V2g+/ym!FBB uKMt ǾWz`[7̥P{voIORҤe6阷7Aߖ)&M*HS9k3GzRC?^hXx]@FX=HNF\몾u]C R*R`'lL:XI)#E,%ˠЋ*4e7j N[FW@]JHf`긩&{ +C3bFmL %/(&tkKT9Zs,dJ`t`mhxѽ)/_V}NJUusSn(k\# /-h٥!`8(4N޳hddw%_"%1hQjr*;O1U^.?qkRMn2Om歜-dN p23oJ56.lʹVwBH_&gxZXyK%๭gG˼Pkz#*)2Pj!}+] 'H{KԇW.ٹO$]?C⨔J"9Nd-1Ck3s@SxcUe}pӴn:TA>W2pcWΒ Bs9\\hDL,qjʒ1aGfSOp$ Ir_cy',UfLY SE"tqbv7+“yKgSO6/1Q칵U35"+Y\Xcj;(gL8MGj׉nn9u~e*DGr yN g+nf:ٺB5& LîaN͇'R.i@N=A3cḿP#-Ր_,@_l۟8NĮW Zxހ}^u}X%0W+Pӹwc.K f]hOF,$r!x}jƮЉ`4ـQ w/5 娏A d!{h'Lꐤ/ɧqNW%oʋ Vv*w5A\@[(rgˌ7 at:ηre:ЕުL|'.M!.oj]R'2<9Y}Hj(4SW?hRM_w'm!S6Nb1nP)-gwׅ76mKoGna,0 "V2a^۶r54eJz:,ˠc{O01UC&&=_RfkN: o=_`bYUk:oҠS`})f!DUi6#h%z@}.c$RJG=sWcr P›&Qf&N|o \8* 0V|6=\2 ᾉ. Vb:S1|N=s)g{rfݶѪ >Y]maͪq :WC|R^}S(Ozɀ%Q-6b0'9;RL|L2e)6pN8&,tT㺚ΖƧ6m5_>zC@,Z::|Xdrc Oke\!-];j*e淶M\n9+ׯr@ Ne$i9ɽ߲it8$/Fǀ V y9sM?(ڣu3uSx=Q|~3HBc[x÷iCȨAо±3_3íK?RG][~VZiԒgr!_?ّINe=5*9O%woYB@[F=kv'S̎\-˘FzȕxBf&e4Ž7a(pȧ@ 'p7&JȘŪ6q ?2e," |&>d/ !?R<]l/ް4,%z\}Iu^E M<5;1TK/d:Q"ۄnk1h|@'ފtyU,"lj+g#<CQ endstream endobj 97 0 obj << /Type /FontDescriptor /FontName /PVBRPG+CMTT12 /Flags 4 /FontBBox [-1 -234 524 695] /Ascent 611 /CapHeight 611 /Descent -222 /ItalicAngle 0 /StemV 65 /XHeight 431 /CharSet (/A/C/E/H/M/O/P/S/T/U/W/a/b/c/d/e/f/g/h/i/k/l/m/n/o/p/period/r/s/t/u/x/y) /FontFile 96 0 R >> endobj 98 0 obj << /Length1 1328 /Length2 1243 /Length3 0 /Length 2088 /Filter /FlateDecode >> stream xڍS TSga,LuZŐ KDv"*S y%!FP9*2( rz\Т PATFR Et"La^¢8s9/w{kMp=GE\   qƤh U(I;j,W  CC8apCR L@wtpFsbr ? $+L#1"L НW#BA ` QAG`\3- [R*UVS cl@"\ 2$5 Ÿ#jH F0 B: k0:DsBJ7K`$R h "bPx TBbFC*C@tp9kD0)(#Uh*$$<9'N 7Ԩv&DPPGCRPD}='0Ecҝ8/ jIי  Z)&Ba⏤U@*r%1FӁ AP߉ˑxFȏh)PCŚp_Nx SNww,hY,` tt`g0=T&2O2B 'AtojB6kc W=7X4>KoeE\XیIfD)CfpTGo1ny,G吆D# ƨ[&T D* $HiAg"MKW'GԜa>W[R>Bm`Zݷ{8kd~ɴ&δa䍕ƭ_@۳-Yi. /F[9ܣP2:]D1 ޖjl"z_ec mAUE%:r{}BVCO<45e@E{.,:u5RUf|a`-?Vݚn1]v](#]"fvc;]1{OlvfϞձW2e"B9ZEe-Csz36`(ӄ>wZyxET&αy@ʻaV.7?3}nHm>nc*syW*y,z Ôӯ $4ZY׿3kI_z԰ulM_։3H|VRfZv(3m{BJG&<~Zy'߼WHӻ!H(^ 1J"o?oM+ endstream endobj 99 0 obj << /Type /FontDescriptor /FontName /AICAWW+MSBM10 /Flags 4 /FontBBox [-55 -420 2343 920] /Ascent 464 /CapHeight 689 /Descent 0 /ItalicAngle 0 /StemV 40 /XHeight 463 /CharSet (/Z) /FontFile 98 0 R >> endobj 6 0 obj << /Type /Font /Subtype /Type1 /BaseFont /OTBUFZ+CMBX12 /FontDescriptor 67 0 R /FirstChar 11 /LastChar 121 /Widths 63 0 R >> endobj 12 0 obj << /Type /Font /Subtype /Type1 /BaseFont /LRIMYK+CMEX10 /FontDescriptor 69 0 R /FirstChar 12 /LastChar 90 /Widths 57 0 R >> endobj 8 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YHTTDY+CMMI10 /FontDescriptor 71 0 R /FirstChar 33 /LastChar 120 /Widths 61 0 R >> endobj 15 0 obj << /Type /Font /Subtype /Type1 /BaseFont /RVPZIX+CMMI5 /FontDescriptor 73 0 R /FirstChar 105 /LastChar 105 /Widths 54 0 R >> endobj 10 0 obj << /Type /Font /Subtype /Type1 /BaseFont /ZWGVMU+CMMI7 /FontDescriptor 75 0 R /FirstChar 33 /LastChar 120 /Widths 59 0 R >> endobj 11 0 obj << /Type /Font /Subtype /Type1 /BaseFont /LRRNNZ+CMMIB10 /FontDescriptor 77 0 R /FirstChar 33 /LastChar 121 /Widths 58 0 R >> endobj 20 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YLJPAC+CMMIB7 /FontDescriptor 79 0 R /FirstChar 121 /LastChar 121 /Widths 53 0 R >> endobj 7 0 obj << /Type /Font /Subtype /Type1 /BaseFont /CGGRXQ+CMR10 /FontDescriptor 81 0 R /FirstChar 4 /LastChar 122 /Widths 62 0 R >> endobj 5 0 obj << /Type /Font /Subtype /Type1 /BaseFont /BNFUSO+CMR12 /FontDescriptor 83 0 R /FirstChar 44 /LastChar 114 /Widths 64 0 R >> endobj 4 0 obj << /Type /Font /Subtype /Type1 /BaseFont /DVDPRI+CMR17 /FontDescriptor 85 0 R /FirstChar 66 /LastChar 121 /Widths 65 0 R >> endobj 13 0 obj << /Type /Font /Subtype /Type1 /BaseFont /YOHNWT+CMR7 /FontDescriptor 87 0 R /FirstChar 4 /LastChar 61 /Widths 56 0 R >> endobj 14 0 obj << /Type /Font /Subtype /Type1 /BaseFont /OYYNAQ+CMSY10 /FontDescriptor 89 0 R /FirstChar 0 /LastChar 94 /Widths 55 0 R >> endobj 21 0 obj << /Type /Font /Subtype /Type1 /BaseFont /UEAUSL+CMSY7 /FontDescriptor 91 0 R /FirstChar 0 /LastChar 50 /Widths 52 0 R >> endobj 44 0 obj << /Type /Font /Subtype /Type1 /BaseFont /AEHEIW+CMTI10 /FontDescriptor 93 0 R /FirstChar 44 /LastChar 122 /Widths 45 0 R >> endobj 9 0 obj << /Type /Font /Subtype /Type1 /BaseFont /ZCXGON+CMTT10 /FontDescriptor 95 0 R /FirstChar 46 /LastChar 121 /Widths 60 0 R >> endobj 36 0 obj << /Type /Font /Subtype /Type1 /BaseFont /PVBRPG+CMTT12 /FontDescriptor 97 0 R /FirstChar 46 /LastChar 121 /Widths 46 0 R >> endobj 22 0 obj << /Type /Font /Subtype /Type1 /BaseFont /AICAWW+MSBM10 /FontDescriptor 99 0 R /FirstChar 90 /LastChar 90 /Widths 51 0 R >> endobj 16 0 obj << /Type /Pages /Count 6 /Parent 100 0 R /Kids [2 0 R 18 0 R 24 0 R 27 0 R 31 0 R 34 0 R] >> endobj 40 0 obj << /Type /Pages /Count 2 /Parent 100 0 R /Kids [38 0 R 42 0 R] >> endobj 100 0 obj << /Type /Pages /Count 8 /Kids [16 0 R 40 0 R] >> endobj 101 0 obj << /Type /Catalog /Pages 100 0 R >> endobj 102 0 obj << /Producer (MiKTeX pdfTeX-1.40.14) /Creator (TeX) /CreationDate (D:20151228081048+01'00') /ModDate (D:20151228081048+01'00') /Trapped /False /PTEX.Fullbanner (This is MiKTeX-pdfTeX 2.9.4902 (1.40.14)) >> endobj xref 0 103 0000000000 65535 f 0000002909 00000 n 0000002797 00000 n 0000000015 00000 n 0000203906 00000 n 0000203767 00000 n 0000202644 00000 n 0000203629 00000 n 0000202924 00000 n 0000204600 00000 n 0000203205 00000 n 0000203345 00000 n 0000202784 00000 n 0000204045 00000 n 0000204182 00000 n 0000203064 00000 n 0000205021 00000 n 0000006539 00000 n 0000006424 00000 n 0000003100 00000 n 0000203487 00000 n 0000204321 00000 n 0000204881 00000 n 0000010342 00000 n 0000010227 00000 n 0000006734 00000 n 0000013519 00000 n 0000013404 00000 n 0000010432 00000 n 0000024865 00000 n 0000016361 00000 n 0000016246 00000 n 0000013657 00000 n 0000019349 00000 n 0000019234 00000 n 0000016451 00000 n 0000204740 00000 n 0000021964 00000 n 0000021849 00000 n 0000019451 00000 n 0000205130 00000 n 0000023574 00000 n 0000023459 00000 n 0000022066 00000 n 0000204459 00000 n 0000023688 00000 n 0000024162 00000 n 0000024636 00000 n 0000025110 00000 n 0000025135 00000 n 0000025197 00000 n 0000025232 00000 n 0000025256 00000 n 0000025594 00000 n 0000025616 00000 n 0000025640 00000 n 0000026189 00000 n 0000026541 00000 n 0000027027 00000 n 0000027538 00000 n 0000028087 00000 n 0000028409 00000 n 0000028911 00000 n 0000029573 00000 n 0000030215 00000 n 0000030604 00000 n 0000030954 00000 n 0000046734 00000 n 0000047098 00000 n 0000056019 00000 n 0000056396 00000 n 0000065532 00000 n 0000065785 00000 n 0000073051 00000 n 0000073269 00000 n 0000081622 00000 n 0000081860 00000 n 0000089679 00000 n 0000089911 00000 n 0000098211 00000 n 0000098430 00000 n 0000122193 00000 n 0000122706 00000 n 0000132649 00000 n 0000132915 00000 n 0000142245 00000 n 0000142485 00000 n 0000150599 00000 n 0000150851 00000 n 0000158774 00000 n 0000159049 00000 n 0000166167 00000 n 0000166398 00000 n 0000179438 00000 n 0000179710 00000 n 0000192315 00000 n 0000192594 00000 n 0000199937 00000 n 0000200222 00000 n 0000202429 00000 n 0000205212 00000 n 0000205279 00000 n 0000205332 00000 n trailer << /Size 103 /Root 101 0 R /Info 102 0 R /ID [ ] >> startxref 205555 %%EOF BiasedUrn/src/0000755000176200001440000000000012640160171012713 5ustar liggesusersBiasedUrn/src/stocR.h0000644000176200001440000000753412640160171014167 0ustar liggesusers/**************************** STOCR.H ************************ 2006-10-21 AF * * * This file defines additions to the C++ library of non-uniform random number * generators for the R-language interface. * * * class StocRBase * =============== * This class replaces the base classes for class StochasticLib3 when used for * the R-language interface. * Member functions: * * double Normal(double m, double s); * Normal distribution with mean m and standard deviation s. * * int32 Hypergeometric (int32 n, int32 m, int32 N); * Hypergeometric distribution. Taking n items out N, m of which are colored. * * * * source code: * ============ * The code for EndOfProgram and FatalError is found in the file userintf.cpp. * The code for the functions in StochasticLib1 is found in the file stoc1.cpp. * The code for the functions in StochasticLib2 is found in the file stoc2.cpp. * The code for the functions in StochasticLib3 is found in the file stoc3.cpp. * The code for the functions in CWalleniusNCHypergeometric, * CMultiWalleniusNCHypergeometric and CMultiWalleniusNCHypergeometricMoments * is found in the file wnchyppr.cpp. * The code for the functions in CFishersNCHypergeometric and * CMultiFishersNCHypergeometric is found in the file fnchyppr.cpp * LnFac is found in stoc1.cpp. * Erf is found in wnchyppr.cpp. * * * Examples: * ========= * * Documentation: * ============== * The file stocc.htm contains further instructions. * * The file distrib.pdf contains definitions of the standard statistic distributions: * Bernoulli, Normal, Poisson, Binomial, Hypergeometric, Multinomial, MultiHypergeometric. * * The file sampmet.pdf contains theoretical descriptions of the methods used * for sampling from these distributions. * * The file nchyp.pdf, available from www.agner.org/random/, contains * definitions of the univariate and multivariate Wallenius and Fisher's * noncentral hypergeometric distributions and theoretical explanations of * the methods for calculating and sampling from these. * * 2006 Agner Fog. GNU General Public License www.gnu.org/copyleft/gpl.html *******************************************************************************/ #ifndef STOC_R_H #define STOC_R_H #include #include // Declaration specification for exported functions #if defined(_WIN32) || defined(__WINDOWS__) #define REXPORTS extern "C" __declspec(dllexport) #else #define REXPORTS extern "C" #endif /*********************************************************************** Class StochasticLib1 ***********************************************************************/ class StocRBase { // This class is used as base class for the random variate generating // classes when used for the R-language interface // Encapsulates the random number generator in R.DLL. public: StocRBase(int32 seed) {} // Constructor static void InitRan() { // Call this before first random number GetRNGstate();} // From R.DLL static void EndRan() { // Call this after last random number PutRNGstate();} // From R.DLL double Random() { // output random float number in the interval 0 <= x < 1 return unif_rand();} // From R.DLL double Normal(double m, double s) { // normal distribution return norm_rand()*s + m;} // From R.DLL int32 Hypergeometric(int32 n, int32 m, int32 N); // hypergeometric distribution (stocR.cpp) protected: int32 HypInversionMod (int32 n, int32 M, int32 N); // hypergeometric by inversion searching from mode int32 HypRatioOfUnifoms (int32 n, int32 M, int32 N);// hypergeometric by ratio of uniforms method static double fc_lnpk(int32 k, int32 N_Mn, int32 M, int32 n); // used by Hypergeometric }; #endif BiasedUrn/src/Makevars0000644000176200001440000000015312640160171014406 0ustar liggesusers# Makevars for BiasedUrn # The value of MAXCOLORS may be modified PKG_CPPFLAGS= -DR_BUILD=1 -DMAXCOLORS=32 BiasedUrn/src/stoc3.cpp0000644000176200001440000013336712640160171014467 0ustar liggesusers/*************************** stoc3.cpp ********************************** * Author: Agner Fog * Date created: 2002-10-02 * Last modified: 2008-11-21 * Project: stocc.zip * Source URL: www.agner.org/random * * Description: * Non-uniform random number generator functions. * * This file contains source code for the class StochasticLib3 derived * from StochasticLib1 or StochasticLib2, defined in stocc.h. * * This class implements methods for sampling from the noncentral and extended * hypergeometric distributions, as well as the multivariate versions of these. * * Documentation: * ============== * The file stocc.h contains class definitions. * Further documentation at www.agner.org/random * * Copyright 2002-2008 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include // memcpy function #include "stocc.h" // class definitions //#include "wnchyppr.cpp" // calculate Wallenius noncentral hypergeometric probability //#include "fnchyppr.cpp" // calculate Fisher's noncentral hypergeometric probability /****************************************************************************** Methods for class StochasticLib3 ******************************************************************************/ /*********************************************************************** Constructor ***********************************************************************/ StochasticLib3::StochasticLib3(int seed) : StochasticLib1(seed) { SetAccuracy(1.E-8); // set default accuracy } /*********************************************************************** SetAccuracy ***********************************************************************/ void StochasticLib3::SetAccuracy(double accur) { // define accuracy of calculations for // WalleniusNCHyp and MultiWalleniusNCHyp if (accur < 0.) accur = 0.; if (accur > 0.01) accur = 0.01; accuracy = accur; } /*********************************************************************** Wallenius Non-central Hypergeometric distribution ***********************************************************************/ int32 StochasticLib3::WalleniusNCHyp (int32 n, int32 m, int32 N, double odds) { /* This function generates a random variate with Wallenius noncentral hypergeometric distribution. Wallenius noncentral hypergeometric distribution is the distribution you get when drawing balls without replacement from an urn containing red and white balls, with bias. We define the weight of the balls so that the probability of taking a particular ball is proportional to its weight. The value of odds is the normalized odds ratio: odds = weight(red) / weight(white). If all balls have the same weight, i.e. odds = 1, then we get the hypergeometric distribution. n is the number of balls you take, m is the number of red balls in the urn, N is the total number of balls in the urn, odds is the odds ratio, and the return value is the number of red balls you get. Four different calculation methods are implemented. This function decides which method to use, based on the parameters. */ // check parameters if (n >= N || m >= N || n <= 0 || m <= 0 || odds <= 0.) { // trivial cases if (n == 0 || m == 0) return 0; if (m == N) return n; if (n == N) return m; if (odds == 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in function WalleniusNCHyp"); return 0;} // illegal parameter FatalError("Parameter out of range in function WalleniusNCHyp");} if (odds == 1.) { // use hypergeometric function if odds == 1 return Hypergeometric(n, m, N);} if (n < 30) { return WalleniusNCHypUrn(n, m, N, odds);} if (double(n)*N < 10000) { return WalleniusNCHypTable(n, m, N, odds);} return WalleniusNCHypRatioOfUnifoms(n, m, N, odds); // the decision to use NoncentralHypergeometricInversion is // taken inside WalleniusNCHypRatioOfUnifoms based // on the calculated variance. } /*********************************************************************** Subfunctions for WalleniusNCHyp ***********************************************************************/ int32 StochasticLib3::WalleniusNCHypUrn (int32 n, int32 m, int32 N, double odds) { // sampling from Wallenius noncentral hypergeometric distribution // by simulating urn model int32 x; // sample int32 m2; // items of color 2 in urn double mw1, mw2; // total weight of balls of color 1 or 2 x = 0; m2 = N - m; mw1 = m * odds; mw2 = m2; do { if (Random() * (mw1 + mw2) < mw1) { x++; m--; if (m == 0) break; mw1 = m * odds;} else { m2--; if (m2 == 0) { x += n-1; break;} mw2 = m2;}} while (--n); return x;} int32 StochasticLib3::WalleniusNCHypTable (int32 n, int32 m, int32 N, double odds) { // Sampling from Wallenius noncentral hypergeometric distribution // using chop-down search from a table created by recursive calculation. // This method is fast when n is low or when called repeatedly with // the same parameters. static int32 wnc_n_last = -1, wnc_m_last = -1, wnc_N_last = -1; // previous parameters static double wnc_o_last = -1; const int TABLELENGTH = 512; // max length of table static double ytable[TABLELENGTH]; // table of probability values static int32 len; // length of table static int32 x1; // lower x limit for table int32 x2; // upper x limit for table int32 x; // sample double u; // uniform random number int success; // table long enough if (n != wnc_n_last || m != wnc_m_last || N != wnc_N_last || odds != wnc_o_last) { // set-up: This is done only when parameters have changed wnc_n_last = n; wnc_m_last = m; wnc_N_last = N; wnc_o_last = odds; CWalleniusNCHypergeometric wnch(n,m,N,odds); // make object for calculation success = wnch.MakeTable(ytable, TABLELENGTH, &x1, &x2); // make table of probability values if (success) { len = x2 - x1 + 1;} // table long enough. remember length else { len = 0;}} // remember failure if (len == 0) { // table not long enough. Use another method return WalleniusNCHypRatioOfUnifoms(n,m,N,odds);} while (1) { // repeat in the rare case of failure u = Random(); // uniform variate to convert for (x=0; x m) xmax = m; if (n != wnc_n_last || m != wnc_m_last || N != wnc_N_last || odds != wnc_o_last) { // set-up: This is done only when parameters have changed wnc_n_last = n; wnc_m_last = m; wnc_N_last = N; wnc_o_last = odds; // find approximate mean mean = wnch.mean(); // find approximate variance from Fisher's noncentral hypergeometric approximation r1 = mean * (m-mean); r2 = (n-mean)*(mean+N-n-m); variance = N*r1*r2/((N-1)*(m*r2+(N-m)*r1)); UseChopDown = variance < 4.; // use chop-down method if variance is low if (!UseChopDown) { // find mode (same code in CWalleniusNCHypergeometric::mode) wnc_mode = (int32)(mean); f2 = 0.; if (odds < 1.) { if (wnc_mode < xmax) wnc_mode++; x2 = xmin; if (odds > 0.294 && N <= 10000000) { x2 = wnc_mode - 1;} // search for mode can be limited for (xi = wnc_mode; xi >= x2; xi--) { f = wnch.probability(xi); if (f <= f2) break; wnc_mode = xi; f2 = f;}} else { if (wnc_mode < xmin) wnc_mode++; x2 = xmax; if (odds < 3.4 && N <= 10000000) { x2 = wnc_mode + 1;} // search for mode can be limited for (xi = wnc_mode; xi <= x2; xi++) { f = wnch.probability(xi); if (f <= f2) break; wnc_mode = xi; f2 = f;}} wnc_k = f2; // value at mode // find approximate variance from normal distribution approximation variance = rsqrt2pi / wnc_k; variance *= variance; // find center and width of hat function wnc_a = mean + 0.5; s123 = 0.40 + 0.8579*sqrt(variance+0.5) + 0.4*fabs(mean-wnc_mode); s4 = 0.; r1 = xmax - mean - s123; r2 = mean - s123 - xmin; if (r1 > r2) r1 = r2; if ((odds>5. || odds<0.2) && r1>=-0.5 && r1<=8.) { // s4 correction needed if (r1 < 1.) r1 = 1.; s4 = 0.029 * pow(double(N),0.23) / (r1*r1);} wnc_h = 2. * (s123 + s4); // find safety bounds wnc_bound1 = (int32)(mean - 4. * wnc_h); if (wnc_bound1 < xmin) wnc_bound1 = xmin; wnc_bound2 = (int32)(mean + 4. * wnc_h); if (wnc_bound2 > xmax) wnc_bound2 = xmax;}} if (UseChopDown) { // for small variance, use chop down inversion return WalleniusNCHypInversion(n,m,N,odds);} // use ratio-of-uniforms rejection method while(1) { // rejection loop u = Random(); if (u == 0.) continue; // avoid division by 0 x = wnc_a + wnc_h * (Random()-0.5)/u; if (x < 0. || x > 2E9) continue; // reject, avoid overflow xi = (int32)(x); // truncate if (xi < wnc_bound1 || xi > wnc_bound2) { continue;} // reject if outside safety bounds #if 0 // use rejection in x-domain if (xi == wnc_mode) break; // accept f = wnch.probability(xi); // function value if (f > wnc_k * u * u) { break;} // acceptance #else // use rejection in t-domain (this is faster) double hx, s2, xma2; // compute h(x) s2 = wnc_h * 0.5; s2 *= s2; xma2 = xi - (wnc_a-0.5); xma2 *= xma2; hx = (s2 >= xma2) ? 1. : s2 / xma2; // rejection in t-domain implemented in CWalleniusNCHypergeometric::BernouilliH if (wnch.BernouilliH(xi, hx * wnc_k * 1.01, u * u * wnc_k * 1.01, this)) { break;} // acceptance #endif } // rejection return xi;} int32 StochasticLib3::WalleniusNCHypInversion (int32 n, int32 m, int32 N, double odds) { // sampling from Wallenius noncentral hypergeometric distribution // using down-up search starting at the mean using the chop-down technique. // This method is faster than the rejection method when the variance is low. int32 x1, x2; // search values int32 xmin, xmax; // x limits double u; // uniform random number to be converted double f; // probability function value double accura; // absolute accuracy int updown; // 1 = search down, 2 = search up, 3 = both // Make objects for calculating mean and probability. // It is more efficient to have two identical objects, one for down search // and one for up search, because they are obtimized for consecutive x values. CWalleniusNCHypergeometric wnch1(n, m, N, odds, accuracy); CWalleniusNCHypergeometric wnch2(n, m, N, odds, accuracy); accura = accuracy * 0.01; if (accura > 1E-7) accura = 1E-7; // absolute accuracy x1 = (int32)(wnch1.mean()); // start at floor and ceiling of mean x2 = x1 + 1; xmin = m+n-N; if (xmin<0) xmin = 0; // calculate limits xmax = n; if (xmax>m) xmax = m; updown = 3; // start searching both up and down while(1) { // loop until accepted (normally executes only once) u = Random(); // uniform random number to be converted while (updown) { // search loop if (updown & 1) { // search down if (x1 < xmin) { updown &= ~1;} // stop searching down else { f = wnch1.probability(x1); u -= f; // subtract probability until 0 if (u <= 0.) return x1; x1--; if (f < accura) updown &= ~1;}} // stop searching down if (updown & 2) { // search up if (x2 > xmax) { updown &= ~2;} // stop searching up else { f = wnch2.probability(x2); u -= f; // subtract probability until 0 if (u <= 0.) return x2; x2++; if (f < accura) updown &= ~2;}}}}} // stop searching down /*********************************************************************** Multivariate Wallenius noncentral hypergeometric distribution ***********************************************************************/ void StochasticLib3::MultiWalleniusNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors) { /* This function generates a vector of random variables with the multivariate Wallenius noncentral hypergeometric distribution. The multivariate Wallenius noncentral hypergeometric distribution is the distribution you get when drawing colored balls from an urn with any number of colors, without replacement, and with bias. The weights are defined so that the probability of taking a particular ball is proportional to its weight. Parameters: destination: An output array to receive the number of balls of each color. Must have space for at least 'colors' elements. source: An input array containing the number of balls of each color in the urn. Must have 'colors' elements. All elements must be non-negative. weights: The odds of each color. Must have 'colors' elements. All elements must be non-negative. n: The number of balls to draw from the urn. Cannot exceed the total number of balls with nonzero weight in source. colors: The number of possible colors. MAXCOLORS (defined in stocc.h): You may adjust MAXCOLORS to the maximum number of colors you need. The function will reduce the number of colors, if possible, by eliminating colors with zero weight or zero number and pooling together colors with the same weight. The problem thus reduced is handled in the arrays osource, urn, oweights and osample of size colors2. The sampling proceeds by either of two methods: simulating urn experiment, or conditional method followed by Metropolis-Hastings sampling. Simulating the urn experiment is simply taking one ball at a time, requiring n uniform random variates. The problem is reduced whenever a color has been exhausted. The conditional method divides the colors into groups where the number of balls in each group is determined by sampling from the marginal distribution which is approximated by the univariate Wallenius distribution. Each group is then subdivided by sampling one color at a time until all colors have been sampled. The sample from the conditional method does not have the exact distribution, but it is used as a starting point for the Metropolis-Hastings sampling, which proceeds as follows: colors c1 and c2 are re-sampled using the univariate Wallenius distribution, keeping the samples of all other colors constant. The new sample is accepted or the old sample retained, according to the Metropolis formula which corrects for the slight error introduced by not using the true conditional distribution. c1 and c2 are rotated in an order determined by the variance of each color. This rotation (scan) is repeated nHastings times. */ // variables int order1[MAXCOLORS]; // sort order, index into source and destination int order2[MAXCOLORS]; // corresponding index into arrays when equal weights pooled together int order3[MAXCOLORS]; // secondary index for sorting by variance int32 osource[MAXCOLORS]; // contents of source, sorted by weight with equal weights pooled together int32 urn[MAXCOLORS]; // balls from osource not taken yet int32 osample[MAXCOLORS]; // balls sampled double oweights[MAXCOLORS]; // sorted list of weights double wcum[MAXCOLORS]; // list of accumulated probabilities double var[MAXCOLORS]; // sorted list of variance double w = 0.; // weight of balls of one color double w1, w2; // odds within group; mean weight in group double wsum; // total weight of all balls of several or all colors double p; // probability double f0, f1; // multivariate probability function double g0, g1; // conditional probability function double r1, r2; // temporaries in calculation of variance int32 nn; // number of balls left to sample int32 m; // number of balls of one color int32 msum; // total number of balls of several or all colors int32 N; // total number of balls with nonzero weight int32 x0, x = 0; // sample of one color int32 n1, n2, ng; // size of weight group sample or partial sample int32 m1, m2; // size of weight group int i, j, k; // loop counters int c, c1, c2; // color index int colors2; // reduced number of colors int a, b; // color index delimiting weight group int nHastings; // number of scans in Metropolis-Hastings sampling // check validity of parameters if (n < 0 || colors < 0 || colors > MAXCOLORS) FatalError("Parameter out of range in function MultiWalleniusNCHyp"); if (colors == 0) return; if (n == 0) { for (i=0; i w && source[c2]) { w = weights[c2]; k = j;}} order1[i] = order1[k]; order1[k] = c;} // skip any colors with zero weight or zero number. // this solves all problems with zero weights while (colors && (weights[c=order1[colors-1]]==0 || source[c]==0)) { colors--; destination[c] = 0;} // check if there are more than n balls with nonzero weight if (n >= N) { if (n > N) FatalError("Taking more items than there are in function MultiWalleniusNCHyp"); for (i = 0; i < colors; i++) {c = order1[i]; destination[c] = source[c];} return;} // copy source and weights into ordered lists // and pool together colors with same weight for (i=0, c2=-1; i < colors; i++) { c = order1[i]; if (i==0 || weights[c] != w) { c2++; x = source[c]; oweights[c2] = w = weights[c];} else { x += source[c];} // join colors with same weight urn[c2] = osource[c2] = x; order2[i] = c2; osample[c2] = 0;} colors2 = c2 + 1; // check number of colors left if (colors2 < 3) { // simple cases if (colors2 == 1) osample[0] = n; if (colors2 == 2) { x = WalleniusNCHyp(n, osource[0], N, oweights[0]/oweights[1]); osample[0] = x; osample[1] = n - x;}} else { // more than 2 colors nn = n; // decide which method to use if (nn < 5000 * colors2) { // Simulate urn experiment // Make list of accumulated probabilities of each color for (i=0, wsum=0; i < colors2; i++) { wsum += urn[i] * oweights[i]; wcum[i] = wsum;} // take one item nn times j = colors2-1; do { // get random color according to probability distribution wcum p = Random() * wcum[colors2-1]; // get color from search in probability distribution wcum for (i=0; i < j; i++) { if (p < wcum[i]) break;} // sample one ball of color i osample[i]++; urn[i]--; nn--; // check if this color has been exhausted if (urn[i] == 0) { if (i != j) { // put exhausted color at the end of lists so that colors2 can be reduced m = osource[i]; osource[i] = osource[j]; osource[j] = m; m = urn[i]; urn[i] = urn[j]; urn[j] = m; m = osample[i]; osample[i] = osample[j]; osample[j] = m; w = oweights[i]; oweights[i] = oweights[j]; oweights[j] = w; // update order2 list (no longer sorted by weight) for (k=0; k 50) { // two colors left. use univariate distribution for the rest x = WalleniusNCHyp(nn, urn[0], urn[0]+urn[1], oweights[0]/oweights[1]); osample[0] += x; osample[1] += nn - x; break;} if (colors2 == 1) { // only one color left. The rest is deterministic osample[0] += nn; break;} // make sure wcum is re-calculated from beginning i = 0;} // update list of accumulated probabilities wsum = i > 0 ? wcum[i-1] : 0.; for (k=i; k w) a = c; else b = c;} while (b > a + 1); // heavy group goes from 0 to b-1, light group goes from b to colors2-1 // calculate mean weight for heavy color group for (i=0, m1=0, wsum=0; i < b; i++) { m1 += urn[i]; wsum += oweights[i] * urn[i];} w1 = wsum / m1; // calculate mean weight for light color group for (i=b, m2=0, wsum=0; i < colors2; i++) { m2 += urn[i]; wsum += oweights[i] * urn[i];} w2 = wsum / m2; // split partial sample n into heavy (n1) and light (n2) n1 = WalleniusNCHyp(n, m1, m1+m2, w1/w2); n2 = n - n1; // set parameters for first group (heavy) a = 0; ng = n1; // loop twice, for the two groops for (k=0; k < 2; k++) { // split group into single colors by calling univariate distribution b-a-1 times for (i = a; i < b-1; i++) { m = urn[i]; w = oweights[i]; // calculate mean weight of remaining colors for (j=i+1, msum=0, wsum=0; j < b; j++) { m1 = urn[j]; w1 = oweights[j]; msum += m1; wsum += m1 * w1;} // sample color i in group x = wsum ? WalleniusNCHyp(ng, m, msum + m, w * msum / wsum) : ng; osample[i] = x; ng -= x;} // get the last one in the group osample[i] = ng; // set parameters for second group (light) a = b; b = colors2; ng = n2;} // finished with conditional method. // osample contains starting point for Metropolis-Hastings sampling // make object for calculating probabilities and mean CMultiWalleniusNCHypergeometric wmnc(n, osource, oweights, colors2); wmnc.mean(var); // calculate mean // calculate approximate variance from mean for (i=0; i w) { w = var[c2]; k = j;}} order3[i] = order3[k]; order3[k] = c;} // number of scans (this value of nHastings has not been fine-tuned) nHastings = 4; if (accuracy < 1E-6) nHastings = 6; if (colors2 > 5) nHastings++; // Metropolis-Hastings sampler f0 = -1.; for (k = 0; k < nHastings; k++) { for (i = 0; i < colors2; i++) { j = i+1; if (j >= colors2) j = 0; c1 = order3[i]; c2 = order3[j]; w = oweights[c1] / oweights[c2]; n1 = osample[c1] + osample[c2]; x0 = osample[c1]; x = WalleniusNCHyp(n1, osource[c1], osource[c1]+osource[c2], w); if (x == x0) continue; // accepted if (f0 < 0.) f0 = wmnc.probability(osample); CWalleniusNCHypergeometric nc(n1, osource[c1], osource[c1]+osource[c2], w, accuracy); g0 = nc.probability(x0); g1 = nc.probability(x); osample[c1] = x; osample[c2] = n1 - x; f1 = wmnc.probability(osample); g0 = f1 * g0; g1 = f0 * g1; if (g0 >= g1 || g0 > g1 * Random()) { // new state accepted f0 = -1.;} else { // rejected. restore old sample osample[c1] = x0; osample[c2] = n1 - x0;}}}}} // finished sampling by either method // un-sort sample into destination and untangle re-orderings for (i=0; i < colors; i++) { c1 = order1[i]; c2 = order2[i]; if (source[c1] == osource[c2]) { destination[c1] = osample[c2];} else { // split colors with same weight that have been treated as one x = Hypergeometric(osample[c2], source[c1], osource[c2]); destination[c1] = x; osample[c2] -= x; osource[c2] -= source[c1];}}} /****************************************************************************** Multivariate complementary Wallenius noncentral hypergeometric distribution ******************************************************************************/ void StochasticLib3::MultiComplWalleniusNCHyp ( int32 * destination, int32 * source, double * weights, int32 n, int colors) { // This function generates a vector of random variables with the multivariate // complementary Wallenius noncentral hypergeometric distribution. // See MultiWalleniusNCHyp for details. double rweights[MAXCOLORS]; // reciprocal weights int32 sample[MAXCOLORS]; // balls sampled double w; // weight int32 N; // total number of balls int i; // color index // make reciprocal weights and calculate N for (i=0, N=0; i N || m > N || n < 0 || m < 0 || odds <= 0.) { if (odds == 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in function FishersNCHyp"); return 0;} FatalError("Parameter out of range in function FishersNCHyp");} if (odds == 1.) { // use hypergeometric function if odds == 1 return Hypergeometric(n, m, N);} // symmetry transformations fak = 1; addd = 0; if (m > N/2) { // invert m m = N - m; fak = -1; addd = n;} if (n > N/2) { // invert n n = N - n; addd += fak * m; fak = - fak;} if (n > m) { // swap n and m x = n; n = m; m = x;} // cases with only one possible result end here if (n == 0 || odds == 0.) return addd; if (fak == -1) { // reciprocal odds if inverting odds = 1. / odds;} // choose method if (n < 30 && N < 1024 && odds > 1.E-5 && odds < 1.E5) { // use inversion by chop down method x = FishersNCHypInversion (n, m, N, odds);} else { // use ratio-of-uniforms method x = FishersNCHypRatioOfUnifoms (n, m, N, odds);} // undo symmetry transformations return x * fak + addd;} /*********************************************************************** Subfunctions used by FishersNCHyp ***********************************************************************/ int32 StochasticLib3::FishersNCHypInversion (int32 n, int32 m, int32 N, double odds) { /* Subfunction for FishersNCHyp distribution. Implements Fisher's noncentral hypergeometric distribution by inversion method, using chop-down search starting at zero. Valid only for 0 <= n <= m <= N/2. Without overflow check the parameters must be limited to n < 30, N < 1024, and 1.E-5 < odds < 1.E5. This limitation is acceptable because this method is slow for higher n. The execution time of this function grows with n. See the file nchyp.pdf for theoretical explanation. */ static int32 fnc_n_last = -1, fnc_m_last = -1, fnc_N_last = -1; static double fnc_o_last = -1, fnc_f0, fnc_scale; int32 x; // x value int32 L; // derived parameter double f; // scaled function value double sum; // scaled sum of function values double a1, a2, b1, b2, f1, f2; // factors in recursive calculation double u; // uniform random variate L = N-m-n; if (n != fnc_n_last || m != fnc_m_last || N != fnc_N_last || odds != fnc_o_last) { // parameters have changed. set-up fnc_n_last = n; fnc_m_last = m; fnc_N_last = N; fnc_o_last = odds; // f(0) is set to an arbitrary value because it cancels out. // A low value is chosen to avoid overflow. fnc_f0 = 1.E-100; // calculate summation of e(x), using the formula: // f(x) = f(x-1) * (m-x+1)*(n-x+1)*odds / (x*(L+x)) // All divisions are avoided by scaling the parameters sum = f = fnc_f0; fnc_scale = 1.; a1 = m; a2 = n; b1 = 1; b2 = L + 1; for (x = 1; x <= n; x++) { f1 = a1 * a2 * odds; f2 = b1 * b2; a1--; a2--; b1++; b2++; f *= f1; sum *= f2; fnc_scale *= f2; sum += f; // overflow check. not needed if parameters are limited: // if (sum > 1E100) {sum *= 1E-100; f *= 1E-100; fnc_scale *= 1E-100;} } fnc_f0 *= fnc_scale; fnc_scale = sum; // now f(0) = fnc_f0 / fnc_scale. // We are still avoiding all divisions by saving the scale factor } // uniform random u = Random() * fnc_scale; // recursive calculation: // f(x) = f(x-1) * (m-x+1)*(n-x+1)*odds / (x*(L+x)) f = fnc_f0; x = 0; a1 = m; a2 = n; b1 = 0; b2 = L; do { u -= f; if (u <= 0) break; x++; b1++; b2++; f *= a1 * a2 * odds; u *= b1 * b2; // overflow check. not needed if parameters are limited: // if (u > 1.E100) {u *= 1E-100; f *= 1E-100;} a1--; a2--;} while (x < n); return x;} int32 StochasticLib3::FishersNCHypRatioOfUnifoms (int32 n, int32 m, int32 N, double odds) { /* Subfunction for FishersNCHyp distribution. Valid for 0 <= n <= m <= N/2, odds != 1 Fisher's noncentral hypergeometric distribution by ratio-of-uniforms rejection method. The execution time of this function is almost independent of the parameters. */ static int32 fnc_n_last = -1, fnc_m_last = -1, fnc_N_last = -1; // previous parameters static double fnc_o_last = -1; static int32 fnc_bound; // upper bound static double fnc_a; // hat center static double fnc_h; // hat width static double fnc_lfm; // ln(f(mode)) static double fnc_logb; // ln(odds) int32 L; // N-m-n int32 mode; // mode double mean; // mean double variance; // variance double x; // real sample int32 k; // integer sample double u; // uniform random double lf; // ln(f(x)) double AA, BB, g1, g2; // temporary L = N-m-n; if (n != fnc_n_last || m != fnc_m_last || N != fnc_N_last || odds != fnc_o_last) { // parameters have changed. set-up fnc_n_last = n; fnc_m_last = m; fnc_N_last = N; fnc_o_last = odds; // find approximate mean AA = (m+n)*odds+L; BB = sqrt(AA*AA - 4*odds*(odds-1)*m*n); mean = (AA-BB)/(2*(odds-1)); // find approximate variance AA = mean * (m-mean); BB = (n-mean)*(mean+L); variance = N*AA*BB/((N-1)*(m*BB+(n+L)*AA)); // compute log(odds) fnc_logb = log(odds); // find center and width of hat function fnc_a = mean + 0.5; fnc_h = 1.028 + 1.717*sqrt(variance+0.5) + 0.032*fabs(fnc_logb); // find safety bound fnc_bound = (int32)(mean + 4.0 * fnc_h); if (fnc_bound > n) fnc_bound = n; // find mode mode = (int32)(mean); g1 =(double)(m-mode)*(n-mode)*odds; g2 =(double)(mode+1)*(L+mode+1); if (g1 > g2 && mode < n) mode++; // value at mode to scale with: fnc_lfm = mode * fnc_logb - fc_lnpk(mode, L, m, n);} while(1) { u = Random(); if (u == 0) continue; // avoid divide by 0 x = fnc_a + fnc_h * (Random()-0.5)/u; if (x < 0. || x > 2E9) continue; // reject, avoid overflow k = (int32)(x); // truncate if (k > fnc_bound) continue; // reject if outside safety bound lf = k*fnc_logb - fc_lnpk(k,L,m,n) - fnc_lfm; // compute function value if (u * (4.0 - u) - 3.0 <= lf) break; // lower squeeze accept if (u * (u-lf) > 1.0) continue; // upper squeeze reject if (2.0 * log(u) <= lf) break;} // final acceptance return k;} /*********************************************************************** Multivariate Fisher's noncentral hypergeometric distribution ***********************************************************************/ void StochasticLib3::MultiFishersNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors) { /* This function generates a vector of random variates with the multivariate Fisher's noncentral hypergeometric distribution. This distribution is defined as the conditional distribution of 'colors' independent binomial variates x[i] = binomial(source[i], p[i]) on the condition that the sum of all x[i] is n. p[i] = r * weights[i] / (1 + r * weights[i]), r is an arbitrary scale factor. Parameters: destination: An output array to receive the number of balls of each color. Must have space for at least 'colors' elements. source: An input array containing the number of balls of each color in the urn. Must have 'colors' elements. All elements must be non-negative. weights: The odds of each color. Must have 'colors' elements. All elements must be non-negative. n: The number of balls drawn from the urn. Can't exceed the total number of balls with nonzero weight in the urn. colors: The number of possible colors. Method: The conditional method is used for generating a sample with the approximate distribution. This sample is used as a starting point for a Gibbs sampler. The accuracy depends on the number of scans with the Gibbs sampler. The function will reduce the number of colors, if possible, by eliminating colors with zero weight or zero number and pooling together colors with the same weight. A symmetry transformation is used if more than half the balls are taken. The problem thus reduced is handled in the arrays osource, oweights and osample of dimension colors2. */ int order1[MAXCOLORS]; // sort order, index into source and destination int order2[MAXCOLORS]; // corresponding index into osource when equal weights pooled together int order3[MAXCOLORS]; // secondary index for sorting by variance int32 osource[MAXCOLORS]; // contents of source, sorted by weight with equal weights pooled together int32 osample[MAXCOLORS]; // balls sampled, sorted by weight double oweights[MAXCOLORS]; // sorted list of weights double var[MAXCOLORS]; // sorted list of variance int32 x = 0; // univariate sample int32 m; // number of items of one color int32 m1, m2; // number of items in each weight group int32 msum; // total number of items of several or all colors int32 n0; // remaining balls to sample int32 n1, n2; // sample size for each weight group double w = 0.; // weight or variance of items of one color double w1, w2; // mean weight of each weight group double wsum; // total weight of all items of several or all colors double odds; // weight ratio int i, j, k; // loop counters int a, b; // limits for weight group int c, c1, c2; // color index int colors2; // reduced number of colors, number of entries in osource int ngibbs; // number of scans in Gibbs sampler int invert = 0; // 1 if symmetry transformation used // check validity of parameters if (n < 0 || colors < 0 || colors > MAXCOLORS) FatalError("Parameter out of range in function MultiFishersNCHyp"); if (colors == 0) return; if (n == 0) {for (i=0; i w && source[c2]) { w = weights[c2]; k = j;}} order1[i] = order1[k]; order1[k] = c;} // Skip any items with zero weight // this solves all problems with zero weights while (colors && (weights[c=order1[colors-1]]==0 || source[c]==0)) { colors--; destination[c] = 0;} // check if we are taking all, or too many, balls if (n >= msum) { if (n > msum) FatalError("Taking more items than there are in function MultiFishersNCHyp"); for (i = 0; i < colors; i++) {c = order1[i]; destination[c] = source[c];} return;} if (n > msum / 2) { // improve accuracy by symmetry transformation for (i=0, j=colors-1; i < j; i++, j--) { // reverse order list c = order1[i]; order1[i] = order1[j]; order1[j] = c;} n = msum - n; invert = 1;} // copy source and weights into ordered lists and pool together colors with same weight for (i=0, c2=-1; i < colors; i++) { c = order1[i]; if (i==0 || weights[c] != w) { c2++; x = source[c]; oweights[c2] = w = invert ? 1./weights[c] : weights[c];} else { x += source[c];} osource[c2] = x; order2[i] = c2; osample[c2] = 0;} colors2 = c2 + 1; // simple cases if (colors2 == 1) osample[0] = n; if (colors2 == 2) { x = FishersNCHyp(n, osource[0], msum, oweights[0]/oweights[1]); osample[0] = x; osample[1] = n - x;} if (colors2 > 2) { // divide weights into two groups, heavy and light a = 0; b = colors2-1; w = sqrt(oweights[0] * oweights[colors2-1]); do { c = (a + b) / 2; if (oweights[c] > w) a = c; else b = c;} while (b > a + 1); a = 0; // heavy group goes from a to b-1, light group goes from b to colors2-1 // calculate mean weight for heavy group for (i=a, m1=0, wsum=0; i < b; i++) { m1 += osource[i]; wsum += oweights[i] * osource[i];} w1 = wsum / m1; // calculate mean weight for light group for (i=b, m2=0, wsum=0; i < colors2; i++) { m2 += osource[i]; wsum += oweights[i] * osource[i];} w2 = wsum / m2; // split sample n into heavy (n1) and light (n2) groups n1 = FishersNCHyp(n, m1, m1+m2, w1/w2); n2 = n - n1; n0 = n1; // loop twice, for the two groops for (k=0; k < 2; k++) { // split group into single colors by calling FishersNCHyp b-a-1 times for (i = a; i < b-1; i++) { m = osource[i]; w = oweights[i]; // calculate mean weight of remaining colors for (j=i+1, msum=0, wsum=0; j < b; j++) { m1 = osource[j]; w1 = oweights[j]; msum += m1; wsum += m1 * w1;} // split out color i if (w == w1) { x = Hypergeometric(n0, m, msum + m);} else { if (wsum == 0) { x = n0;} else { odds = w * msum / wsum; x = FishersNCHyp(n0, m, msum + m, odds);}} osample[i] += x; n0 -= x;} // get the last color in the group osample[i] += n0; // set parameters for second group a = b; b = colors2; n0 = n2;} // calculate variance CMultiFishersNCHypergeometric(n, osource, oweights, colors2).variance(var); // sort again, this time by variance for (i=0; i < colors2-1; i++) { c = order3[i]; k = i; w = var[c]; for (j=i+1; j < colors2; j++) { c2 = order3[j]; if (var[c2] > w) { w = var[c2]; k = j;}} order3[i] = order3[k]; order3[k] = c;} // determine number of scans (not fine-tuned): ngibbs = 4; if (accuracy < 1E-6) ngibbs = 6; if (colors2 > 5) ngibbs++; // Gibbs sampler for (k = 0; k < ngibbs; k++) { for (i = 0; i < colors2; i++) { c1 = order3[i]; j = i + 1; if (j == colors2) j = 0; c2 = order3[j]; n1 = osample[c1] + osample[c2]; x = FishersNCHyp(n1, osource[c1], osource[c1]+osource[c2], oweights[c1]/oweights[c2]); osample[c1] = x; osample[c2] = n1 - x;}}} if (invert) { // reverse symmetry transformation on result for (i=0; i < colors2; i++) { osample[i] = osource[i] - osample[i];}} // un-sort sample into destination for (i=0; i < colors; i++) { c1 = order1[i]; c2 = order2[i]; if (source[c1] == osource[c2]) { destination[c1] = osample[c2];} else { x = Hypergeometric(osample[c2], source[c1], osource[c2]); destination[c1] = x; osample[c2] -= x; osource[c2] -= source[c1];}}} BiasedUrn/src/stoc1.cpp0000644000176200001440000007332412640160171014461 0ustar liggesusers/*************************** stoc1.cpp ********************************** * Author: Agner Fog * Date created: 2002-01-04 * Last modified: 2008-11-30 * Project: stocc.zip * Source URL: www.agner.org/random * * Description: * Non-uniform random number generator functions. * * This file contains source code for the class StochasticLib1 defined in stocc.h. * * Documentation: * ============== * The file stocc.h contains class definitions. * Further documentation at www.agner.org/random * * Copyright 2002-2008 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include "stocc.h" // class definition /*********************************************************************** constants ***********************************************************************/ const double SHAT1 = 2.943035529371538573; // 8/e const double SHAT2 = 0.8989161620588987408; // 3-sqrt(12/e) /*********************************************************************** Log factorial function ***********************************************************************/ double LnFac(int32 n) { // log factorial function. gives natural logarithm of n! // define constants static const double // coefficients in Stirling approximation C0 = 0.918938533204672722, // ln(sqrt(2*pi)) C1 = 1./12., C3 = -1./360.; // C5 = 1./1260., // use r^5 term if FAK_LEN < 50 // C7 = -1./1680.; // use r^7 term if FAK_LEN < 20 // static variables static double fac_table[FAK_LEN]; // table of ln(n!): static int initialized = 0; // remember if fac_table has been initialized if (n < FAK_LEN) { if (n <= 1) { if (n < 0) FatalError("Parameter negative in LnFac function"); return 0; } if (!initialized) { // first time. Must initialize table // make table of ln(n!) double sum = fac_table[0] = 0.; for (int i=1; i N || m > N || n < 0 || m < 0) { FatalError("Parameter out of range in hypergeometric function");} // symmetry transformations fak = 1; addd = 0; if (m > N/2) { // invert m m = N - m; fak = -1; addd = n; } if (n > N/2) { // invert n n = N - n; addd += fak * m; fak = - fak; } if (n > m) { // swap n and m x = n; n = m; m = x; } // cases with only one possible result end here if (n == 0) return addd; //------------------------------------------------------------------ // choose method //------------------------------------------------------------------ if (N > 680 || n > 70) { // use ratio-of-uniforms method x = HypRatioOfUnifoms (n, m, N); } else { // inversion method, using chop-down search from mode x = HypInversionMod (n, m, N); } // undo symmetry transformations return x * fak + addd; } /*********************************************************************** Subfunctions used by hypergeometric ***********************************************************************/ int32 StochasticLib1::HypInversionMod (int32 n, int32 m, int32 N) { /* Subfunction for Hypergeometric distribution. Assumes 0 <= n <= m <= N/2. Overflow protection is needed when N > 680 or n > 75. Hypergeometric distribution by inversion method, using down-up search starting at the mode using the chop-down technique. This method is faster than the rejection method when the variance is low. */ // Setup static int32 h_n_last = -1, h_m_last = -1, h_N_last = -1; // Last values static int32 h_mode, h_mp; // Mode, mode+1 static int32 h_bound; // Safety bound static double h_fm; // Value at mode // Sampling int32 I; // Loop counter int32 L = N - m - n; // Parameter double modef; // mode, float double Mp, np; // m + 1, n + 1 double p; // temporary double U; // uniform random double c, d; // factors in iteration double divisor; // divisor, eliminated by scaling double k1, k2; // float version of loop counter double L1 = L; // float version of L Mp = (double)(m + 1); np = (double)(n + 1); if (N != h_N_last || m != h_m_last || n != h_n_last) { // set-up when parameters have changed h_N_last = N; h_m_last = m; h_n_last = n; p = Mp / (N + 2.); modef = np * p; // mode, real h_mode = (int32)modef; // mode, integer if (h_mode == modef && p == 0.5) { h_mp = h_mode--; } else { h_mp = h_mode + 1; } // mode probability, using log factorial function // (may read directly from fac_table if N < FAK_LEN) h_fm = exp(LnFac(N-m) - LnFac(L+h_mode) - LnFac(n-h_mode) + LnFac(m) - LnFac(m-h_mode) - LnFac(h_mode) - LnFac(N) + LnFac(N-n) + LnFac(n) ); // safety bound - guarantees at least 17 significant decimal digits // bound = min(n, (int32)(modef + k*c')) h_bound = (int32)(modef + 11. * sqrt(modef * (1.-p) * (1.-n/(double)N)+1.)); if (h_bound > n) h_bound = n; } // loop until accepted while(1) { U = Random(); // uniform random number to be converted // start chop-down search at mode if ((U -= h_fm) <= 0.) return(h_mode); c = d = h_fm; // alternating down- and upward search from the mode k1 = h_mp - 1; k2 = h_mode + 1; for (I = 1; I <= h_mode; I++, k1--, k2++) { // Downward search from k1 = h_mp - 1 divisor = (np - k1)*(Mp - k1); // Instead of dividing c with divisor, we multiply U and d because // multiplication is faster. This will give overflow if N > 800 U *= divisor; d *= divisor; c *= k1 * (L1 + k1); if ((U -= c) <= 0.) return(h_mp - I - 1); // = k1 - 1 // Upward search from k2 = h_mode + 1 divisor = k2 * (L1 + k2); // re-scale parameters to avoid time-consuming division U *= divisor; c *= divisor; d *= (np - k2) * (Mp - k2); if ((U -= d) <= 0.) return(h_mode + I); // = k2 // Values of n > 75 or N > 680 may give overflow if you leave out this.. // overflow protection // if (U > 1.E100) {U *= 1.E-100; c *= 1.E-100; d *= 1.E-100;} } // Upward search from k2 = 2*mode + 1 to bound for (k2 = I = h_mp + h_mode; I <= h_bound; I++, k2++) { divisor = k2 * (L1 + k2); U *= divisor; d *= (np - k2) * (Mp - k2); if ((U -= d) <= 0.) return(I); // more overflow protection // if (U > 1.E100) {U *= 1.E-100; d *= 1.E-100;} } } } int32 StochasticLib1::HypRatioOfUnifoms (int32 n, int32 m, int32 N) { /* Subfunction for Hypergeometric distribution using the ratio-of-uniforms rejection method. This code is valid for 0 < n <= m <= N/2. The computation time hardly depends on the parameters, except that it matters a lot whether parameters are within the range where the LnFac function is tabulated. Reference: E. Stadlober: "The ratio of uniforms approach for generating discrete random variates". Journal of Computational and Applied Mathematics, vol. 31, no. 1, 1990, pp. 181-189. */ static int32 h_N_last = -1; // previous parameter static int32 h_m_last = -1; // previous parameter static int32 h_n_last = -1; // previous parameter static int32 h_bound; // upper bound static double h_a; // hat center static double h_h; // hat width static double h_g; // value at mode int32 L; // N-m-n int32 mode; // mode int32 k; // integer sample double x; // real sample double rNN; // 1/(N*(N+2)) double my; // mean double var; // variance double u; // uniform random double lf; // ln(f(x)) L = N - m - n; if (h_N_last != N || h_m_last != m || h_n_last != n) { h_N_last = N; h_m_last = m; h_n_last = n; // Set-up rNN = 1. / ((double)N*(N+2)); // make two divisions in one my = (double)n * m * rNN * (N+2); // mean = n*m/N mode = (int32)(double(n+1) * double(m+1) * rNN * N); // mode = floor((n+1)*(m+1)/(N+2)) var = (double)n * m * (N-m) * (N-n) / ((double)N*N*(N-1)); // variance h_h = sqrt(SHAT1 * (var+0.5)) + SHAT2; // hat width h_a = my + 0.5; // hat center h_g = fc_lnpk(mode, L, m, n); // maximum h_bound = (int32)(h_a + 4.0 * h_h); // safety-bound if (h_bound > n) h_bound = n; } while(1) { u = Random(); // uniform random number if (u == 0) continue; // avoid division by 0 x = h_a + h_h * (Random()-0.5) / u; // generate hat distribution if (x < 0. || x > 2E9) continue; // reject, avoid overflow k = (int32)x; if (k > h_bound) continue; // reject if outside range lf = h_g - fc_lnpk(k,L,m,n); // ln(f(k)) if (u * (4.0 - u) - 3.0 <= lf) break; // lower squeeze accept if (u * (u-lf) > 1.0) continue; // upper squeeze reject if (2.0 * log(u) <= lf) break; // final acceptance } return k; } double StochasticLib1::fc_lnpk(int32 k, int32 L, int32 m, int32 n) { // subfunction used by hypergeometric and Fisher's noncentral hypergeometric distribution return(LnFac(k) + LnFac(m - k) + LnFac(n - k) + LnFac(L + k)); } #ifndef R_BUILD // Not needed if making R interface /*********************************************************************** Multivariate hypergeometric distribution ***********************************************************************/ void StochasticLib1::MultiHypergeometric (int32 * destination, int32 * source, int32 n, int colors) { /* This function generates a vector of random variates, each with the hypergeometric distribution. The multivariate hypergeometric distribution is the distribution you get when drawing balls from an urn with more than two colors, without replacement. Parameters: destination: An output array to receive the number of balls of each color. Must have space for at least 'colors' elements. source: An input array containing the number of balls of each color in the urn. Must have 'colors' elements. All elements must be non-negative. n: The number of balls drawn from the urn. Can't exceed the total number of balls in the urn. colors: The number of possible colors. */ int32 sum, x, y; int i; if (n < 0 || colors < 0) FatalError("Parameter negative in multihypergeo function"); if (colors == 0) return; // compute total number of balls for (i = 0, sum = 0; i < colors; i++) { y = source[i]; if (y < 0) FatalError("Parameter negative in multihypergeo function"); sum += y; } if (n > sum) FatalError("n > sum in multihypergeo function"); for (i = 0; i < colors-1; i++) { // generate output by calling hypergeometric colors-1 times y = source[i]; x = Hypergeometric(n, y, sum); n -= x; sum -= y; destination[i] = x; } // get the last one destination[i] = n; } /*********************************************************************** Poisson distribution ***********************************************************************/ int32 StochasticLib1::Poisson (double L) { /* This function generates a random variate with the poisson distribution. Uses inversion by chop-down method for L < 17, and ratio-of-uniforms method for L >= 17. For L < 1.E-6 numerical inaccuracy is avoided by direct calculation. */ //------------------------------------------------------------------ // choose method //------------------------------------------------------------------ if (L < 17) { if (L < 1.E-6) { if (L == 0) return 0; if (L < 0) FatalError("Parameter negative in poisson function"); //-------------------------------------------------------------- // calculate probabilities //-------------------------------------------------------------- // For extremely small L we calculate the probabilities of x = 1 // and x = 2 (ignoring higher x). The reason for using this // method is to prevent numerical inaccuracies in other methods. //-------------------------------------------------------------- return PoissonLow(L); } else { //-------------------------------------------------------------- // inversion method //-------------------------------------------------------------- // The computation time for this method grows with L. // Gives overflow for L > 80 //-------------------------------------------------------------- return PoissonInver(L); } } else { if (L > 2.E9) FatalError("Parameter too big in poisson function"); //---------------------------------------------------------------- // ratio-of-uniforms method //---------------------------------------------------------------- // The computation time for this method does not depend on L. // Use where other methods would be slower. //---------------------------------------------------------------- return PoissonRatioUniforms(L); } } /*********************************************************************** Subfunctions used by poisson ***********************************************************************/ int32 StochasticLib1::PoissonLow(double L) { /* This subfunction generates a random variate with the poisson distribution for extremely low values of L. The method is a simple calculation of the probabilities of x = 1 and x = 2. Higher values are ignored. The reason for using this method is to avoid the numerical inaccuracies in other methods. */ double d, r; d = sqrt(L); if (Random() >= d) return 0; r = Random() * d; if (r > L * (1.-L)) return 0; if (r > 0.5 * L*L * (1.-L)) return 1; return 2; } int32 StochasticLib1::PoissonInver(double L) { /* This subfunction generates a random variate with the poisson distribution using inversion by the chop down method (PIN). Execution time grows with L. Gives overflow for L > 80. The value of bound must be adjusted to the maximal value of L. */ const int bound = 130; // safety bound. Must be > L + 8*sqrt(L). static double p_L_last = -1.; // previous value of L static double p_f0; // value at x=0 double r; // uniform random number double f; // function value int32 x; // return value if (L != p_L_last) { // set up p_L_last = L; p_f0 = exp(-L); // f(0) = probability of x=0 } while (1) { r = Random(); x = 0; f = p_f0; do { // recursive calculation: f(x) = f(x-1) * L / x r -= f; if (r <= 0) return x; x++; f *= L; r *= x; // instead of f /= x } while (x <= bound); } } int32 StochasticLib1::PoissonRatioUniforms(double L) { /* This subfunction generates a random variate with the poisson distribution using the ratio-of-uniforms rejection method (PRUAt). Execution time does not depend on L, except that it matters whether L is within the range where ln(n!) is tabulated. Reference: E. Stadlober: "The ratio of uniforms approach for generating discrete random variates". Journal of Computational and Applied Mathematics, vol. 31, no. 1, 1990, pp. 181-189. */ static double p_L_last = -1.0; // previous L static double p_a; // hat center static double p_h; // hat width static double p_g; // ln(L) static double p_q; // value at mode static int32 p_bound; // upper bound int32 mode; // mode double u; // uniform random double lf; // ln(f(x)) double x; // real sample int32 k; // integer sample if (p_L_last != L) { p_L_last = L; // Set-up p_a = L + 0.5; // hat center mode = (int32)L; // mode p_g = log(L); p_q = mode * p_g - LnFac(mode); // value at mode p_h = sqrt(SHAT1 * (L+0.5)) + SHAT2; // hat width p_bound = (int32)(p_a + 6.0 * p_h); // safety-bound } while(1) { u = Random(); if (u == 0) continue; // avoid division by 0 x = p_a + p_h * (Random() - 0.5) / u; if (x < 0 || x >= p_bound) continue; // reject if outside valid range k = (int32)(x); lf = k * p_g - LnFac(k) - p_q; if (lf >= u * (4.0 - u) - 3.0) break; // quick acceptance if (u * (u - lf) > 1.0) continue; // quick rejection if (2.0 * log(u) <= lf) break; // final acceptance } return(k); } /*********************************************************************** Binomial distribution ***********************************************************************/ int32 StochasticLib1::Binomial (int32 n, double p) { /* This function generates a random variate with the binomial distribution. Uses inversion by chop-down method for n*p < 35, and ratio-of-uniforms method for n*p >= 35. For n*p < 1.E-6 numerical inaccuracy is avoided by poisson approximation. */ int inv = 0; // invert int32 x; // result double np = n * p; if (p > 0.5) { // faster calculation by inversion p = 1. - p; inv = 1; } if (n <= 0 || p <= 0) { if (n == 0 || p == 0) return inv * n; // only one possible result FatalError("Parameter out of range in binomial function"); // error exit } //------------------------------------------------------------------ // choose method //------------------------------------------------------------------ if (np < 35.) { if (np < 1.E-6) { // Poisson approximation for extremely low np x = PoissonLow(np); } else { // inversion method, using chop-down search from 0 x = BinomialInver(n, p); } } else { // ratio of uniforms method x = BinomialRatioOfUniforms(n, p); } if (inv) { x = n - x; // undo inversion } return x; } /*********************************************************************** Subfunctions used by binomial ***********************************************************************/ int32 StochasticLib1::BinomialInver (int32 n, double p) { /* Subfunction for Binomial distribution. Assumes p < 0.5. Uses inversion method by search starting at 0. Gives overflow for n*p > 60. This method is fast when n*p is low. */ double f0, f, q; int32 bound; double pn, r, rc; int32 x, n1, i; // f(0) = probability of x=0 is (1-p)^n // fast calculation of (1-p)^n f0 = 1.; pn = 1.-p; n1 = n; while (n1) { if (n1 & 1) f0 *= pn; pn *= pn; n1 >>= 1; } // calculate safety bound rc = (n + 1) * p; bound = (int32)(rc + 11.0*(sqrt(rc) + 1.0)); if (bound > n) bound = n; q = p / (1. - p); while (1) { r = Random(); // recursive calculation: f(x) = f(x-1) * (n-x+1)/x*p/(1-p) f = f0; x = 0; i = n; do { r -= f; if (r <= 0) return x; x++; f *= q * i; r *= x; // it is faster to multiply r by x than dividing f by x i--; } while (x <= bound); } } int32 StochasticLib1::BinomialRatioOfUniforms (int32 n, double p) { /* Subfunction for Binomial distribution. Assumes p < 0.5. Uses the Ratio-of-Uniforms rejection method. The computation time hardly depends on the parameters, except that it matters a lot whether parameters are within the range where the LnFac function is tabulated. Reference: E. Stadlober: "The ratio of uniforms approach for generating discrete random variates". Journal of Computational and Applied Mathematics, vol. 31, no. 1, 1990, pp. 181-189. */ static int32 b_n_last = -1; // last n static double b_p_last = -1.; // last p static int32 b_mode; // mode static int32 b_bound; // upper bound static double b_a; // hat center static double b_h; // hat width static double b_g; // value at mode static double b_r1; // ln(p/(1-p)) double u; // uniform random double q1; // 1-p double np; // n*p double var; // variance double lf; // ln(f(x)) double x; // real sample int32 k; // integer sample if(b_n_last != n || b_p_last != p) { // Set_up b_n_last = n; b_p_last = p; q1 = 1.0 - p; np = n * p; b_mode = (int32)(np + p); // mode b_a = np + 0.5; // hat center b_r1 = log(p / q1); b_g = LnFac(b_mode) + LnFac(n-b_mode); var = np * q1; // variance b_h = sqrt(SHAT1 * (var+0.5)) + SHAT2; // hat width b_bound = (int32)(b_a + 6.0 * b_h); // safety-bound if (b_bound > n) b_bound = n; // safety-bound } while (1) { // rejection loop u = Random(); if (u == 0) continue; // avoid division by 0 x = b_a + b_h * (Random() - 0.5) / u; if (x < 0. || x > b_bound) continue; // reject, avoid overflow k = (int32)x; // truncate lf = (k-b_mode)*b_r1+b_g-LnFac(k)-LnFac(n-k);// ln(f(k)) if (u * (4.0 - u) - 3.0 <= lf) break; // lower squeeze accept if (u * (u - lf) > 1.0) continue; // upper squeeze reject if (2.0 * log(u) <= lf) break; // final acceptance } return k; } /*********************************************************************** Multinomial distribution ***********************************************************************/ void StochasticLib1::Multinomial (int32 * destination, double * source, int32 n, int colors) { /* This function generates a vector of random variates, each with the binomial distribution. The multinomial distribution is the distribution you get when drawing balls from an urn with more than two colors, with replacement. Parameters: destination: An output array to receive the number of balls of each color. Must have space for at least 'colors' elements. source: An input array containing the probability or fraction of each color in the urn. Must have 'colors' elements. All elements must be non-negative. The sum doesn't have to be 1, but the sum must be positive. n: The number of balls drawn from the urn. colors: The number of possible colors. */ double s, sum; int32 x; int i; if (n < 0 || colors < 0) FatalError("Parameter negative in multinomial function"); if (colors == 0) return; // compute sum of probabilities for (i=0, sum=0; i 0) FatalError("Zero sum in multinomial function"); for (i=0; i 0) FatalError("Zero sum in multinomial function"); for (i=0; i= 1. || w < 1E-30); w = sqrt(log(w)*(-2./w)); normal_x1 *= w; normal_x2 *= w; // normal_x1 and normal_x2 are independent normally distributed variates normal_x2_valid = 1; // save normal_x2 for next call return normal_x1 * s + m; } /*********************************************************************** Bernoulli distribution ***********************************************************************/ int StochasticLib1::Bernoulli(double p) { // Bernoulli distribution with parameter p. This function returns // 0 or 1 with probability (1-p) and p, respectively. if (p < 0 || p > 1) FatalError("Parameter out of range in Bernoulli function"); return Random() < p; } /*********************************************************************** Shuffle function ***********************************************************************/ void StochasticLib1::Shuffle(int * list, int min, int n) { /* This function makes a list of the n numbers from min to min+n-1 in random order. The parameter 'list' must be an array with at least n elements. The array index goes from 0 to n-1. If you want to shuffle something else than integers then use the integers in list as an index into a table of the items you want to shuffle. */ int i, j, swap; // put numbers from min to min+n-1 into list for (i=0, j=min; i #ifdef __INTEL_COMPILER #include // Intel math function library #else #include // default math function linrary #endif // Define 32 bit signed and unsigned integers. // Change these definitions, if necessary, on 64 bit computers #if defined(_WIN16) || defined(__MSDOS__) || defined(_MSDOS) // 16 bit system typedef long int int32; // 32 bit signed integer typedef unsigned long int uint32; // 32 bit unsigned integer #else typedef int int32; // 32 bit signed integer typedef unsigned int uint32; // 32 bit unsigned integer #endif /*********************************************************************** System-specific user interface functions ***********************************************************************/ void EndOfProgram(void); // system-specific exit code (userintf.cpp) void FatalError(const char * ErrorText); // system-specific error reporting (userintf.cpp) /*********************************************************************** Different random number generator classes ***********************************************************************/ class TRandomMersenne { // encapsulate random number generator #if 0 // define constants for MT11213A: // (32 bit constants cannot be defined as enum in 16-bit compilers) #define MERS_N 351 #define MERS_M 175 #define MERS_R 19 #define MERS_U 11 #define MERS_S 7 #define MERS_T 15 #define MERS_L 17 #define MERS_A 0xE4BD75F5 #define MERS_B 0x655E5280 #define MERS_C 0xFFD58000 #else // or constants for MT19937: #define MERS_N 624 #define MERS_M 397 #define MERS_R 31 #define MERS_U 11 #define MERS_S 7 #define MERS_T 15 #define MERS_L 18 #define MERS_A 0x9908B0DF #define MERS_B 0x9D2C5680 #define MERS_C 0xEFC60000 #endif public: TRandomMersenne(uint32 seed) { // constructor RandomInit(seed);} void RandomInit(uint32 seed); // re-seed void RandomInitByArray(uint32 seeds[], int length); // seed by more than 32 bits int IRandom(int min, int max); // output random integer double Random(); // output random float uint32 BRandom(); // output random bits private: uint32 mt[MERS_N]; // state vector int mti; // index into mt enum TArch {LITTLE_ENDIAN1, BIG_ENDIAN1, NONIEEE}; TArch Architecture; // conversion to float depends on computer architecture }; class TRanrotBGenerator { // encapsulate random number generator enum constants { // define parameters KK = 17, JJ = 10, R1 = 13, R2 = 9}; public: void RandomInit(uint32 seed); // initialization int IRandom(int min, int max); // get integer random number in desired interval double Random(); // get floating point random number TRanrotBGenerator(uint32 seed); // constructor protected: int p1, p2; // indexes into buffer uint32 randbuffer[KK]; // history buffer uint32 randbufcopy[KK*2]; // used for self-test enum TArch {LITTLE_ENDIAN1, BIG_ENDIAN1, NONIEEE}; TArch Architecture; // conversion to float depends on computer architecture }; class TRanrotWGenerator { // encapsulate random number generator enum constants { // define parameters KK = 17, JJ = 10, R1 = 19, R2 = 27}; public: void RandomInit(uint32 seed); // initialization int IRandom(int min, int max); // get integer random number in desired interval long double Random(); // get floating point random number uint32 BRandom(); // output random bits TRanrotWGenerator(uint32 seed); // constructor protected: int p1, p2; // indexes into buffer union { // used for conversion to float long double randp1; uint32 randbits[3];}; uint32 randbuffer[KK][2]; // history buffer uint32 randbufcopy[KK*2][2]; // used for self-test enum TArch {LITTLE_ENDIAN1, BIG_ENDIAN1, NONIEEE, EXTENDEDPRECISIONLITTLEENDIAN}; TArch Architecture; // conversion to float depends on computer architecture }; class TRandomMotherOfAll { // encapsulate random number generator public: void RandomInit(uint32 seed); // initialization int IRandom(int min, int max); // get integer random number in desired interval double Random(); // get floating point random number TRandomMotherOfAll(uint32 seed); // constructor protected: double x[5]; // history buffer }; #endif BiasedUrn/src/stocR.cpp0000644000176200001440000000175012640160171014514 0ustar liggesusers/*************************** stocR.cpp ********************************** * Author: Agner Fog * Date created: 2006 * Last modified: 2011-08-05 * Project: BiasedUrn * Source URL: www.agner.org/random * * Description: * Interface of non-uniform random number generators to R-language implementation. * This file contains source code for the class StocRBase defined in stocR.h. * * Copyright 2006-2011 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include "stocc.h" // class definition /*********************************************************************** Fatal error exit (Replaces userintf.cpp) ***********************************************************************/ void FatalError(const char * ErrorText) { // This function outputs an error message and aborts the program. error("%s", ErrorText); // Error exit in R.DLL } BiasedUrn/src/urn1.cpp0000644000176200001440000016234612640160171014320 0ustar liggesusers/*************************** urn1.cpp ********************************** * Author: Agner Fog * Date created: 2006 * Last modified: 2011-08-05 * Project: BiasedUrn * Source URL: www.agner.org/random * * Description: * R interface to univariate noncentral hypergeometric distributions * * Copyright 2006-2011 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include #include #include "stocc.h" /****************************************************************************** dFNCHypergeo Mass function, Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP dFNCHypergeo( SEXP rx, // Number of red balls drawn, scalar or vector SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation // ,SEXP rlog // Will return log(p) if TRUE ) { // Check for vectors if (LENGTH(rx) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 // || LENGTH(rlog) > 1 ) { error("Parameter has wrong length"); } // Get parameter values int *px = INTEGER(rx); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); //int ilog = *LOGICAL(rlog); int nres = LENGTH(rx); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double factor; // Scale factor int x; // Temporary x int32 x1, x2; // Table limits int xmin, xmax; // Absolute limits for x int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CFishersNCHypergeometric fnc(n, m1, N, odds, prec); // Check if it is advantageous to use MakeTable: if (nres > 1 && (BufferLength = (int)fnc.MakeTable(buffer, 0, &x1, &x2), (uint32)nres > (uint32)BufferLength / 32)) { // Use MakeTable xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities factor = 1. / fnc.MakeTable(buffer, BufferLength, &x1, &x2, prec*0.001); // Get probabilities from table for (i = 0; i < nres; i++) { x = px[i]; if (x >= x1 && x <= x2) { // x within table presult[i] = buffer[x - x1] * factor; // Get result from table } else if (x >= xmin && x <= xmax) { // Outside table. Result is very small but not 0 presult[i] = fnc.probability(x); // Calculate result } else { // Impossible value of x presult[i] = 0.; // Result is 0 } // if (ilog) presult[i] = log(presult[i]); // Log desired } } else { // Calculate probabilities one by one for (i = 0; i < nres; i++) { presult[i] = fnc.probability(px[i]); // Probability //if (ilog) presult[i] = log(presult[i]); // Log desired } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** dWNCHypergeo Mass function, Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP dWNCHypergeo( SEXP rx, // Number of red balls drawn, scalar or vector SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation // ,SEXP rlog // Will return log(p) if TRUE ) { // Check for vectors if (LENGTH(rx) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 // || LENGTH(rlog) > 1 ) { error("Parameter has wrong length"); } // Get parameter values int * px = INTEGER(rx); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); //int ilog = *LOGICAL(rlog); int nres = LENGTH(rx); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table int x; // Temporary x int32 x1, x2; // Table limits int xmin, xmax; // Absolute limits for x int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CWalleniusNCHypergeometric wnc(n, m1, N, odds, prec); // Check if it is advantageous to use MakeTable: if (nres > 1 && (BufferLength = wnc.MakeTable(buffer, 0, &x1, &x2), x1)) { // Use MakeTable xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities wnc.MakeTable(buffer, BufferLength, &x1, &x2, prec*0.001); // Get probabilities from table for (i = 0; i < nres; i++) { x = px[i]; if (x >= x1 && x <= x2) { // x within table presult[i] = buffer[x - x1]; // Get result from table } else if (x >= xmin && x <= xmax) { // Outside table. Result is very small but not 0 presult[i] = wnc.probability(x); // Calculate result } else { // Impossible value of x presult[i] = 0.; // Result is 0 } // if (ilog) presult[i] = log(presult[i]); // Log desired } } else { // Calculate probabilities one by one for (i = 0; i < nres; i++) { presult[i] = wnc.probability(px[i]); //if (ilog) presult[i] = log(presult[i]); } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** pFNCHypergeo Cumulative distribution function for Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP pFNCHypergeo( SEXP rx, // Number of red balls drawn, scalar or vector SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rlower_tail // TRUE: P(X <= x), FALSE: P(X > x) ) { // Check for vectors if (LENGTH(rx) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 || LENGTH(rlower_tail) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int * px = INTEGER(rx); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int lower_tail = *LOGICAL(rlower_tail); int nres = LENGTH(rx); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double factor; // Scale factor double sum; // Used for summation double p; // Probability int x; // Temporary x int32 x1, x2; // Table limits int xmin, xmax; // Absolute limits for x int xmean; // Approximate mean of x int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // min and max xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CFishersNCHypergeometric fnc(n, m1, N, odds, prec); // Get necessary buffer length BufferLength = (int)fnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities factor = 1. / fnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Get mean xmean = (int)(fnc.mean() + 0.5); // Round mean // Check for consistency if (xmean < x1 || xmean > x2) { error("Inconsistency. mean = %i, lower limit = %i, upper limit = %i", xmean, x1, x2); } // Make left tail of table cumulative: for (x = x1, sum = 0; x <= xmean; x++) sum = buffer[x-x1] += sum; // Probabilities for x > xmean are calculated by summation from the // right in order to avoid loss of precision. // Make right tail of table cumulative from the right: for (x = x2, sum = 0; x > xmean; x--) sum = buffer[x-x1] += sum; // Loop through x vector for (i = 0; i < nres; i++) { x = px[i]; // Input x value if (x <= xmean) { // Left tail if (x < x1) { p = 0.; // Outside table } else { p = buffer[x-x1] * factor; // Probability from table } if (!lower_tail) p = 1. - p; // Invert if right tail presult[i] = p; // Store result } else { // Right tail if (x >= x2) { p = 0.; // Outside table } else { p = buffer[x-x1+1] * factor; // Probability from table } if (lower_tail) p = 1. - p; // Invert if left tail presult[i] = p; // Store result } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** pWNCHypergeo Cumulative distribution function for Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP pWNCHypergeo( SEXP rx, // Number of red balls drawn, scalar or vector SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rlower_tail // TRUE: P(X <= x), FALSE: P(X > x) ) { // Check for vectors if (LENGTH(rx) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 || LENGTH(rlower_tail) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int * px = INTEGER(rx); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int lower_tail = *LOGICAL(rlower_tail); int nres = LENGTH(rx); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double sum; // Used for summation double p; // Probability int x; // Temporary x int32 x1, x2; // Table limits int xmin, xmax; // Absolute limits for x int xmean; // Approximate mean of x int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // min and max xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CWalleniusNCHypergeometric wnc(n, m1, N, odds, prec); // Get necessary buffer length BufferLength = wnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities wnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Get mean xmean = (int)(wnc.mean() + 0.5); // Round mean // Check for consistency if (xmean < x1 || xmean > x2) { error("Inconsistency. mean = %i, lower limit = %i, upper limit = %i", xmean, x1, x2); } // Make left tail of table cumulative: for (x = x1, sum = 0; x <= xmean; x++) sum = buffer[x-x1] += sum; // Probabilities for x > xmean are calculated by summation from the // right in order to avoid loss of precision. // Make right tail of table cumulative from the right: for (x = x2, sum = 0; x > xmean; x--) sum = buffer[x-x1] += sum; // Loop through x vector for (i = 0; i < nres; i++) { x = px[i]; // Input x value if (x <= xmean) { // Left tail if (x < x1) { p = 0.; // Outside table } else { p = buffer[x-x1]; // Probability from table } if (!lower_tail) p = 1. - p; // Invert if right tail presult[i] = p; // Store result } else { // Right tail if (x >= x2) { p = 0.; // Outside table } else { p = buffer[x-x1+1]; // Probability from table } if (lower_tail) p = 1. - p; // Invert if left tail presult[i] = p; // Store result } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** qFNCHypergeo Quantile function for Fisher's NonCentral Hypergeometric distribution. Returns the lowest x for which P(X<=x) >= p when lower.tail = TRUE Returns the lowest x for which P(X >x) <= p when lower.tail = FALSE ******************************************************************************/ REXPORTS SEXP qFNCHypergeo( SEXP rp, // Cumulative probability SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rlower_tail // TRUE: P(X <= x), FALSE: P(X > x) ) { // Check for vectors if (LENGTH(rp) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 || LENGTH(rlower_tail) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double* pp = REAL(rp); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int lower_tail = *LOGICAL(rlower_tail); int nres = LENGTH(rp); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double factor; // Scale factor double sum; // Used for summation double p; // Probability int x; // Temporary x int32 x1, x2; // Table limits int i; // Loop counter unsigned int a, b, c; // Used in binary search // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, nres)); presult = INTEGER(result); // Make object for calculating probabilities CFishersNCHypergeometric fnc(n, m1, N, odds, prec); // Get necessary buffer length BufferLength = (int)fnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities factor = fnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Make table cumulative: for (x = x1, sum = 0; x <= x2; x++) sum = buffer[x-x1] += sum; // Loop through p vector for (i = 0; i < nres; i++) { p = pp[i]; // Input p value if (!R_FINITE(p) || p < 0. || p > 1.) { presult[i] = NA_INTEGER; // Invalid input. Return NA } else { if (!lower_tail) p = 1. - p; // Invert if right tail p *= factor; // Table is scaled by factor // Binary search in table a = 0; b = x2 - x1 + 1; while (a < b) { c = (a + b) / 2; if (p <= buffer[c]) { b = c; } else { a = c + 1; } } x = x1 + a; if (x > x2) x = x2; // Prevent values > xmax that occur because of small imprecisions presult[i] = x; } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** qWNCHypergeo Quantile function for Wallenius' NonCentral Hypergeometric distribution. Returns the lowest x for which P(X<=x) >= p when lower.tail = TRUE Returns the lowest x for which P(X >x) <= p when lower.tail = FALSE ******************************************************************************/ REXPORTS SEXP qWNCHypergeo( SEXP rp, // Cumulative probability SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rlower_tail // TRUE: P(X <= x), FALSE: P(X > x) ) { // Check for vectors if (LENGTH(rp) < 0 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 || LENGTH(rlower_tail) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double* pp = REAL(rp); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int lower_tail = *LOGICAL(rlower_tail); int nres = LENGTH(rp); // Number of probability values to return int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double sum; // Used for summation double p; // Probability int x; // Temporary x int32 x1, x2; // Table limits int i; // Loop counter unsigned int a, b, c; // Used in binary search // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, nres)); presult = INTEGER(result); // Make object for calculating probabilities CWalleniusNCHypergeometric wnc(n, m1, N, odds, prec); // Get necessary buffer length BufferLength = wnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities wnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Make table cumulative: for (x = x1, sum = 0; x <= x2; x++) sum = buffer[x-x1] += sum; // Loop through p vector for (i = 0; i < nres; i++) { p = pp[i]; // Input p value if (!R_FINITE(p) || p < 0. || p > 1.) { presult[i] = NA_INTEGER; // Invalid input. Return NA } else { if (!lower_tail) p = 1. - p; // Invert if right tail // Binary search in table a = 0; b = x2 - x1 + 1; while (a < b) { c = (a + b) / 2; if (p <= buffer[c]) { b = c; } else { a = c + 1; } } x = x1 + a; if (x > x2) x = x2; // Prevent values > xmax that occur because of small imprecisions presult[i] = x; } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** rFNCHypergeo Random variate generation function for Fisher's NonCentral Hypergeometric distribution. ******************************************************************************/ REXPORTS SEXP rFNCHypergeo( SEXP rnran, // Number of random variates desired SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rnran) != 1 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int nran = *INTEGER(rnran); if (LENGTH(rnran) > 1) nran = LENGTH(rnran); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double sum; // Used for summation double u; // Uniform random number int x; // Temporary x int32 x1, x2; // Table limits unsigned int a, b, c; // Used in binary search int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if (nran <= 0) error("Parameter nran must be positive"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, nran)); presult = INTEGER(result); // Make object for generating variates StochasticLib3 sto(0); // Seed is not used sto.SetAccuracy(prec); // Set precision sto.InitRan(); // Initialize RNG in R.dll if (nran > 4) { // Check necessary table length CFishersNCHypergeometric fnc(n, m1, N, odds, prec); BufferLength = (int)fnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); if (BufferLength / 2 < nran) { // It is advantageous to make a table // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities fnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Make table cumulative: for (x = x1, sum = 0; x <= x2; x++) sum = buffer[x-x1] += sum; // Loop for each variate for (i = 0; i < nran; i++) { // Make uniform random u = sto.Random() * sum; // Binary search in table a = 0; b = x2 - x1 + 1; while (a < b) { c = (a + b) / 2; if (u < buffer[c]) { b = c; } else { a = c + 1; } } x = x1 + a; if (x > x2) x = x2; // Prevent values > xmax that occur because of small imprecisions presult[i] = x; } goto FINISHED_R; } } // Not using table. // Generate variates one by one for (i = 0; i < nran; i++) { presult[i] = sto.FishersNCHyp(n, m1, N, odds); } FINISHED_R: sto.EndRan(); // Return RNG state to R.dll // Return result UNPROTECT(1); return(result); } /****************************************************************************** rWNCHypergeo Random variate generation function for Wallenius' NonCentral Hypergeometric distribution. ******************************************************************************/ REXPORTS SEXP rWNCHypergeo( SEXP rnran, // Number of random variates desired SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rnran) != 1 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int nran = *INTEGER(rnran); if (LENGTH(rnran) > 1) nran = LENGTH(rnran); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int N = m1 + m2; // Total number of balls double* buffer = 0; // Table of probabilities int BufferLength; // Length of table double sum; // Used for summation double u; // Uniform random number int x; // Temporary x int32 x1, x2; // Table limits unsigned int a, b, c; // Used in binary search int i; // Loop counter // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if (nran <= 0) error("Parameter nran must be positive"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, nran)); presult = INTEGER(result); // Make object for generating variates StochasticLib3 sto(0); // Seed is not used sto.SetAccuracy(prec); // Set precision sto.InitRan(); // Initialize RNG in R.dll if (nran > 4) { // Check necessary table length CWalleniusNCHypergeometric wnc(n, m1, N, odds, prec); BufferLength = (int)wnc.MakeTable(buffer, 0, &x1, &x2, prec * 0.001); if (BufferLength / 2 < nran) { // It is advantageous to make a table // Allocate buffer buffer = (double*)R_alloc(BufferLength, sizeof(double)); // Make table of probabilities wnc.MakeTable(buffer, BufferLength, &x1, &x2, prec * 0.001); // Make table cumulative: for (x = x1, sum = 0; x <= x2; x++) sum = buffer[x-x1] += sum; // Loop for each variate for (i = 0; i < nran; i++) { // Make uniform random u = sto.Random() * sum; // sum should be 1.0 but might be slightly less if tails are cut off in table // Binary search in table a = 0; b = x2 - x1 + 1; while (a < b) { c = (a + b) / 2; if (u < buffer[c]) { b = c; } else { a = c + 1; } } x = x1 + a; if (x > x2) x = x2; // Prevent values > xmax that occur because of small imprecisions presult[i] = x; } goto FINISHED_R; } } // Not using table. // Generate variates one by one for (i = 0; i < nran; i++) { presult[i] = sto.WalleniusNCHyp(n, m1, N, odds); } FINISHED_R: sto.EndRan(); // Return RNG state to R.dll // Return result UNPROTECT(1); return(result); } /****************************************************************************** momentsFNCHypergeo Calculates the mean or variance of Fisher's NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses simple approximations when precision >= 0.1. // Uses calculation by enumeration of all non-negligible x values when // precision < 0.1. // Note that several other approximations have been proposed in the literature. // See e.g.: // Levin, B. Biometrika, vol. 71, no. 3, 1984, pp. 630-632. // Liao, J. Biometrics, vol. 48, no. 3, 1992, pp. 889-892. // McCullagh, P. & Nelder, J.A.: Generalized Linear Models, 2'nd ed., 1989. REXPORTS SEXP momentsFNCHypergeo( SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rmoment // 1 = mean, 2 = variance ) { // Check for vectors if (LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int imoment = *INTEGER(rmoment); int N = m1 + m2; // Total number of balls // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (imoment != 1 && imoment != 2) error ("Only moments 1 and 2 supported"); if (!R_FINITE(prec) || prec < 0) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, 1)); presult = REAL(result); // Make object for calculating mean and variance CFishersNCHypergeometric fnc(n, m1, N, odds, prec); // Check precision if (prec >= 0.1) { // Simple approximation allowed if (imoment == 1) { *presult = fnc.mean(); } else { *presult = fnc.variance(); } } else { // Exact calculation required // Values saved from last calculation: static int old_m1 = 0; static int old_m2 = 0; static int old_n = 0; static double old_odds = 0; static double old_prec = 0; static double old_mean = 0; static double old_var = 0; if (m1 != old_m1 || m2 != old_m2 || n != old_n || odds != old_odds || prec < old_prec) { // Parameters have changed. Cannot reuse results. // Calculate mean and variance. // We are calculating both mean and variance in the same // process. The values are stored for the next call in case // both mean and variance are requested fnc.moments(&old_mean, &old_var); // Store parameters for possible reuse in next call old_m1 = m1; old_m2 = m2; old_n = n; old_odds = odds; old_prec = prec; } if (imoment == 1) { // Return mean *presult = old_mean; } else { // Return variance *presult = old_var; } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** momentsWNCHypergeo Calculates the mean or variance of Wallenius' NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses simple approximations when precision >= 0.1. // Uses calculation by enumeration of all non-negligible x values when // precision < 0.1. REXPORTS SEXP momentsWNCHypergeo( SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision, // Precision of calculation SEXP rmoment // 1 = mean, 2 = variance ) { // Check for vectors if (LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int imoment = *INTEGER(rmoment); int N = m1 + m2; // Total number of balls // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (imoment != 1 && imoment != 2) error ("Only moments 1 and 2 supported"); if (!R_FINITE(prec) || prec < 0) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, 1)); presult = REAL(result); // Make object for calculating mean and variance CWalleniusNCHypergeometric wnc(n, m1, N, odds, prec); // Check precision if (prec >= 0.1) { // Simple approximation allowed if (imoment == 1) { *presult = wnc.mean(); } else { *presult = wnc.variance(); } } else { // Exact calculation required // Values saved from last calculation: static int old_m1 = 0; static int old_m2 = 0; static int old_n = 0; static double old_odds = 0; static double old_prec = 0; static double old_mean = 0; static double old_var = 0; if (m1 != old_m1 || m2 != old_m2 || n != old_n || odds != old_odds || prec < old_prec) { // Parameters have changed. Cannot reuse results. // Calculate mean and variance. // We are calculating both mean and variance in the same // process. The values are stored for the next call in case // both mean and variance are requested wnc.moments(&old_mean, &old_var); // Store parameters for possible reuse in next call old_m1 = m1; old_m2 = m2; old_n = n; old_odds = odds; old_prec = prec; } if (imoment == 1) { // Return mean *presult = old_mean; } else { // Return variance *presult = old_var; } } // Return result UNPROTECT(1); return(result); } /****************************************************************************** modeFNCHypergeo Calculates the mode of Fisher's NonCentral Hypergeometric distribution. ******************************************************************************/ REXPORTS SEXP modeFNCHypergeo( SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds // Odds of getting a red ball among one red and one white ) { // Check for vectors if (LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); int N = m1 + m2; // Total number of balls // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, 1)); presult = INTEGER(result); // Calculate mode *presult = CFishersNCHypergeometric(n, m1, N, odds).mode(); // Return result UNPROTECT(1); return(result); } /****************************************************************************** modeWNCHypergeo Calculates the mode of Wallenius' NonCentral Hypergeometric distribution. ******************************************************************************/ REXPORTS SEXP modeWNCHypergeo( SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double odds = *REAL(rodds); double prec = *REAL(rprecision); int N = m1 + m2; // Total number of balls // Check validity of parameters if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (n > m2 && odds == 0) error ("Not enough items with nonzero weight"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; int * presult; PROTECT(result = allocVector(INTSXP, 1)); presult = INTEGER(result); // Calculate mode *presult = CWalleniusNCHypergeometric(n, m1, N, odds, prec).mode(); // Return result UNPROTECT(1); return(result); } /****************************************************************************** oddsFNCHypergeo Estimate odds ratio from mean for Fisher's NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses Cornfield's approximation. precision is ignored. REXPORTS SEXP oddsFNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rmu) < 1 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double *pmu = REAL(rmu); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double prec = *REAL(rprecision); int nres = LENGTH(rmu); int N = m1 + m2; // Total number of balls int i; // Loop counter int err = 0; // Remember any error // Check validity of parameters if (nres < 0) error("mu has wrong length"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.05) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Get xmin and xmax int xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x int xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Loop for all mu inputs for (i = 0; i < nres; i++) { double mu = pmu[i]; // Check limits if (xmin == xmax) { presult[i] = R_NaN; err |= 1; // Indetermined continue; } if (mu <= double(xmin)) { if (mu == double(xmin)) { presult[i] = 0.; err |= 2; // Zero continue; } presult[i] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(xmax)) { if (mu == double(xmax)) { presult[i] = R_PosInf; err |= 4; // Infinite continue; } presult[i] = R_NaN; err |= 8; // Out of range continue; } // Calculate odds ratio presult[i] = mu * (m2 - n + mu) / ((m1 - mu)*(n - mu)); } // Check for errors if (err & 8) error("mu out of range"); else if (err & 1) warning("odds is indetermined"); else { if (err & 4) warning("odds is infinite"); if (err & 2) warning("odds is zero with no precision"); } // Return result UNPROTECT(1); return(result); } /****************************************************************************** oddsWNCHypergeo Estimate odds ratio from mean for Wallenius' NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses Manly's approximation. precision is ignored. REXPORTS SEXP oddsWNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rm1, // Number of red balls in urn SEXP rm2, // Number of white balls in urn SEXP rn, // Number of balls drawn from urn SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rmu) < 1 || LENGTH(rm1) != 1 || LENGTH(rm2) != 1 || LENGTH(rn) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double *pmu = REAL(rmu); int m1 = *INTEGER(rm1); int m2 = *INTEGER(rm2); int n = *INTEGER(rn); double prec = *REAL(rprecision); int nres = LENGTH(rmu); int N = m1 + m2; // Total number of balls int i; // Loop counter int err = 0; // Remember any error // Check validity of parameters if (nres < 0) error("mu has wrong length"); if (m1 < 0 || m2 < 0 || n < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > m1 + m2: Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.02) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Get xmin and xmax int xmin = m1 + n - N; if (xmin < 0) xmin = 0; // Minimum x int xmax = n; if (xmax > m1) xmax = m1; // Maximum x // Loop for all mu inputs for (i = 0; i < nres; i++) { double mu = pmu[i]; // Check limits if (xmin == xmax) { presult[i] = R_NaN; err |= 1; // Indetermined continue; } if (mu <= double(xmin)) { if (mu == double(xmin)) { presult[i] = 0.; err |= 2; // Zero continue; } presult[i] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(xmax)) { if (mu == double(xmax)) { presult[i] = R_PosInf; err |= 4; // Infinite continue; } presult[i] = R_NaN; err |= 8; // Out of range continue; } // Calculate odds ratio presult[i] = log(1. - mu / m1) / log(1. - (n-mu)/m2); } // Check for errors if (err & 8) error("mu out of range"); else if (err & 1) warning("odds is indetermined"); else { if (err & 4) warning("odds is infinite"); if (err & 2) warning("odds is zero with no precision"); } // Return result UNPROTECT(1); return(result); } /****************************************************************************** numWNCHypergeo Estimate number of balls of each color from experimental mean for Wallenius' NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses Manly's approximation. Precision is ignored. /* Calculation method: Manly's approximate equation for the mean is transformed to: log(1-mu1/m1) = omega*(log(1-mu2/(N-m1)) This equation is solved by Newton-Raphson iteration */ REXPORTS SEXP numWNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rn, // Number of balls drawn from urn SEXP rN, // Number of balls in urn before sampling SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rmu) < 1 || LENGTH(rn) != 1 || LENGTH(rN) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double *pmu = REAL(rmu); int n = *INTEGER(rn); int N = *INTEGER(rN); double odds = *REAL(rodds); double prec = *REAL(rprecision); int nres = LENGTH(rmu); int i; // Loop counter int err = 0; // Remember any error // Check validity of parameters if (nres < 0) error("mu has wrong length"); if (n < 0 || N < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > N: Taking more items than there are"); if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.02) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, 2)); } else { PROTECT(result = allocMatrix(REALSXP, 2, nres)); } presult = REAL(result); // Loop for all mu inputs for (i = 0; i < nres; i++, presult += 2) { double mu = pmu[i]; // Check limits if (n == 0) { presult[0] = presult[1] = R_NaN; err |= 1; // Indetermined continue; } if (odds == 0.) { presult[0] = presult[1] = R_NaN; if (mu == 0.) err |= 1; // Indetermined else err |= 0x10; // Out of range continue; } if (n == N) { // Known exactly presult[0] = mu; presult[1] = N - mu; continue; } if (mu <= 0.) { if (mu == 0.) { presult[0] = 0; presult[1] = N; err |= 2; // Zero continue; } presult[0] = presult[1] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(n)) { if (mu == double(n)) { presult[0] = N; presult[1] = 0; err |= 4; // Infinite continue; } presult[0] = presult[1] = R_NaN; err |= 8; // Out of range continue; } // Calculate m1 double z, zd, m1, m2, lastm1, mu2 = n - mu; // Initial guess m1 = N * mu / n; m2 = N - m1; int niter = 0; // Newton Raphson iteration do { lastm1 = m1; z = log(1. - mu/m1) - odds*log(1. - mu2/m2); zd = mu/(m1*(m1-mu)) + odds*mu2/(m2*(m2-mu2)); m1 -= z / zd; if (m1 <= mu) { // out of range m1 = (lastm1 + mu) * 0.5; } m2 = N - m1; if (m2 <= mu2) { // out of range m2 = (N - lastm1 + mu2) * 0.5; m1 = N - m2; } if (++niter > 200) error ("Convergence problem"); } while (fabs(m1-lastm1) > N * 1E-10); presult[0] = m1; presult[1] = N - m1; } // Check for errors if (err & 0x08) error("mu out of range"); else { if (err & 0x10) warning("Zero odds conflicts with nonzero mean"); if (err & 1) warning("odds is indetermined"); } //else if (err & 6) warning("result is independent of odds"); // Return result UNPROTECT(1); return(result); } /****************************************************************************** numFNCHypergeo Estimate number of balls of each color from experimental mean for Fisher's NonCentral Hypergeometric distribution. ******************************************************************************/ // Uses Cornfield's approximation. Precision is ignored. REXPORTS SEXP numFNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rn, // Number of balls drawn from urn SEXP rN, // Number of balls in urn before sampling SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { // Check for vectors if (LENGTH(rmu) < 1 || LENGTH(rn) != 1 || LENGTH(rN) != 1 || LENGTH(rodds) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Get parameter values double *pmu = REAL(rmu); int n = *INTEGER(rn); int N = *INTEGER(rN); double odds = *REAL(rodds); double prec = *REAL(rprecision); int nres = LENGTH(rmu); int i; // Loop counter int err = 0; // Remember any error // Check validity of parameters if (nres < 0) error("mu has wrong length"); if (n < 0 || N < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > N: Taking more items than there are"); if (!R_FINITE(odds) || odds < 0) error("Invalid value for odds"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.02) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, 2)); } else { PROTECT(result = allocMatrix(REALSXP, 2, nres)); } presult = REAL(result); // Loop for all mu inputs for (i = 0; i < nres; i++, presult += 2) { double mu = pmu[i]; // Check limits if (n == 0) { presult[0] = presult[1] = R_NaN; err |= 1; // Indetermined continue; } if (odds == 0.) { presult[0] = presult[1] = R_NaN; if (mu == 0.) err |= 1; // Indetermined else err |= 0x10; // Out of range continue; } if (n == N) { // Known exactly presult[0] = mu; presult[1] = N - mu; continue; } if (mu <= 0.) { if (mu == 0.) { presult[0] = 0; presult[1] = N; err |= 2; // Zero continue; } presult[0] = presult[1] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(n)) { if (mu == double(n)) { presult[0] = N; presult[1] = 0; err |= 4; // Infinite continue; } presult[0] = presult[1] = R_NaN; err |= 8; // Out of range continue; } // Calculate m1 double mu2 = n - mu, mu_o = mu / odds;; double m1 = (mu_o*(N-mu2) + mu*mu2) / (mu_o + mu2); presult[0] = m1; presult[1] = N - m1; } // Check for errors if (err & 0x08) error("mu out of range"); else { if (err & 0x10) warning("Zero odds conflicts with nonzero mean"); if (err & 1) warning("odds is indetermined"); } //else if (err & 6) warning("result is independent of odds"); // Return result UNPROTECT(1); return(result); } /*********************************************************************** DllMain ***********************************************************************/ // Define entry point DllMain if Windows and not Gnu compiler #if defined (_WIN32) && ! defined (__GNUC__) extern "C" __declspec(dllexport) int __stdcall DllMain(int, int, void*) { return 1; } #endif BiasedUrn/src/stocc.h0000644000176200001440000006361512640160171014212 0ustar liggesusers/***************************** stocc.h ********************************** * Author: Agner Fog * Date created: 2004-01-08 * Last modified: 2011-08-05 * Project: randomc.h * Source URL: www.agner.org/random * * Description: * This file contains function prototypes and class declarations for the C++ * library of non-uniform random number generators. Most functions are fast and * accurate, even for extreme values of the parameters. * * * functions without classes: * ========================== * * void EndOfProgram(void); * System-specific exit code. You may modify this to make it fit your * user interface. * * void FatalError(const char * ErrorText); * Used for outputting error messages from the other functions and classes. * You may have to modify this function to make it fit your user interface. * * double Erf (double x); * Calculates the error function, which is the integral of the normal distribution. * * double LnFac(int32 n); * Calculates the natural logarithm of the factorial of n. * * * class StochasticLib1: * ==================== * This class can be derived from any of the uniform random number generators * defined in randomc.h. StochasticLib1 provides the following non-uniform random * variate generators: * * int Bernoulli(double p); * Bernoulli distribution. Gives 0 or 1 with probability 1-p and p. * * double Normal(double m, double s); * Normal distribution with mean m and standard deviation s. * * int32 Poisson (double L); * Poisson distribution with mean L. * * int32 Binomial (int32 n, double p); * Binomial distribution. n trials with probability p. * * int32 Hypergeometric (int32 n, int32 m, int32 N); * Hypergeometric distribution. Taking n items out N, m of which are colored. * * void Multinomial (int32 * destination, double * source, int32 n, int colors); * void Multinomial (int32 * destination, int32 * source, int32 n, int colors); * Multivariate binomial distribution. * * void MultiHypergeometric (int32 * destination, int32 * source, int32 n, int colors); * Multivariate hypergeometric distribution. * * void Shuffle(int * list, int min, int n); * Shuffle a list of integers. * * * class StochasticLib2: * ===================== * This class is derived from class StochasticLib1. It redefines the functions * Poisson, Binomial and HyperGeometric. * In StochasticLib1, these functions are optimized for being called with * parameters that vary. In StochasticLib2, the same functions are optimized * for being called repeatedly with the same parameters. If your parameters * seldom vary, then StochasticLib2 is faster. The two classes use different * calculation methods, both of which are accurate. * * * class StochasticLib3: * ===================== * This class can be derived from either StochasticLib1 or StochasticLib2, * whichever is preferred. It contains functions for generating variates with * the univariate and multivariate Wallenius' and Fisher's noncentral * hypergeometric distributions. * * int32 WalleniusNCHyp (int32 n, int32 m, int32 N, double odds); * Sampling from Wallenius' noncentral hypergeometric distribution, which is * what you get when taking n items out N, m of which are colored, without * replacement, with bias. * * int32 FishersNCHyp (int32 n, int32 m, int32 N, double odds); * Sampling from Fisher's noncentral hypergeometric distribution which is the * conditional distribution of independent binomial variates given their sum n. * * void MultiWalleniusNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors); * Sampling from multivariate Wallenius' noncentral hypergeometric distribution. * * void MultiFishersNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors); * Sampling from multivariate Fisher's noncentral hypergeometric distribution. * * * Uniform random number generators (integer and float) are also available, as * these are inherited from the random number generator class that is the base * class of StochasticLib1. * * * class CWalleniusNCHypergeometric * ================================ * This class implements various methods for calculating the probability * function and the mean and variance of the univariate Wallenius' noncentral * hypergeometric distribution. It is used by StochasticLib3 and can also be * used independently. * * * class CMultiWalleniusNCHypergeometric * ===================================== * This class implements various methods for calculating the probability func- * tion and the mean of the multivariate Wallenius' noncentral hypergeometric * distribution. It is used by StochasticLib3 and can also be used independently. * * * class CMultiWalleniusNCHypergeometricMoments * ============================================ * This class calculates the exact mean and variance of the multivariate * Wallenius' noncentral hypergeometric probability distribution. * * * class CFishersNCHypergeometric * ============================== * This class calculates the probability function and the mean and variance * of Fisher's noncentral hypergeometric distribution. * * * class CMultiFishersNCHypergeometric * =================================== * This class calculates the probability function and the mean and variance * of the multivariate Fisher's noncentral hypergeometric distribution. * * * source code: * ============ * The code for EndOfProgram and FatalError is found in the file userintf.cpp. * The code for the functions in StochasticLib1 is found in the file stoc1.cpp. * The code for the functions in StochasticLib2 is found in the file stoc2.cpp. * The code for the functions in StochasticLib3 is found in the file stoc3.cpp. * The code for the functions in CWalleniusNCHypergeometric, * CMultiWalleniusNCHypergeometric and CMultiWalleniusNCHypergeometricMoments * is found in the file wnchyppr.cpp. * The code for the functions in CFishersNCHypergeometric and * CMultiFishersNCHypergeometric is found in the file fnchyppr.cpp * LnFac is found in stoc1.cpp. * Erf is found in wnchyppr.cpp. * * * Examples: * ========= * The file ex-stoc.cpp contains an example of how to use this class library. * * The file ex-cards.cpp contains an example of how to shuffle a list of items. * * The file ex-lotto.cpp contains an example of how to generate a sequence of * random integers where no number can occur more than once. * * The file testbino.cpp contains an example of sampling from the binomial distribution. * * The file testhype.cpp contains an example of sampling from the hypergeometric distribution. * * The file testpois.cpp contains an example of sampling from the poisson distribution. * * The file testwnch.cpp contains an example of sampling from Wallenius noncentral hypergeometric distribution. * * The file testfnch.cpp contains an example of sampling from Fisher's noncentral hypergeometric distribution. * * The file testmwnc.cpp contains an example of sampling from the multivariate Wallenius noncentral hypergeometric distribution. * * The file testmfnc.cpp contains an example of sampling from the multivariate Fisher's noncentral hypergeometric distribution. * * The file evolc.zip contains examples of how to simulate biological evolution using this class library. * * * Documentation: * ============== * The file stocc.htm contains further instructions. * * The file distrib.pdf contains definitions of the standard statistic distributions: * Bernoulli, Normal, Poisson, Binomial, Hypergeometric, Multinomial, MultiHypergeometric. * * The file sampmet.pdf contains theoretical descriptions of the methods used * for sampling from these distributions. * * The file nchyp.pdf, available from www.agner.org/random/, contains * definitions of the univariate and multivariate Wallenius and Fisher's * noncentral hypergeometric distributions and theoretical explanations of * the methods for calculating and sampling from these. * * 2002-2011 Agner Fog. GNU General Public License www.gnu.org/copyleft/gpl.html *******************************************************************************/ #ifndef STOCC_H #define STOCC_H #include "randomc.h" #ifdef R_BUILD #include "stocR.h" // Include this when building R-language interface #endif /*********************************************************************** Choose which uniform random number generator to base these classes on ***********************************************************************/ // STOC_BASE defines which base class to use for the non-uniform // random number generator classes StochasticLib1, 2, and 3. #ifndef STOC_BASE #ifdef R_BUILD // Inherit from StocRBase when building for R-language interface #define STOC_BASE StocRBase #else #define STOC_BASE TRandomMersenne // Or choose any other random number generator base class: //#define STOC_BASE TRanrotWGenerator //#define STOC_BASE TRandomMotherOfAll #endif #endif /*********************************************************************** Other simple functions ***********************************************************************/ double LnFac(int32 n); // log factorial (stoc1.cpp) double LnFacr(double x); // log factorial of non-integer (wnchyppr.cpp) double FallingFactorial(double a, double b); // Falling factorial (wnchyppr.cpp) double Erf (double x); // error function (wnchyppr.cpp) int32 FloorLog2(float x); // floor(log2(x)) for x > 0 (wnchyppr.cpp) int NumSD (double accuracy); // used internally for determining summation interval /*********************************************************************** Constants and tables ***********************************************************************/ // Maximum number of colors in the multivariate distributions #ifndef MAXCOLORS #define MAXCOLORS 32 // You may change this value #endif // constant for LnFac function: static const int FAK_LEN = 1024; // length of factorial table // The following tables are tables of residues of a certain expansion // of the error function. These tables are used in the Laplace method // for calculating Wallenius' noncentral hypergeometric distribution. // There are ERFRES_N tables covering desired precisions from // 2^(-ERFRES_B) to 2^(-ERFRES_E). Only the table that matches the // desired precision is used. The tables are defined in erfres.h which // is included in wnchyppr.cpp. // constants for ErfRes tables: static const int ERFRES_B = 16; // begin: -log2 of lowest precision static const int ERFRES_E = 40; // end: -log2 of highest precision static const int ERFRES_S = 2; // step size from begin to end static const int ERFRES_N = (ERFRES_E-ERFRES_B)/ERFRES_S+1; // number of tables static const int ERFRES_L = 48; // length of each table // tables of error function residues: extern "C" double ErfRes [ERFRES_N][ERFRES_L]; // number of std. deviations to include in integral to obtain desired precision: extern "C" double NumSDev[ERFRES_N]; /*********************************************************************** Class StochasticLib1 ***********************************************************************/ class StochasticLib1 : public STOC_BASE { // This class encapsulates the random variate generating functions. // May be derived from any of the random number generators. public: StochasticLib1 (int seed); // constructor int Bernoulli(double p); // bernoulli distribution #ifndef R_BUILD double Normal(double m, double s); // normal distribution #endif int32 Poisson (double L); // poisson distribution int32 Binomial (int32 n, double p); // binomial distribution int32 Hypergeometric (int32 n, int32 m, int32 N); // hypergeometric distribution void Multinomial (int32 * destination, double * source, int32 n, int colors); // multinomial distribution void Multinomial (int32 * destination, int32 * source, int32 n, int colors); // multinomial distribution void MultiHypergeometric (int32 * destination, int32 * source, int32 n, int colors); // multivariate hypergeometric distribution void Shuffle(int * list, int min, int n); // shuffle integers // functions used internally protected: static double fc_lnpk(int32 k, int32 N_Mn, int32 M, int32 n); // used by Hypergeometric // subfunctions for each approximation method int32 PoissonInver(double L); // poisson by inversion int32 PoissonRatioUniforms(double L); // poisson by ratio of uniforms int32 PoissonLow(double L); // poisson for extremely low L int32 BinomialInver (int32 n, double p); // binomial by inversion int32 BinomialRatioOfUniforms (int32 n, double p); // binomial by ratio of uniforms int32 HypInversionMod (int32 n, int32 M, int32 N); // hypergeometric by inversion searching from mode int32 HypRatioOfUnifoms (int32 n, int32 M, int32 N);// hypergeometric by ratio of uniforms method // variables used by Normal distribution double normal_x2; int normal_x2_valid; }; /*********************************************************************** Class StochasticLib2 ***********************************************************************/ class StochasticLib2 : public StochasticLib1 { // derived class, redefining some functions public: int32 Poisson (double L); // poisson distribution int32 Binomial (int32 n, double p); // binomial distribution int32 Hypergeometric (int32 n, int32 M, int32 N); // hypergeometric distribution StochasticLib2(int seed):StochasticLib1(seed){}; // constructor // subfunctions for each approximation method: protected: int32 PoissonModeSearch(double L); // poisson by search from mode int32 PoissonPatchwork(double L); // poisson by patchwork rejection static double PoissonF(int32 k, double l_nu, double c_pm); // used by PoissonPatchwork int32 BinomialModeSearch(int32 n, double p); // binomial by search from mode int32 BinomialPatchwork(int32 n, double p); // binomial by patchwork rejection double BinomialF(int32 k, int32 n, double l_pq, double c_pm); // used by BinomialPatchwork int32 HypPatchwork (int32 n, int32 M, int32 N); // hypergeometric by patchwork rejection }; /*********************************************************************** Class StochasticLib3 ***********************************************************************/ class StochasticLib3 : public StochasticLib1 { // This class can be derived from either StochasticLib1 or StochasticLib2. // Adds more probability distributions public: StochasticLib3(int seed); // constructor void SetAccuracy(double accur); // define accuracy of calculations int32 WalleniusNCHyp (int32 n, int32 m, int32 N, double odds); // Wallenius noncentral hypergeometric distribution int32 FishersNCHyp (int32 n, int32 m, int32 N, double odds); // Fisher's noncentral hypergeometric distribution void MultiWalleniusNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors); // multivariate Wallenius noncentral hypergeometric distribution void MultiComplWalleniusNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors); // multivariate complementary Wallenius noncentral hypergeometric distribution void MultiFishersNCHyp (int32 * destination, int32 * source, double * weights, int32 n, int colors); // multivariate Fisher's noncentral hypergeometric distribution // subfunctions for each approximation method protected: int32 WalleniusNCHypUrn (int32 n, int32 m, int32 N, double odds); // WalleniusNCHyp by urn model int32 WalleniusNCHypInversion (int32 n, int32 m, int32 N, double odds); // WalleniusNCHyp by inversion method int32 WalleniusNCHypTable (int32 n, int32 m, int32 N, double odds); // WalleniusNCHyp by table method int32 WalleniusNCHypRatioOfUnifoms (int32 n, int32 m, int32 N, double odds); // WalleniusNCHyp by ratio-of-uniforms int32 FishersNCHypInversion (int32 n, int32 m, int32 N, double odds); // FishersNCHyp by inversion int32 FishersNCHypRatioOfUnifoms (int32 n, int32 m, int32 N, double odds); // FishersNCHyp by ratio-of-uniforms // variables double accuracy; // desired accuracy of calculations }; /*********************************************************************** Class CWalleniusNCHypergeometric ***********************************************************************/ class CWalleniusNCHypergeometric { // This class contains methods for calculating the univariate // Wallenius' noncentral hypergeometric probability function public: CWalleniusNCHypergeometric(int32 n, int32 m, int32 N, double odds, double accuracy=1.E-8); // constructor void SetParameters(int32 n, int32 m, int32 N, double odds); // change parameters double probability(int32 x); // calculate probability function int32 MakeTable(double * table, int32 MaxLength, int32 * xfirst, int32 * xlast, double cutoff = 0.); // make table of probabilities double mean(void); // approximate mean double variance(void); // approximate variance (poor approximation) int32 mode(void); // calculate mode double moments(double * mean, double * var); // calculate exact mean and variance int BernouilliH(int32 x, double h, double rh, StochasticLib1 *sto); // used by rejection method // implementations of different calculation methods protected: double recursive(void); // recursive calculation double binoexpand(void); // binomial expansion of integrand double laplace(void); // Laplace's method with narrow integration interval double integrate(void); // numerical integration // other subfunctions double lnbico(void); // natural log of binomial coefficients void findpars(void); // calculate r, w, E double integrate_step(double a, double b); // used by integrate() double search_inflect(double t_from, double t_to); // used by integrate() // parameters double omega; // Odds int32 n, m, N, x; // Parameters int32 xmin, xmax; // Minimum and maximum x double accuracy; // Desired precision // parameters used by lnbico int32 xLastBico; double bico, mFac, xFac; // parameters generated by findpars and used by probability, laplace, integrate: double r, rd, w, wr, E, phi2d; int32 xLastFindpars; }; /*********************************************************************** Class CMultiWalleniusNCHypergeometric ***********************************************************************/ class CMultiWalleniusNCHypergeometric { // This class encapsulates the different methods for calculating the // multivariate Wallenius noncentral hypergeometric probability function public: CMultiWalleniusNCHypergeometric(int32 n, int32 * m, double * odds, int colors, double accuracy=1.E-8); // constructor void SetParameters(int32 n, int32 * m, double * odds, int colors); // change parameters double probability(int32 * x); // calculate probability function void mean(double * mu); // calculate approximate mean void variance(double * var, double * mean = 0); // calculate approximate variance and mean // implementations of different calculation methods protected: double binoexpand(void); // binomial expansion of integrand double laplace(void); // Laplace's method with narrow integration interval double integrate(void); // numerical integration // other subfunctions double lnbico(void); // natural log of binomial coefficients void findpars(void); // calculate r, w, E double integrate_step(double a, double b); // used by integrate() double search_inflect(double t_from, double t_to); // used by integrate() // parameters double * omega; double accuracy; int32 n, N; int32 * m, * x; int colors; int Dummy_align; // parameters generated by findpars and used by probability, laplace, integrate: double r, rd, w, wr, E, phi2d; // generated by lnbico double bico; }; /*********************************************************************** Class CMultiWalleniusNCHypergeometricMoments ***********************************************************************/ class CMultiWalleniusNCHypergeometricMoments: public CMultiWalleniusNCHypergeometric { // This class calculates the exact mean and variance of the multivariate // Wallenius noncentral hypergeometric distribution by calculating all the // possible x-combinations with probability < accuracy public: CMultiWalleniusNCHypergeometricMoments(int32 n, int32 * m, double * odds, int colors, double accuracy=1.E-8) : CMultiWalleniusNCHypergeometric(n, m, odds, colors, accuracy) {}; double moments(double * mean, double * var, int32 * combinations = 0); protected: // functions used internally double loop(int32 n, int c); // recursive loops // data int32 xi[MAXCOLORS]; // x vector to calculate probability of int32 xm[MAXCOLORS]; // rounded approximate mean of x[i] int32 remaining[MAXCOLORS]; // number of balls of color > c in urn double sx[MAXCOLORS]; // sum of x*f(x) double sxx[MAXCOLORS]; // sum of x^2*f(x) int32 sn; // number of combinations }; /*********************************************************************** Class CFishersNCHypergeometric ***********************************************************************/ class CFishersNCHypergeometric { // This class contains methods for calculating the univariate Fisher's // noncentral hypergeometric probability function public: CFishersNCHypergeometric(int32 n, int32 m, int32 N, double odds, double accuracy = 1E-8); // constructor double probability(int32 x); // calculate probability function double probabilityRatio(int32 x, int32 x0); // calculate probability f(x)/f(x0) double MakeTable(double * table, int32 MaxLength, int32 * xfirst, int32 * xlast, double cutoff = 0.); // make table of probabilities double mean(void); // calculate approximate mean double variance(void); // approximate variance int32 mode(void); // calculate mode (exact) double moments(double * mean, double * var); // calculate exact mean and variance protected: double lng(int32 x); // natural log of proportional function // parameters double odds; // odds ratio double logodds; // ln odds ratio double accuracy; // accuracy int32 n, m, N; // Parameters int32 xmin, xmax; // minimum and maximum of x // parameters used by subfunctions int32 xLast; double mFac, xFac; // log factorials double scale; // scale to apply to lng function double rsum; // reciprocal sum of proportional function int ParametersChanged; }; /*********************************************************************** Class CMultiFishersNCHypergeometric ***********************************************************************/ class CMultiFishersNCHypergeometric { // This class contains functions for calculating the multivariate // Fisher's noncentral hypergeometric probability function and its mean and // variance. Warning: the time consumption for first call to // probability or moments is proportional to the total number of // possible x combinations, which may be extreme! public: CMultiFishersNCHypergeometric(int32 n, int32 * m, double * odds, int colors, double accuracy = 1E-9); // constructor double probability(int32 * x); // calculate probability function void mean(double * mu); // calculate approximate mean void variance(double * var, double * mean = 0); // calculate approximate variance and mean double moments(double * mean, double * var, int32 * combinations = 0); // calculate exact mean and variance protected: void mean1(double * mu); // calculate approximate mean except for unused colors double lng(int32 * x); // natural log of proportional function void SumOfAll(void); // calculates sum of proportional function for all x combinations double loop(int32 n, int c); // recursive loops used by SumOfAll double odds[MAXCOLORS]; // copy of all nonzero odds double logodds[MAXCOLORS]; // log odds int32 m[MAXCOLORS]; // copy of all nonzero m int nonzero[MAXCOLORS]; // colors for which m and odds are not zero int32 n; // number of balls to take int32 N; // number of balls in urn int32 Nu; // number of balls in urn with nonzero weight int Colors; // number of colors int reduced; // bit 0: some colors have m=0 or odds=0. // bit 1: all nonzero odds are equal int usedcolors; // number of colors with m > 0 and odds > 0 double mFac; // sum of log m[i]! double scale; // scale to apply to lng function double rsum; // reciprocal sum of proportional function double accuracy; // accuracy of calculation // data used by used by SumOfAll int32 xi[MAXCOLORS]; // x vector to calculate probability of int32 xm[MAXCOLORS]; // rounded approximate mean of x[i] int32 remaining[MAXCOLORS]; // number of balls of color > c in urn double sx[MAXCOLORS]; // sum of x*f(x) or mean double sxx[MAXCOLORS]; // sum of x^2*f(x) or variance int32 sn; // number of possible combinations of x }; #endif BiasedUrn/src/erfres.h0000644000176200001440000004674512640160171014372 0ustar liggesusers/***************************** ERFRES.H ************************************** * Author: Agner Fog * Date created: 2004-07-10 * Last modified: 2008-12-12 * Project: stocc.zip * Source URL: www.agner.org/random * * Description: Table of residues of a certain expansion of the error function. These tables are used in the Laplace method for calculating Wallenius noncentral hypergeometric distribution. Used in CWalleniusNCHypergeometric::laplace() and CMultiWalleniusNCHypergeometric::laplace(). This file is generated by ERFRESMK.CPP. Please see the file ERFRESMK.CPP for a detailed description. You must re-run ERFRESMK.CPP if the constants in STOCC.H are changed. The following constants have been used for making the tables below: ERFRES_B = 16 (-log2 of lowest precision) ERFRES_E = 40 (-log2 of highest precision) ERFRES_S = 2 (step size from begin to end) ERFRES_N = 13 (number of tables) ERFRES_L = 48 (length of each table) * Copyright 2004-2008 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ //number of standard deviations to integrate double NumSDev[ERFRES_N] = { 4.324919041, 4.621231001, 4.900964208, 5.16657812, 5.419983175, 5.662697617, 5.895951217, 6.120756286, 6.337957755, 6.548269368, 6.752300431, 6.950575948, 7.143552034}; //tables of error function residues double ErfRes[ERFRES_N][ERFRES_L] = { // 0: precision 1.53E-05 {1.77242680540608204400E+00, 4.42974050453076994800E-01, 5.52683719287987914000E-02, 4.57346771067359261300E-03, 2.80459064155823224600E-04, 1.34636065677244878500E-05, 5.21352785817798300800E-07, 1.65832271688171705300E-08, 4.38865717471213472100E-10, 9.76518286165874680600E-12, 1.84433013221606645200E-13, 2.98319658966723379900E-15, 4.16751049288581722800E-17, 5.06844293411881381200E-19, 5.40629927341885830200E-21, 5.09268600245963099700E-23, 4.26365286677037947600E-25, 3.19120961809492396300E-27, 2.14691825888024309100E-29, 1.30473994083903636000E-31, 7.19567933922698314600E-34, 3.61655672748362805300E-36, 1.66299275803871018000E-38, 7.02143932105206679000E-41, 2.73122271211734530800E-43, 9.81824938600123102500E-46, 3.27125155121613401700E-48, 1.01290491600297417870E-50, 2.92208589554240568800E-53, 7.87247562929246970200E-56, 1.98510836143160618600E-58, 4.69476368999432417500E-61, 1.04339442450396263710E-63, 2.18317315734482557700E-66, 4.30811606197931495800E-69, 8.03081062303437395000E-72, 1.41637813978528824300E-74, 2.36693694351427741600E-77, 3.75309000199992425400E-80, 5.65409397708564003600E-83, 8.10322084538751956300E-86, 1.10610328893385430400E-88, 1.43971150303803736000E-91, 1.78884532267880002700E-94, 2.12393968173898899400E-97, 2.41222807417272408400E-100, 2.62311608532487946600E-103, 2.73362126618952541200E-106}, // 1: precision 3.81E-06 {1.77244708953065753100E+00, 4.43074113723358004800E-01, 5.53507546366094128100E-02, 4.60063583541917741200E-03, 2.85265530531727983900E-04, 1.39934570721569428400E-05, 5.61234181715130108200E-07, 1.87635216633109792000E-08, 5.29386567604284238200E-10, 1.27170893476994027400E-11, 2.62062404027629145800E-13, 4.66479837413316034000E-15, 7.22069968938298529400E-17, 9.78297384753513147400E-19, 1.16744590415498861200E-20, 1.23448081765041655900E-22, 1.16327347874717650400E-24, 9.82084801488552519700E-27, 7.46543820883360082800E-29, 5.13361419796185362400E-31, 3.20726459674397306300E-33, 1.82784782995019591600E-35, 9.53819678596992509200E-38, 4.57327699736894183000E-40, 2.02131302843758583500E-42, 8.26035836048709995200E-45, 3.13004443753993537100E-47, 1.10264466279388735400E-49, 3.62016356599029098800E-52, 1.11028768672354227000E-54, 3.18789098809699663200E-57, 8.58660896411902915800E-60, 2.17384332055877431800E-62, 5.18219413865915035000E-65, 1.16526530012222654600E-67, 2.47552943408735877700E-70, 4.97637013794934320200E-73, 9.47966949394160838200E-76, 1.71361124212171341900E-78, 2.94335699587741039100E-81, 4.80983789654609513600E-84, 7.48676877660738410200E-87, 1.11129798477201315100E-89, 1.57475145101473103400E-92, 2.13251069867015016100E-95, 2.76249093386952224300E-98, 3.42653604413897348900E-101, 4.07334940102519697800E-104}, // 2: precision 9.54E-07 {1.77245216056180140300E+00, 4.43102496776356791100E-01, 5.53772601883593673800E-02, 4.61054749828262358400E-03, 2.87253302758514987700E-04, 1.42417784632842086400E-05, 5.82408831964509309600E-07, 2.00745450404117050700E-08, 5.91011604093749423400E-10, 1.49916022838813094600E-11, 3.29741365965300606900E-13, 6.32307780683001018100E-15, 1.06252674842175897800E-16, 1.57257431560311360800E-18, 2.06034642322747725700E-20, 2.40159615347654528000E-22, 2.50271435589313449400E-24, 2.34271631492982176000E-26, 1.97869636045309031700E-28, 1.51440731538936707000E-30, 1.05452976534458622500E-32, 6.70612854853490875900E-35, 3.90863249061728208500E-37, 2.09490406980039604000E-39, 1.03572639732910843160E-41, 4.73737271771599553200E-44, 2.01016799853191990700E-46, 7.93316727009805559200E-49, 2.91896910080597410900E-51, 1.00361556207253403120E-53, 3.23138481735358914000E-56, 9.76266225260763484100E-59, 2.77288342251948021500E-61, 7.41751660051554639600E-64, 1.87191699537047863600E-66, 4.46389809367038823800E-69, 1.00740435367143552990E-71, 2.15468537440631290200E-74, 4.37372804933525238000E-77, 8.43676369508201162800E-80, 1.54845094802349484100E-82, 2.70727577941653793200E-85, 4.51412388960109772800E-88, 7.18605932463221426200E-91, 1.09328719452457957600E-93, 1.59123500193816486400E-96, 2.21770259794482485600E-99, 2.96235081914900644200E-102}, // 3: precision 2.38E-07 {1.77245342831958737100E+00, 4.43110438095780200600E-01, 5.53855581791170228000E-02, 4.61401880234106439000E-03, 2.88031928895194049600E-04, 1.43505456256023050800E-05, 5.92777558091362167400E-07, 2.07920891418090254000E-08, 6.28701715960960909000E-10, 1.65457546101845217200E-11, 3.81394501062348919800E-13, 7.73640169798996619200E-15, 1.38648618664047143200E-16, 2.20377376795474051600E-18, 3.11871105901085320300E-20, 3.94509797765438339700E-22, 4.47871054279593642800E-24, 4.58134444141001287500E-26, 4.23915369932833545200E-28, 3.56174643985755223000E-30, 2.72729562179570597400E-32, 1.90986605998546816600E-34, 1.22720072734085613700E-36, 7.25829034260272865500E-39, 3.96321699645874596800E-41, 2.00342049456074966200E-43, 9.40055798441764717800E-46, 4.10462275003981738400E-48, 1.67166813346582579800E-50, 6.36422340874443565900E-53, 2.26969100679582421400E-55, 7.59750937838053600600E-58, 2.39149482673471882600E-60, 7.09134153544718378800E-63, 1.98415128824311335000E-65, 5.24683837588056156800E-68, 1.31326161465641387500E-70, 3.11571024962460536800E-73, 7.01627137211411880000E-76, 1.50162731270605666400E-78, 3.05816530510335364700E-81, 5.93355048535012188600E-84, 1.09802441010335521600E-86, 1.94008240128183308800E-89, 3.27631821921541675800E-92, 5.29343480369738200400E-95, 8.19001419434114020600E-98, 1.21456436757992622700E-100}, // 4: precision 5.96E-08 {1.77245374525903386300E+00, 4.43112635580628681700E-01, 5.53880993417431935600E-02, 4.61519508177347361400E-03, 2.88323830371235781500E-04, 1.43956506488931199600E-05, 5.97533121516696046900E-07, 2.11560073234896927000E-08, 6.49836113541376862800E-10, 1.75091216044688314800E-11, 4.16782737060155846600E-13, 8.80643257335436424800E-15, 1.65748420791207225100E-16, 2.78707349086274968000E-18, 4.19899868515935354900E-20, 5.68498078698629510200E-22, 6.93816222596422139400E-24, 7.65747618996655475200E-26, 7.66779861336649418200E-28, 6.98905143723583695400E-30, 5.81737537190421990800E-32, 4.43568540037466870600E-34, 3.10768227888207447300E-36, 2.00640852664381818400E-38, 1.19706367104711013300E-40, 6.61729939738396217600E-43, 3.39784063694262711800E-45, 1.62450416252839296200E-47, 7.24798161653719932800E-50, 3.02428684730111423300E-52, 1.18255348374176440700E-54, 4.34156802253088795200E-57, 1.49931575039307549400E-59, 4.87879082698754128200E-62, 1.49836511723882777600E-64, 4.34998243416684050900E-67, 1.19554618884894856000E-69, 3.11506828608539767000E-72, 7.70504604851319512900E-75, 1.81153231245726529100E-77, 4.05332288179748454100E-80, 8.64127160751002389800E-83, 1.75723563299790750600E-85, 3.41217779987510142000E-88, 6.33324341504830543600E-91, 1.12470466360665277900E-93, 1.91282818505057981800E-96, 3.11838272111119088500E-99}, // 5: precision 1.49E-08 {1.77245382449389548700E+00, 4.43113238150016054000E-01, 5.53888635367372804600E-02, 4.61558298326459057200E-03, 2.88429374592283566800E-04, 1.44135302457832808700E-05, 5.99599530816354110000E-07, 2.13293263207088596800E-08, 6.60866899904610148200E-10, 1.80600922150303605400E-11, 4.38957621672449876700E-13, 9.54096365498724593600E-15, 1.86125270560486321400E-16, 3.26743200260750243300E-18, 5.17322947745786073000E-20, 7.40303709577309752000E-22, 9.59703297362487960100E-24, 1.12979041959758568400E-25, 1.21090586780714120800E-27, 1.18477600671972569200E-29, 1.06110784945102789800E-31, 8.72301430014194580800E-34, 6.59978694597213862400E-36, 4.60782503988683505400E-38, 2.97629996764696360400E-40, 1.78296967476668997800E-42, 9.92947813649120231300E-45, 5.15238281451496107200E-47, 2.49648080941516617600E-49, 1.13183145876711695200E-51, 4.81083885812771760200E-54, 1.92068525483444959800E-56, 7.21538203720691761200E-59, 2.55484244329461795400E-61, 8.54021947322263940200E-64, 2.69922457940407460300E-66, 8.07806757099831088400E-69, 2.29233505413233278200E-71, 6.17627451352383776600E-74, 1.58198519435517862400E-76, 3.85682833066898009900E-79, 8.96007783937447061800E-82, 1.98575880907873828900E-84, 4.20275001914011054200E-87, 8.50301055680340658200E-90, 1.64613519849643900900E-92, 3.05222294684008316300E-95, 5.42516704506242119200E-98}, // 6: precision 3.73E-09 {1.77245384430261089200E+00, 4.43113402125597019200E-01, 5.53890898808651020700E-02, 4.61570802060252211600E-03, 2.88466397094702578100E-04, 1.44203545983349722400E-05, 6.00457657669759309400E-07, 2.14076280553580130200E-08, 6.66287908992827087900E-10, 1.83546080772263722600E-11, 4.51849203153760888400E-13, 1.00053478654150626250E-14, 2.00133542358651377800E-16, 3.62647881190865840300E-18, 5.96489800325831839200E-20, 8.92069144951359438200E-22, 1.21499978844978062400E-23, 1.50969159775091919100E-25, 1.71458470816131592700E-27, 1.78354149193378771000E-29, 1.70298947555869630200E-31, 1.49600537831395400600E-33, 1.21186208172570666700E-35, 9.07362642179266008600E-38, 6.29382543478586469600E-40, 4.05352760000606626000E-42, 2.42933889358226154400E-44, 1.35768914148821438100E-46, 7.09017160688256911600E-49, 3.46664168532600651800E-51, 1.58991153690202909500E-53, 6.85218984466549798200E-56, 2.77986852228382907500E-58, 1.06333492956411188200E-60, 3.84102521375678317000E-63, 1.31221496031384552800E-65, 4.24584095965170648000E-68, 1.30291378525223696900E-70, 3.79687911940099574200E-73, 1.05205378465263412500E-75, 2.77502269989758744900E-78, 6.97601832816401403200E-81, 1.67315109709482392200E-83, 3.83268665565667928900E-86, 8.39358376033290752000E-89, 1.75907817494562062400E-91, 3.53115954806899335200E-94, 6.79562013989671425000E-97}, // 7: precision 9.31E-10 {1.77245384925478974400E+00, 4.43113446460012284000E-01, 5.53891560601252504200E-02, 4.61574755288994634700E-03, 2.88479053368568788400E-04, 1.44228769021976818600E-05, 6.00800544645992949800E-07, 2.14414502554089331400E-08, 6.68819005926294320800E-10, 1.85032367193584636900E-11, 4.58880445172944815400E-13, 1.02790650461108873560E-14, 2.09055796622121955200E-16, 3.87357904265687446300E-18, 6.55355746022352119400E-20, 1.01398465283490267200E-21, 1.43654532753298842400E-23, 1.86580454392148962200E-25, 2.22454554378132065200E-27, 2.43828788210971585600E-29, 2.46099438567553070000E-31, 2.29136593939231572900E-33, 1.97178483051357608300E-35, 1.57129911859150760300E-37, 1.16187715309016251400E-39, 7.98791034830625946600E-42, 5.11610271388176540200E-44, 3.05861085454619325800E-46, 1.71006575230074253400E-48, 8.95787473757552059200E-51, 4.40426750636187741200E-53, 2.03593329808165663200E-55, 8.86319619094250260800E-58, 3.63949556302483252000E-60, 1.41180525527432472100E-62, 5.18110448656726197600E-65, 1.80130976146235507900E-67, 5.94089489436009998000E-70, 1.86108901096460881000E-72, 5.54453617603266634800E-75, 1.57273231131712670500E-77, 4.25229555550383344000E-80, 1.09708064410784368000E-82, 2.70363777400980301400E-85, 6.37064773173804957600E-88, 1.43666982549400138800E-90, 3.10359876850474266200E-93, 6.42822304267944541900E-96}, // 8: precision 2.33E-10 {1.77245385049283445600E+00, 4.43113458380306853400E-01, 5.53891751960330686200E-02, 4.61575984524613369300E-03, 2.88483285115404915700E-04, 1.44237837119469849000E-05, 6.00933085215778545800E-07, 2.14555059613473259000E-08, 6.69949807134525424700E-10, 1.85746173246056176400E-11, 4.62510251141501895600E-13, 1.04309449728125451550E-14, 2.14376794695367282400E-16, 4.03195345507914206800E-18, 6.95901230873262760600E-20, 1.10422005968960415700E-21, 1.61274044622451622200E-23, 2.17010646570190394600E-25, 2.69272585719737993500E-27, 3.08406442023150341400E-29, 3.26412756902204044100E-31, 3.19659762892894327800E-33, 2.90079234489442113000E-35, 2.44307440922101839900E-37, 1.91280099578638699700E-39, 1.39463784147443818800E-41, 9.48568383329895892700E-44, 6.02906080392955580400E-46, 3.58720420688290561300E-48, 2.00136767763554841800E-50, 1.04877885428425423540E-52, 5.17045929753308956200E-55, 2.40183088534749939500E-57, 1.05288434613857573000E-59, 4.36191374659545444200E-62, 1.71017740178796946700E-64, 6.35417287308090154000E-67, 2.24023617204667066100E-69, 7.50388817892399787300E-72, 2.39087016939309798700E-74, 7.25439736654156264700E-77, 2.09846227207024494800E-79, 5.79315651373498761100E-82, 1.52786617607871741100E-84, 3.85332605389629328300E-87, 9.30196261538477647000E-90, 2.15126632809118648300E-92, 4.77058936290696223500E-95}, // 9: precision 5.82E-11 {1.77245385080234563500E+00, 4.43113461569894215700E-01, 5.53891806760746538300E-02, 4.61576361260268991600E-03, 2.88484673044866409200E-04, 1.44241019771415521500E-05, 6.00982861902849871600E-07, 2.14611541966231908200E-08, 6.70435999307504633400E-10, 1.86074527008731886600E-11, 4.64296589104966284700E-13, 1.05109058078120195880E-14, 2.17373506425627932200E-16, 4.12736258800510237200E-18, 7.22027572389545573000E-20, 1.16641031427122158000E-21, 1.74261574594878846800E-23, 2.40999131874158664000E-25, 3.08741471404781296800E-27, 3.66622899027160893300E-29, 4.03832398444680182100E-31, 4.12964092806000764200E-33, 3.92459969957984993300E-35, 3.47023698321199047400E-37, 2.85870037656881575800E-39, 2.19701222983622897200E-41, 1.57757442199878062800E-43, 1.05998290283581317870E-45, 6.67461794578944750100E-48, 3.94493775265477963400E-50, 2.19180590286711897200E-52, 1.14647284342367091100E-54, 5.65409064942635909000E-57, 2.63281413190197920300E-59, 1.15914855705146421000E-61, 4.83173813806023163900E-64, 1.90931412007029721900E-66, 7.16152712238209948300E-69, 2.55277823724126351900E-71, 8.65775632882397637500E-74, 2.79685049229469435800E-76, 8.61535752145576873700E-79, 2.53319381071928112300E-81, 7.11686161831786026200E-84, 1.91227899461300469000E-86, 4.91879425560043181900E-89, 1.21226578717106016000E-91, 2.86511260628508142200E-94}, // 10: precision 1.46E-11 {1.77245385087972342800E+00, 4.43113462419744630200E-01, 5.53891822321947835700E-02, 4.61576475266972634100E-03, 2.88485120632836570100E-04, 1.44242113476668549100E-05, 6.01001089101483108200E-07, 2.14633579957941871400E-08, 6.70638121912630560800E-10, 1.86219965341716152100E-11, 4.65139560168398521100E-13, 1.05511053035457485150E-14, 2.18978467579008781700E-16, 4.18179627467181890600E-18, 7.37905600609363562400E-20, 1.20666925770415139000E-21, 1.83216676939141016100E-23, 2.58616160243870388400E-25, 3.39612594393133643000E-27, 4.15117456105401982300E-29, 4.72512355800254106200E-31, 5.01108411105699264300E-33, 4.95452692086540934200E-35, 4.57052259669118191500E-37, 3.93757613394119041600E-39, 3.17143225730425447800E-41, 2.39087136989889684400E-43, 1.68918677399352864600E-45, 1.11992962513487784300E-47, 6.97720003652956407000E-50, 4.09017183052803247800E-52, 2.25925194899934230000E-54, 1.17743902383784437300E-56, 5.79751618317805258800E-59, 2.70049127204827368400E-61, 1.19150157862632851000E-63, 4.98581510751975724600E-66, 1.98102566456273457700E-68, 7.48277410614888503600E-71, 2.68994458637406843000E-73, 9.21308680313745922900E-76, 3.00957175301701607000E-78, 9.38604174484261857600E-81, 2.79745691952436047200E-83, 7.97548757616816228000E-86, 2.17700350714256603000E-88, 5.69442820814374326200E-91, 1.42855756885812751800E-93}, // 11: precision 3.64E-12 {1.77245385089906787700E+00, 4.43113462645337308000E-01, 5.53891826707801996000E-02, 4.61576509382801447000E-03, 2.88485262834342722100E-04, 1.44242482379506758200E-05, 6.01007615943023924400E-07, 2.14641957411498484200E-08, 6.70719685646245707700E-10, 1.86282265411023575000E-11, 4.65522856702499667400E-13, 1.05705070352080171380E-14, 2.19800647930093079100E-16, 4.21139261151871749000E-18, 7.47068213693802656400E-20, 1.23132525686457329000E-21, 1.89037080673535316000E-23, 2.70767450402634975900E-25, 3.62208731605653583200E-27, 4.52783644780645903400E-29, 5.29116794891083221600E-31, 5.78191926529856774600E-33, 5.91019131357709915300E-35, 5.65375339320520942200E-37, 5.06448494950527399600E-39, 4.25125004489814020300E-41, 3.34702040997479327500E-43, 2.47392597585772167100E-45, 1.71856809642179370600E-47, 1.12329116466680264100E-49, 6.91635006957699099400E-52, 4.01648185933072044700E-54, 2.20256743728563483200E-56, 1.14197705850825122000E-58, 5.60474946818590333800E-61, 2.60701847612354797700E-63, 1.15061401831998511400E-65, 4.82402847794291118400E-68, 1.92339714685666953300E-70, 7.30092195189691915600E-73, 2.64114863236683700200E-75, 9.11500639536260716600E-78, 3.00399043312000082200E-80, 9.46306767642663343000E-83, 2.85205432245625504600E-85, 8.23120145271503093200E-88, 2.27678649791096140000E-90, 6.04082678746563674000E-93}, // 12: precision 9.09E-13 {1.77245385090390399000E+00, 4.43113462705021723200E-01, 5.53891827935733966800E-02, 4.61576519490408572200E-03, 2.88485307416075940900E-04, 1.44242604760223605000E-05, 6.01009907022372119900E-07, 2.14645068933581115800E-08, 6.70751738699247757000E-10, 1.86308168994678478700E-11, 4.65691470353760117700E-13, 1.05795367138350319200E-14, 2.20205466324054638500E-16, 4.22680889851439179400E-18, 7.52117118137557251000E-20, 1.24569747014608843200E-21, 1.92626007811754286900E-23, 2.78693040917777943300E-25, 3.77798094465194860200E-27, 4.80270052176922369800E-29, 5.72806202403284098500E-31, 6.41118455649104110000E-33, 6.73530071235990996000E-35, 6.64287180769401900600E-37, 6.15272463485746774200E-39, 5.35401292372264035500E-41, 4.37964050507321407500E-43, 3.37013878900376065400E-45, 2.44151902553507999600E-47, 1.66674472552984171500E-49, 1.07324838386391679300E-51, 6.52532932562465070600E-54, 3.75007759408864456600E-56, 2.03933010598440151000E-58, 1.05056269424470639500E-60, 5.13240427502016103000E-63, 2.38044205354512290600E-65, 1.04929890842558070320E-67, 4.40052237815903136000E-70, 1.75760526644875492000E-72, 6.69249991110777975200E-75, 2.43182093294000139800E-77, 8.44044451319186471300E-80, 2.80086205952805676200E-82, 8.89407469263960473600E-85, 2.70501913533005623200E-87, 7.88617413146613817400E-90, 2.20568290007963387700E-92}}; BiasedUrn/src/fnchyppr.cpp0000644000176200001440000005754212640160171015265 0ustar liggesusers/*************************** fnchyppr.cpp ********************************** * Author: Agner Fog * Date created: 2002-10-20 * Last modified: 2015-12-27 * Project: stocc.zip * Source URL: www.agner.org/random * * Description: * Calculation of univariate and multivariate Fisher's noncentral hypergeometric * probability distribution. * * This file contains source code for the class CFishersNCHypergeometric * and CMultiFishersNCHypergeometric defined in stocc.h. * * Documentation: * ============== * The file stocc.h contains class definitions. * Further documentation on www.agner.org/random * * Copyright 2002-2015 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include // memmove function #include "stocc.h" // class definition /*********************************************************************** Methods for class CFishersNCHypergeometric ***********************************************************************/ CFishersNCHypergeometric::CFishersNCHypergeometric(int32 n, int32 m, int32 N, double odds, double accuracy) { // constructor // set parameters this->n = n; this->m = m; this->N = N; this->odds = odds; this->accuracy = accuracy; // check validity of parameters if (n < 0 || m < 0 || N < 0 || odds < 0. || n > N || m > N) { FatalError("Parameter out of range in class CFishersNCHypergeometric"); } if (accuracy < 0) accuracy = 0; if (accuracy > 1) accuracy = 1; // initialize logodds = log(odds); scale = rsum = 0.; ParametersChanged = 1; // calculate xmin and xmax xmin = m + n - N; if (xmin < 0) xmin = 0; xmax = n; if (xmax > m) xmax = m; } int32 CFishersNCHypergeometric::mode(void) { // Find mode (exact) // Uses the method of Liao and Rosen, The American Statistician, vol 55, // no 4, 2001, p. 366-369. // Note that there is an error in Liao and Rosen's formula. // Replace sgn(b) with -1 in Liao and Rosen's formula. double A, B, C, D; // coefficients for quadratic equation double x; // mode int32 L = m + n - N; int32 m1 = m+1, n1 = n+1; if (odds == 1.) { // simple hypergeometric x = (m + 1.) * (n + 1.) / (N + 2.); } else { // calculate analogously to Cornfield mean A = 1. - odds; B = (m1+n1)*odds - L; C = -(double)m1*n1*odds; D = B*B -4*A*C; D = D > 0. ? sqrt(D) : 0.; x = (D - B)/(A+A); } return int32(x); } double CFishersNCHypergeometric::mean(void) { // Find approximate mean // Calculation analogous with mode double a, b; // temporaries in calculation double mean; // mean if (odds == 1.) { // simple hypergeometric return double(m)*n/N; } // calculate Cornfield mean a = (m+n)*odds + (N-m-n); b = a*a - 4.*odds*(odds-1.)*m*n; b = b > 0. ? sqrt(b) : 0.; mean = (a-b)/(2.*(odds-1.)); return mean; } double CFishersNCHypergeometric::variance(void) { // find approximate variance (poor approximation) double my = mean(); // approximate mean // find approximate variance from Fisher's noncentral hypergeometric approximation double r1 = my * (m-my); double r2 = (n-my)*(my+N-n-m); if (r1 <= 0. || r2 <= 0.) return 0.; double var = N*r1*r2/((N-1)*(m*r2+(N-m)*r1)); if (var < 0.) var = 0.; return var; } double CFishersNCHypergeometric::moments(double * mean_, double * var_) { // calculate exact mean and variance // return value = sum of f(x), expected = 1. double y, sy=0, sxy=0, sxxy=0, me1; int32 x, xm, x1; const double accur = 0.1 * accuracy; // accuracy of calculation xm = (int32)mean(); // approximation to mean for (x = xm; x <= xmax; x++) { y = probability(x); x1 = x - xm; // subtract approximate mean to avoid loss of precision in sums sy += y; sxy += x1 * y; sxxy += x1 * x1 * y; if (y < accur && x != xm) break; } for (x = xm-1; x >= xmin; x--) { y = probability(x); x1 = x - xm; // subtract approximate mean to avoid loss of precision in sums sy += y; sxy += x1 * y; sxxy += x1 * x1 * y; if (y < accur) break; } me1 = sxy / sy; *mean_ = me1 + xm; y = sxxy / sy - me1 * me1; if (y < 0) y=0; *var_ = y; return sy; } double CFishersNCHypergeometric::probability(int32 x) { // calculate probability function const double accur = accuracy * 0.1;// accuracy of calculation if (x < xmin || x > xmax) return 0; if (n == 0) return 1.; if (odds == 1.) { // central hypergeometric return exp( LnFac(m) - LnFac(x) - LnFac(m-x) + LnFac(N-m) - LnFac(n-x) - LnFac((N-m)-(n-x)) - (LnFac(N) - LnFac(n) - LnFac(N-n))); } if (odds == 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in CFishersNCHypergeometric::probability"); return x == 0; } if (!rsum) { // first time. calculate rsum = reciprocal of sum of proportional // function over all probable x values int32 x1, x2; // x loop double y; // value of proportional function x1 = (int32)mean(); // start at mean if (x1 < xmin) x1 = xmin; x2 = x1 + 1; scale = 0.; scale = lng(x1); // calculate scale to avoid overflow rsum = 1.; // = exp(lng(x1)) with this scale for (x1--; x1 >= xmin; x1--) { rsum += y = exp(lng(x1)); // sum from x1 and down if (y < accur) break; // until value becomes negligible } for (; x2 <= xmax; x2++) { // sum from x2 and up rsum += y = exp(lng(x2)); if (y < accur) break; // until value becomes negligible } rsum = 1. / rsum; // save reciprocal sum } return exp(lng(x)) * rsum; // function value } double CFishersNCHypergeometric::probabilityRatio(int32 x, int32 x0) { // Calculate probability ratio f(x)/f(x0) // This is much faster than calculating a single probability because // rsum is not needed double a1, a2, a3, a4, f1, f2, f3, f4; int32 y, dx = x - x0; int invert = 0; if (x < xmin || x > xmax) return 0.; if (x0 < xmin || x0 > xmax) { FatalError("Infinity in CFishersNCHypergeometric::probabilityRatio"); } if (dx == 0.) return 1.; if (dx < 0.) { invert = 1; dx = -dx; y = x; x = x0; x0 = y; } a1 = m - x0; a2 = n - x0; a3 = x; a4 = N - m - n + x; if (dx <= 28 && x <= 100000) { // avoid overflow // direct calculation f1 = f2 = 1.; // compute ratio of binomials for (y = 0; y < dx; y++) { f1 *= a1-- * a2--; f2 *= a3-- * a4--; } // compute odds^dx f3 = 1.; f4 = odds; y = dx; while (y) { if (f4 < 1.E-100) { f3 = 0.; break; // avoid underflow } if (y & 1) f3 *= f4; f4 *= f4; y = (unsigned long)(y) >> 1; } f1 = f3 * f1 / f2; if (invert) f1 = 1. / f1; } else { // use logarithms f1 = FallingFactorial(a1,dx) + FallingFactorial(a2,dx) - FallingFactorial(a3,dx) - FallingFactorial(a4,dx) + dx * log(odds); if (invert) f1 = -f1; f1 = exp(f1); } return f1; } double CFishersNCHypergeometric::MakeTable(double * table, int32 MaxLength, int32 * xfirst, int32 * xlast, double cutoff) { // Makes a table of Fisher's noncentral hypergeometric probabilities. // Results are returned in the array table of size MaxLength. // The values are scaled so that the highest value is 1. The return value // is the sum, s, of all the values in the table. The normalized // probabilities are obtained by multiplying all values in the table by // 1/s. // The tails are cut off where the values are < cutoff, so that // *xfirst may be > xmin and *xlast may be < xmax. // The value of cutoff will be 0.01 * accuracy if not specified. // The first and last x value represented in the table are returned in // *xfirst and *xlast. The resulting probability values are returned in the // first (*xlast - *xfirst + 1) positions of table. If this would require // more than MaxLength values then the table is filled with as many // correct values as possible. // // The function will return the desired length of table when MaxLength = 0. double f; // probability function value double sum; // sum of table values double a1, a2, b1, b2; // factors in recursive calculation of f(x) int32 x; // x value int32 x1, x2; // lowest and highest x int32 i, i0, i1, i2; // table index int32 mode = this->mode(); // mode int32 L = n + m - N; // parameter int32 DesiredLength; // desired length of table // limits for x x1 = (L > 0) ? L : 0; // xmin x2 = (n < m) ? n : m; // xmax // special cases if (x1 == x2) goto DETERMINISTIC; if (odds <= 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in CWalleniusNCHypergeometric::MakeTable"); x1 = 0; DETERMINISTIC: if (MaxLength == 0) { if (xfirst) *xfirst = 1; return 1; } *xfirst = *xlast = x1; *table = 1.; return 1; } if (MaxLength <= 0) { // Return UseTable and LengthNeeded DesiredLength = x2 - x1 + 1; // max length of table if (DesiredLength > 200) { double sd = sqrt(variance()); // calculate approximate standard deviation // estimate number of standard deviations to include from normal distribution i = (int32)(NumSD(accuracy) * sd + 0.5); if (DesiredLength > i) DesiredLength = i; } if (xfirst) *xfirst = 1; // for analogy with CWalleniusNCHypergeometric::MakeTable return DesiredLength; } // place mode in the table if (mode - x1 <= MaxLength/2) { // There is enough space for left tail i0 = mode - x1; } else if (x2 - mode <= MaxLength/2) { // There is enough space for right tail i0 = MaxLength - x2 + mode - 1; if (i0 < 0) i0 = 0; } else { // There is not enough space for any of the tails. Place mode in middle of table i0 = MaxLength/2; } // Table start index i1 = i0 - mode + x1; if (i1 < 0) i1 = 0; // Table end index i2 = i0 + x2 - mode; if (i2 > MaxLength-1) i2 = MaxLength-1; // make center table[i0] = sum = f = 1.; // make left tail x = mode; a1 = m + 1 - x; a2 = n + 1 - x; b1 = x; b2 = x - L; for (i = i0 - 1; i >= i1; i--) { f *= b1 * b2 / (a1 * a2 * odds); // recursive formula a1++; a2++; b1--; b2--; sum += table[i] = f; if (f < cutoff) { i1 = i; break; // cut off tail if < accuracy } } if (i1 > 0) { // move table down for cut-off left tail memmove(table, table+i1, (i0-i1+1)*sizeof(*table)); // adjust indices i0 -= i1; i2 -= i1; i1 = 0; } // make right tail x = mode + 1; a1 = m + 1 - x; a2 = n + 1 - x; b1 = x; b2 = x - L; f = 1.; for (i = i0 + 1; i <= i2; i++) { f *= a1 * a2 * odds / (b1 * b2); // recursive formula a1--; a2--; b1++; b2++; sum += table[i] = f; if (f < cutoff) { i2 = i; break; // cut off tail if < accuracy } } // x limits *xfirst = mode - (i0 - i1); *xlast = mode + (i2 - i0); return sum; } double CFishersNCHypergeometric::lng(int32 x) { // natural log of proportional function // returns lambda = log(m!*x!/(m-x)!*m2!*x2!/(m2-x2)!*odds^x) int32 x2 = n - x, m2 = N - m; if (ParametersChanged) { mFac = LnFac(m) + LnFac(m2); xLast = -99; ParametersChanged = 0; } if (m < FAK_LEN && m2 < FAK_LEN) goto DEFLT; switch (x - xLast) { case 0: // x unchanged break; case 1: // x incremented. calculate from previous value xFac += log (double(x) * (m2-x2) / (double(x2+1)*(m-x+1))); break; case -1: // x decremented. calculate from previous value xFac += log (double(x2) * (m-x) / (double(x+1)*(m2-x2+1))); break; default: DEFLT: // calculate all xFac = LnFac(x) + LnFac(x2) + LnFac(m-x) + LnFac(m2-x2); } xLast = x; return mFac - xFac + x * logodds - scale; } /*********************************************************************** calculation methods in class CMultiFishersNCHypergeometric ***********************************************************************/ CMultiFishersNCHypergeometric::CMultiFishersNCHypergeometric(int32 n_, int32 * m_, double * odds_, int colors_, double accuracy_) { // constructor int i; // loop counter // copy parameters n = n_; Colors = colors_; accuracy = accuracy_; // check if parameters are valid reduced = 2; N = Nu = 0; usedcolors = 0; for (i = 0; i < Colors; i++) { nonzero[i] = 1; // remember if color i has m > 0 and odds > 0 m[usedcolors] = m_[i]; // copy m N += m_[i]; // sum of m if (m_[i] <= 0) { nonzero[i] = 0; // color i unused reduced |= 1; if (m_[i] < 0) FatalError("Parameter m negative in constructor for CMultiFishersNCHypergeometric"); } odds[usedcolors] = odds_[i]; // copy odds if (odds_[i] <= 0) { nonzero[i] = 0; // color i unused reduced |= 1; if (odds_[i] < 0) FatalError("Parameter odds negative in constructor for CMultiFishersNCHypergeometric"); } if (usedcolors > 0 && nonzero[i] && odds[usedcolors] != odds[usedcolors-1]) { reduced &= ~2; // odds are not all equal } if (nonzero[i]) { Nu += m[usedcolors]; // sum of m for used colors usedcolors++; // skip color i if zero } } if (N < n) FatalError("Taking more items than there are in constructor for CMultiFishersNCHypergeometric"); if (Nu< n) FatalError("Not enough items with nonzero weight in constructor for CMultiFishersNCHypergeometric"); // calculate mFac and logodds for (i=0, mFac=0.; i < usedcolors; i++) { mFac += LnFac(m[i]); logodds[i] = log(odds[i]); } // initialize sn = 0; } void CMultiFishersNCHypergeometric::mean(double * mu) { // calculates approximate mean of multivariate Fisher's noncentral // hypergeometric distribution. Result is returned in mu[0..colors-1]. // The calculation is reasonably fast. int i, j; // color index double mur[MAXCOLORS]; // mean for used colors // get mean of used colors mean1(mur); // resolve unused colors for (i = j = 0; i < Colors; i++) { if (nonzero[i]) { mu[i] = mur[j++]; } else { mu[i] = 0.; } } } void CMultiFishersNCHypergeometric::mean1(double * mu) { // calculates approximate mean of multivariate Fisher's noncentral // hypergeometric distribution, except for unused colors double r, r1; // iteration variable double q; // mean of color i double W; // total weight int i; // color index int iter = 0; // iteration counter if (usedcolors < 3) { // simple cases if (usedcolors == 1) mu[0] = n; if (usedcolors == 2) { mu[0] = CFishersNCHypergeometric(n,m[0],Nu,odds[0]/odds[1]).mean(); mu[1] = n - mu[0]; } } else if (n == Nu) { // Taking all balls for (i = 0; i < usedcolors; i++) mu[i] = m[i]; } else { // not a special case // initial guess for r for (i=0, W=0.; i < usedcolors; i++) W += m[i] * odds[i]; r = (double)n * Nu / ((Nu-n)*W); if (r > 0.) { // iteration loop to find r do { r1 = r; for (i=0, q=0.; i < usedcolors; i++) { q += m[i] * r * odds[i] / (r * odds[i] + 1.); } r *= n * (Nu-q) / (q * (Nu-n)); if (++iter > 100) FatalError("convergence problem in function CMultiFishersNCHypergeometric::mean"); } while (fabs(r-r1) > 1E-5); } // get result for (i=0; i < usedcolors; i++) { mu[i] = m[i] * r * odds[i] / (r * odds[i] + 1.); } } } void CMultiFishersNCHypergeometric::variance(double * var, double * mean_) { // calculates approximate variance of multivariate Fisher's noncentral // hypergeometric distribution (accuracy is not too good). // Variance is returned in variance[0..colors-1]. // Mean is returned in mean_[0..colors-1] if not NULL. // The calculation is reasonably fast. double r1, r2; double mu[MAXCOLORS]; int i, j; mean1(mu); // Mean of used colors for (i = j = 0; i < Colors; i++) { if (nonzero[i]) { r1 = mu[j] * (m[j]-mu[j]); r2 = (n-mu[j])*(mu[j]+Nu-n-m[j]); if (r1 <= 0. || r2 <= 0.) { var[i] = 0.; } else { var[i] = Nu*r1*r2/((Nu-1)*(m[j]*r2+(Nu-m[j])*r1)); } j++; } else { // unused color var[i] = 0.; } } // Store mean if mean_ is not NULL if (mean_) { // resolve unused colors for (i = j = 0; i < Colors; i++) { if (nonzero[i]) { mean_[i] = mu[j++]; } else { mean_[i] = 0.; } } } } double CMultiFishersNCHypergeometric::probability(int32 * x) { // Calculate probability function. // Note: The first-time call takes very long time because it requires // a calculation of all possible x combinations with probability > // accuracy, which may be extreme. // The calculation uses logarithms to avoid overflow. // (Recursive calculation may be faster, but this has not been implemented) int i, j; // color index int32 xsum = 0; // sum of x int32 Xu[MAXCOLORS]; // x for used colors // resolve unused colors for (i = j = 0; i < Colors; i++) { if (nonzero[i]) { Xu[j++] = x[i]; // copy x to array of used colors xsum += x[i]; // sum of x } else { if (x[i]) return 0.; // taking balls with zero weight } } if (xsum != n) { FatalError("sum of x values not equal to n in function CMultiFishersNCHypergeometric::probability"); } for (i = 0; i < usedcolors; i++) { if (Xu[i] > m[i] || Xu[i] < 0 || Xu[i] < n - Nu + m[i]) return 0.; // Outside bounds for x } if (n == 0 || n == Nu) return 1.; // deterministic cases if (usedcolors < 3) { // cases with < 3 colors if (usedcolors < 2) return 1.; // Univariate probability return CFishersNCHypergeometric(n, m[0], Nu, odds[0]/odds[1], accuracy).probability(Xu[0]); } if (reduced & 2) { // All odds are equal. This is multivariate central hypergeometric distribution int32 sx = n, sm = N; double p = 1.; for (i = 0; i < usedcolors - 1; i++) { // Use univariate hypergeometric (usedcolors-1) times p *= CFishersNCHypergeometric(sx, m[i], sm, 1.).probability(x[i]); sx -= x[i]; sm -= m[i]; } return p; } // all special cases eliminated. Calculate sum of all function values if (sn == 0) SumOfAll(); // first time initialize return exp(lng(Xu)) * rsum; // function value } double CMultiFishersNCHypergeometric::moments(double * mean, double * variance, int32 * combinations) { // calculates mean and variance of the Fisher's noncentral hypergeometric // distribution by calculating all combinations of x-values with // probability > accuracy. // Return value = 1. // Returns the mean in mean[0...colors-1] // Returns the variance in variance[0...colors-1] int i, j; // color index if (sn == 0) { // first time initialization includes calculation of mean and variance SumOfAll(); } // copy results and resolve unused colors for (i = j = 0; i < Colors; i++) { if (nonzero[i]) { mean[i] = sx[j]; variance[i] = sxx[j]; j++; } else { mean[i] = variance[i] = 0.; } } if (combinations) *combinations = sn; return 1.; } void CMultiFishersNCHypergeometric::SumOfAll() { // this function does the very time consuming job of calculating the sum // of the proportional function g(x) over all possible combinations of // the x[i] values with probability > accuracy. These combinations are // generated by the recursive function loop(). // The mean and variance are generated as by-products. int i; // color index int32 msum; // sum of m[i] // get approximate mean mean1(sx); // round mean to integers for (i=0, msum=0; i < usedcolors; i++) { msum += xm[i] = (int32)(sx[i]+0.4999999);} // adjust truncated x values to make the sum = n msum -= n; for (i = 0; msum < 0; i++) { if (xm[i] < m[i]) { xm[i]++; msum++; } } for (i = 0; msum > 0; i++) { if (xm[i] > 0) { xm[i]--; msum--; } } // adjust scale factor to g(mean) to avoid overflow scale = 0.; scale = lng(xm); // initialize for recursive loops sn = 0; for (i = usedcolors-1, msum = 0; i >= 0; i--) { remaining[i] = msum; msum += m[i]; } for (i = 0; i < usedcolors; i++) { sx[i] = 0; sxx[i] = 0; } // recursive loops to calculate sums of g(x) over all x combinations rsum = 1. / loop(n, 0); // calculate mean and variance for (i = 0; i < usedcolors; i++) { sxx[i] = sxx[i]*rsum - sx[i]*sx[i]*rsum*rsum; sx[i] = sx[i]*rsum; } } double CMultiFishersNCHypergeometric::loop(int32 n, int c) { // recursive function to loop through all combinations of x-values. // used by SumOfAll int32 x, x0; // x of color c int32 xmin, xmax; // min and max of x[c] double s1, s2, sum = 0.; // sum of g(x) values int i; // loop counter if (c < usedcolors-1) { // not the last color // calculate min and max of x[c] for given x[0]..x[c-1] xmin = n - remaining[c]; if (xmin < 0) xmin = 0; xmax = m[c]; if (xmax > n) xmax = n; x0 = xm[c]; if (x0 < xmin) x0 = xmin; if (x0 > xmax) x0 = xmax; // loop for all x[c] from mean and up for (x = x0, s2 = 0.; x <= xmax; x++) { xi[c] = x; sum += s1 = loop(n-x, c+1); // recursive loop for remaining colors if (s1 < accuracy && s1 < s2) break; // stop when values become negligible s2 = s1; } // loop for all x[c] from mean and down for (x = x0-1; x >= xmin; x--) { xi[c] = x; sum += s1 = loop(n-x, c+1); // recursive loop for remaining colors if (s1 < accuracy && s1 < s2) break; // stop when values become negligible s2 = s1; } } else { // last color xi[c] = n; // sums and squaresums s1 = exp(lng(xi)); // proportional function g(x) for (i = 0; i < usedcolors; i++) { // update sums sx[i] += s1 * xi[i]; sxx[i] += s1 * xi[i] * xi[i]; } sn++; sum += s1; } return sum; } double CMultiFishersNCHypergeometric::lng(int32 * x) { // natural log of proportional function g(x) double y = 0.; int i; for (i = 0; i < usedcolors; i++) { y += x[i]*logodds[i] - LnFac(x[i]) - LnFac(m[i]-x[i]); } return mFac + y - scale; } BiasedUrn/src/wnchyppr.cpp0000644000176200001440000022637012640160171015303 0ustar liggesusers/*************************** wnchyppr.cpp ********************************** * Author: Agner Fog * Date created: 2002-10-20 * Last modified: 2013-11-06 * Project: stocc.zip * Source URL: www.agner.org/random * * Description: * Calculation of univariate and multivariate Wallenius noncentral * hypergeometric probability distribution. * * This file contains source code for the class CWalleniusNCHypergeometric * and CMultiWalleniusNCHypergeometricMoments defined in stocc.h. * * Documentation: * ============== * The file stocc.h contains class definitions. * The file nchyp.pdf, available from www.agner.org/random/theory * describes the theory of the calculation methods. * The file ran-instructions.pdf contains further documentation and * instructions. * * Copyright 2002-2013 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include // memcpy function #include "stocc.h" // class definition #include "erfres.h" // table of error function residues (Don't precompile this header) /*********************************************************************** constants ***********************************************************************/ static const double LN2 = 0.693147180559945309417; // log(2) /*********************************************************************** Log and Exp functions with special care for small x ***********************************************************************/ // These are functions that involve expressions of the types log(1+x) // and exp(x)-1. These functions need special care when x is small to // avoid loss of precision. There are three versions of these functions: // (1) Assembly version in library randomaXX.lib // (2) Use library functions log1p and expm1 if available // (3) Use Taylor expansion if none of the above are available #ifdef RANDOMA_H // (1) // Assembly library randomaXX.lib is used. // Nothing to include here. #elif defined(__GNUC__) || defined (__INTEL_COMPILER) || defined(HAVE_EXPM1) // (2) // Functions log1p(x) = log(1+x) and expm1(x) = exp(x)-1 are available // in the math libraries of Gnu and Intel compilers // and in R.DLL (www.r-project.org). double pow2_1(double q, double * y0 = 0) { // calculate 2^q and (1-2^q) without loss of precision. // return value is (1-2^q). 2^q is returned in *y0 double y, y1; q *= LN2; if (fabs(q) > 0.1) { y = exp(q); // 2^q y1 = 1. - y; // 1-2^q } else { // Use expm1 y1 = expm1(q); // 2^q-1 y = y1 + 1; // 2^q y1 = -y1; // 1-2^q } if (y0) *y0 = y; // Return y if not void pointer return y1; // Return y1 } double log1mx(double x, double x1) { // Calculate log(1-x) without loss of precision when x is small. // Parameter x1 must be = 1-x. if (fabs(x) > 0.03) { return log(x1); } else { // use log1p(x) = log(1+x) return log1p(-x); } } double log1pow(double q, double x) { // calculate log((1-e^q)^x) without loss of precision. // Combines the methods of the above two functions. double y, y1; if (fabs(q) > 0.1) { y = exp(q); // e^q y1 = 1. - y; // 1-e^q } else { // Use expm1 y1 = expm1(q); // e^q-1 y = y1 + 1; // e^q y1 = -y1; // 1-e^q } if (y > 0.1) { // (1-y)^x calculated without problem return x * log(y1); } else { // Use log1p return x * log1p(-y); } } #else // (3) // Functions log1p and expm1 are not available in MS and Borland compiler // libraries. Use explicit Taylor expansion when needed. double pow2_1(double q, double * y0 = 0) { // calculate 2^q and (1-2^q) without loss of precision. // return value is (1-2^q). 2^q is returned in *y0 double y, y1, y2, qn, i, ifac; q *= LN2; if (fabs(q) > 0.1) { y = exp(q); y1 = 1. - y; } else { // expand 1-e^q = -summa(q^n/n!) to avoid loss of precision y1 = 0; qn = i = ifac = 1; do { y2 = y1; qn *= q; ifac *= i++; y1 -= qn / ifac; } while (y1 != y2); y = 1.-y1; } if (y0) *y0 = y; return y1; } double log1mx(double x, double x1) { // Calculate log(1-x) without loss of precision when x is small. // Parameter x1 must be = 1-x. if (fabs(x) > 0.03) { return log(x1); } else { // expand ln(1-x) = -summa(x^n/n) double y, z1, z2, i; y = i = 1.; z1 = 0; do { z2 = z1; y *= x; z1 -= y / i++; } while (z1 != z2); return z1; } } double log1pow(double q, double x) { // calculate log((1-e^q)^x) without loss of precision // Uses various Taylor expansions to avoid loss of precision double y, y1, y2, z1, z2, qn, i, ifac; if (fabs(q) > 0.1) { y = exp(q); y1 = 1. - y; } else { // expand 1-e^q = -summa(q^n/n!) to avoid loss of precision y1 = 0; qn = i = ifac = 1; do { y2 = y1; qn *= q; ifac *= i++; y1 -= qn / ifac; } while (y1 != y2); y = 1. - y1; } if (y > 0.1) { // (1-y)^x calculated without problem return x * log(y1); } else { // expand ln(1-y) = -summa(y^n/n) y1 = i = 1.; z1 = 0; do { z2 = z1; y1 *= y; z1 -= y1 / i++; } while (z1 != z2); return x * z1; } } #endif /*********************************************************************** Other shared functions ***********************************************************************/ double LnFacr(double x) { // log factorial of non-integer x int32 ix = (int32)(x); if (x == ix) return LnFac(ix); // x is integer double r, r2, D = 1., f; static const double C0 = 0.918938533204672722, // ln(sqrt(2*pi)) C1 = 1./12., C3 = -1./360., C5 = 1./1260., C7 = -1./1680.; if (x < 6.) { if (x == 0 || x == 1) return 0; while (x < 6) D *= ++x; } r = 1. / x; r2 = r*r; f = (x + 0.5)*log(x) - x + C0 + r*(C1 + r2*(C3 + r2*(C5 + r2*C7))); if (D != 1.) f -= log(D); return f; } double FallingFactorial(double a, double b) { // calculates ln(a*(a-1)*(a-2)* ... * (a-b+1)) if (b < 30 && int(b) == b && a < 1E10) { // direct calculation double f = 1.; for (int i = 0; i < b; i++) f *= a--; return log(f); } if (a > 100.*b && b > 1.) { // combine Stirling formulas for a and (a-b) to avoid loss of precision double ar = 1./a; double cr = 1./(a-b); // calculate -log(1-b/a) by Taylor expansion double s = 0., lasts, n = 1., ba = b*ar, f = ba; do { lasts = s; s += f/n; f *= ba; n++; } while (s != lasts); return (a+0.5)*s + b*log(a-b) - b + (1./12.)*(ar-cr) //- (1./360.)*(ar*ar*ar-cr*cr*cr) ; } // use LnFacr function return LnFacr(a)-LnFacr(a-b); } double Erf (double x) { // Calculates the error function erf(x) as a series expansion or // continued fraction expansion. // This function may be available in math libraries as erf(x) static const double rsqrtpi = 0.564189583547756286948; // 1/sqrt(pi) static const double rsqrtpi2 = 1.12837916709551257390; // 2/sqrt(pi) if (x < 0.) return -Erf(-x); if (x > 6.) return 1.; if (x < 2.4) { // use series expansion double term; // term in summation double j21; // 2j+1 double sum = 0; // summation double xx2 = x*x*2.; // 2x^2 int j; term = x; j21 = 1.; for (j=0; j<=50; j++) { // summation loop sum += term; if (term <= 1.E-13) break; j21 += 2.; term *= xx2 / j21; } return exp(-x*x) * sum * rsqrtpi2; } else { // use continued fraction expansion double a, f; int n = int(2.25f*x*x - 23.4f*x + 60.84f); // predict expansion degree if (n < 1) n = 1; a = 0.5 * n; f = x; for (; n > 0; n--) { // continued fraction loop f = x + a / f; a -= 0.5; } return 1. - exp(-x*x) * rsqrtpi / f; } } int32 FloorLog2(float x) { // This function calculates floor(log2(x)) for positive x. // The return value is <= -127 for x <= 0. union UfloatInt { // Union for extracting bits from a float float f; int32 i; UfloatInt(float ff) {f = ff;} // constructor }; #if defined(_M_IX86) || defined(__INTEL__) || defined(_M_X64) || defined(__IA64__) || defined(__POWERPC__) // Running on a platform known to use IEEE-754 floating point format //int32 n = *(int32*)&x; int32 n = UfloatInt(x).i; return (n >> 23) - 0x7F; #else // Check if floating point format is IEEE-754 static const UfloatInt check(1.0f); if (check.i == 0x3F800000) { // We have the standard IEEE floating point format int32 n = UfloatInt(x).i; return (n >> 23) - 0x7F; } else { // Unknown floating point format if (x <= 0.f) return -127; return (int32)floor(log(x)*(1./LN2)); } #endif } int NumSD (double accuracy) { // Gives the length of the integration interval necessary to achieve // the desired accuracy when integrating/summating a probability // function, relative to the standard deviation // Returns an integer approximation to 2*NormalDistrFractile(accuracy/2) static const double fract[] = { 2.699796e-03, 4.652582e-04, 6.334248e-05, 6.795346e-06, 5.733031e-07, 3.797912e-08, 1.973175e-09, 8.032001e-11, 2.559625e-12, 6.381783e-14}; int i; for (i = 0; i < (int)(sizeof(fract)/sizeof(*fract)); i++) { if (accuracy >= fract[i]) break; } return i + 6; } /*********************************************************************** Methods for class CWalleniusNCHypergeometric ***********************************************************************/ CWalleniusNCHypergeometric::CWalleniusNCHypergeometric(int32 n_, int32 m_, int32 N_, double odds_, double accuracy_) { // constructor accuracy = accuracy_; SetParameters(n_, m_, N_, odds_);} void CWalleniusNCHypergeometric::SetParameters(int32 n_, int32 m_, int32 N_, double odds) { // change parameters if (n_ < 0 || n_ > N_ || m_ < 0 || m_ > N_ || odds < 0) FatalError("Parameter out of range in CWalleniusNCHypergeometric"); n = n_; m = m_; N = N_; omega = odds; // set parameters xmin = m + n - N; if (xmin < 0) xmin = 0; // calculate xmin xmax = n; if (xmax > m) xmax = m; // calculate xmax xLastBico = xLastFindpars = -99; // indicate last x is invalid r = 1.; // initialize } double CWalleniusNCHypergeometric::mean(void) { // find approximate mean int iter; // number of iterations double a, b; // temporaries in calculation of first guess double mean, mean1; // iteration value of mean double m1r, m2r; // 1/m, 1/m2 double e1, e2; // temporaries double g; // function to find root of double gd; // derivative of g double omegar; // 1/omega if (omega == 1.) { // simple hypergeometric return double(m)*n/N; } if (omega == 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in CWalleniusNCHypergeometric::mean"); return 0.; } if (xmin == xmax) return xmin; // calculate Cornfield mean of Fisher noncentral hypergeometric distribution as first guess a = (m+n)*omega + (N-m-n); b = a*a - 4.*omega*(omega-1.)*m*n; b = b > 0. ? sqrt(b) : 0.; mean = (a-b)/(2.*(omega-1.)); if (mean < xmin) mean = xmin; if (mean > xmax) mean = xmax; m1r = 1./m; m2r = 1./(N-m); iter = 0; if (omega > 1.) { do { // Newton Raphson iteration mean1 = mean; e1 = 1.-(n-mean)*m2r; if (e1 < 1E-14) { e2 = 0.; // avoid underflow } else { e2 = pow(e1,omega-1.); } g = e2*e1 + (mean-m)*m1r; gd = e2*omega*m2r + m1r; mean -= g / gd; if (mean < xmin) mean = xmin; if (mean > xmax) mean = xmax; if (++iter > 40) { FatalError("Search for mean failed in function CWalleniusNCHypergeometric::mean"); } } while (fabs(mean1 - mean) > 2E-6); } else { // omega < 1 omegar = 1./omega; do { // Newton Raphson iteration mean1 = mean; e1 = 1.-mean*m1r; if (e1 < 1E-14) { e2 = 0.; // avoid underflow } else { e2 = pow(e1,omegar-1.); } g = 1.-(n-mean)*m2r-e2*e1; gd = e2*omegar*m1r + m2r; mean -= g / gd; if (mean < xmin) mean = xmin; if (mean > xmax) mean = xmax; if (++iter > 40) { FatalError("Search for mean failed in function CWalleniusNCHypergeometric::mean"); } } while (fabs(mean1 - mean) > 2E-6); } return mean; } double CWalleniusNCHypergeometric::variance(void) { // find approximate variance (poor approximation) double my = mean(); // approximate mean // find approximate variance from Fisher's noncentral hypergeometric approximation double r1 = my * (m-my); double r2 = (n-my)*(my+N-n-m); if (r1 <= 0. || r2 <= 0.) return 0.; double var = N*r1*r2/((N-1)*(m*r2+(N-m)*r1)); if (var < 0.) var = 0.; return var; } double CWalleniusNCHypergeometric::moments(double * mean_, double * var_) { // calculate exact mean and variance // return value = sum of f(x), expected = 1. double y, sy=0, sxy=0, sxxy=0, me1; int32 x, xm, x1; const double accur = 0.1 * accuracy; // accuracy of calculation xm = (int32)mean(); // approximation to mean for (x = xm; x <= xmax; x++) { y = probability(x); x1 = x - xm; // subtract approximate mean to avoid loss of precision in sums sy += y; sxy += x1 * y; sxxy += x1 * x1 * y; if (y < accur && x != xm) break; } for (x = xm-1; x >= xmin; x--) { y = probability(x); x1 = x - xm; // subtract approximate mean to avoid loss of precision in sums sy += y; sxy += x1 * y; sxxy += x1 * x1 * y; if (y < accur) break; } me1 = sxy / sy; *mean_ = me1 + xm; y = sxxy / sy - me1 * me1; if (y < 0) y=0; *var_ = y; return sy; } int32 CWalleniusNCHypergeometric::mode(void) { // find mode int32 Mode; // mode if (omega == 1.) { // simple hypergeometric int32 L = m + n - N; int32 m1 = m + 1, n1 = n + 1; Mode = int32((double)m1*n1*omega/((m1+n1)*omega-L)); } else { // find mode double f, f2 = -1.; // f2 = 0.; int32 xi, x2; int32 xmin = m + n - N; if (xmin < 0) xmin = 0; // calculate xmin int32 xmax = n; if (xmax > m) xmax = m; // calculate xmax Mode = (int32)mean(); // floor(mean) if (omega < 1.) { if (Mode < xmax) Mode++; // ceil(mean) x2 = xmin; // lower limit if (omega > 0.294 && N <= 10000000) { x2 = Mode - 1;} // search for mode can be limited for (xi = Mode; xi >= x2; xi--) { f = probability(xi); if (f <= f2) break; Mode = xi; f2 = f; } } else { if (Mode < xmin) Mode++; x2 = xmax; // upper limit if (omega < 3.4 && N <= 10000000) { x2 = Mode + 1;} // search for mode can be limited for (xi = Mode; xi <= x2; xi++) { f = probability(xi); if (f <= f2) break; Mode = xi; f2 = f; } } } return Mode; } double CWalleniusNCHypergeometric::lnbico() { // natural log of binomial coefficients. // returns lambda = log(m!*x!/(m-x)!*m2!*x2!/(m2-x2)!) int32 x2 = n-x, m2 = N-m; if (xLastBico < 0) { // m, n, N have changed mFac = LnFac(m) + LnFac(m2); } if (m < FAK_LEN && m2 < FAK_LEN) goto DEFLT; switch (x - xLastBico) { case 0: // x unchanged break; case 1: // x incremented. calculate from previous value xFac += log (double(x) * (m2-x2) / (double(x2+1)*(m-x+1))); break; case -1: // x decremented. calculate from previous value xFac += log (double(x2) * (m-x) / (double(x+1)*(m2-x2+1))); break; default: DEFLT: // calculate all xFac = LnFac(x) + LnFac(x2) + LnFac(m-x) + LnFac(m2-x2); } xLastBico = x; return bico = mFac - xFac; } void CWalleniusNCHypergeometric::findpars() { // calculate d, E, r, w if (x == xLastFindpars) { return; // all values are unchanged since last call } // find r to center peak of integrand at 0.5 double dd, d1, z, zd, rr, lastr, rrc, rt, r2, r21, a, b, dummy; double oo[2]; double xx[2] = {double(x), double(n-x)}; int i, j = 0; if (omega > 1.) { // make both omegas <= 1 to avoid overflow oo[0] = 1.; oo[1] = 1./omega; } else { oo[0] = omega; oo[1] = 1.; } dd = oo[0]*(m-x) + oo[1]*(N-m-xx[1]); d1 = 1./dd; E = (oo[0]*m + oo[1]*(N-m)) * d1; rr = r; if (rr <= d1) rr = 1.2*d1; // initial guess // Newton-Raphson iteration to find r do { lastr = rr; rrc = 1. / rr; z = dd - rrc; zd = rrc * rrc; for (i=0; i<2; i++) { rt = rr * oo[i]; if (rt < 100.) { // avoid overflow if rt big r21 = pow2_1(rt, &r2); // r2=2^r, r21=1.-2^r a = oo[i] / r21; // omegai/(1.-2^r) b = xx[i] * a; // x*omegai/(1.-2^r) z += b; zd += b * a * LN2 * r2; } } if (zd == 0) FatalError("can't find r in function CWalleniusNCHypergeometric::findpars"); rr -= z / zd; if (rr <= d1) rr = lastr * 0.125 + d1*0.875; if (++j == 70) FatalError("convergence problem searching for r in function CWalleniusNCHypergeometric::findpars"); } while (fabs(rr-lastr) > rr * 1.E-6); if (omega > 1) { dd *= omega; rr *= oo[1]; } r = rr; rd = rr * dd; // find peak width double ro, k1, k2; ro = r * omega; if (ro < 300) { // avoid overflow k1 = pow2_1(ro, &dummy); k1 = -1. / k1; k1 = omega*omega*(k1+k1*k1); } else k1 = 0.; if (r < 300) { // avoid overflow k2 = pow2_1(r, &dummy); k2 = -1. / k2; k2 = (k2+k2*k2); } else k2 = 0.; phi2d = -4.*r*r*(x*k1 + (n-x)*k2); if (phi2d >= 0.) { FatalError("peak width undefined in function CWalleniusNCHypergeometric::findpars"); /* wr = r = 0.; */ } else { wr = sqrt(-phi2d); w = 1./wr; } xLastFindpars = x; } int CWalleniusNCHypergeometric::BernouilliH(int32 x_, double h, double rh, StochasticLib1 *sto) { // This function generates a Bernouilli variate with probability proportional // to the univariate Wallenius' noncentral hypergeometric distribution. // The return value will be 1 with probability f(x_)/h and 0 with probability // 1-f(x_)/h. // This is equivalent to calling sto->Bernouilli(probability(x_)/h), // but this method is faster. The method used here avoids calculating the // Wallenius probability by sampling in the t-domain. // rh is a uniform random number in the interval 0 <= rh < h. The function // uses additional random numbers generated from sto. // This function is intended for use in rejection methods for sampling from // the Wallenius distribution. It is called from // StochasticLib3::WalleniusNCHypRatioOfUnifoms in the file stoc3.cpp double f0; // Lambda*Phi() double phideri0; // phi()/rd double qi; // 2^(-r*omega[i]) double qi1; // 1-qi double omegai[2] = {omega,1.}; // weights for each color double romegi; // r*omega[i] double xi[2] = {double(x_), double(n-x_)}; // number of each color sampled double k; // adjusted width for majorizing function Ypsilon(t) double erfk; // erf correction double rdm1; // rd - 1 double G_integral; // integral of majorizing function Ypsilon(t) double ts; // t sampled from Ypsilon(t) distribution double logts; // log(ts) double rlogts; // r*log(ts) double fts; // Phi(ts)/rd double rgts; // 1/(Ypsilon(ts)/rd) double t2; // temporary in calculation of Ypsilon(ts) int i, j; // loop counters static const double rsqrt8 = 0.3535533905932737622; // 1/sqrt(8) static const double sqrt2pi = 2.506628274631000454; // sqrt(2*pi) x = x_; // save x in class object lnbico(); // calculate bico = log(Lambda) findpars(); // calculate r, d, rd, w, E if (E > 0.) { k = log(E); // correction for majorizing function k = 1. + 0.0271 * (k * sqrt(k)); } else k = 1.; k *= w; // w * k rdm1 = rd - 1.; // calculate phi()/rd phideri0 = -LN2 * rdm1; for (i=0; i<2; i++) { romegi = r * omegai[i]; if (romegi > 40.) { qi=0.; qi1 = 1.; // avoid underflow } else { qi1 = pow2_1(-romegi, &qi); } phideri0 += xi[i] * log1mx(qi, qi1); } erfk = Erf(rsqrt8 / k); f0 = rd * exp(phideri0 + bico); G_integral = f0 * sqrt2pi * k * erfk; if (G_integral <= h) { // G fits under h-hat do { ts = sto->Normal(0,k); // sample ts from normal distribution } while (fabs(ts) >= 0.5); // reject values outside interval, and avoid ts = 0 ts += 0.5; // ts = normal distributed in interval (0,1) for (fts=0., j=0; j<2; j++) { // calculate (Phi(ts)+Phi(1-ts))/2 logts = log(ts); rlogts = r * logts; // (ts = 0 avoided above) fts += exp(log1pow(rlogts*omega,xi[0]) + log1pow(rlogts,xi[1]) + rdm1*logts + bico); ts = 1. - ts; } fts *= 0.5; t2 = (ts-0.5) / k; // calculate 1/Ypsilon(ts) rgts = exp(-(phideri0 + bico - 0.5 * t2*t2)); return rh < G_integral * fts * rgts; // Bernouilli variate } else { // G > h: can't use sampling in t-domain return rh < probability(x); } } /*********************************************************************** methods for calculating probability in class CWalleniusNCHypergeometric ***********************************************************************/ double CWalleniusNCHypergeometric::recursive() { // recursive calculation // Wallenius noncentral hypergeometric distribution by recursion formula // Approximate by ignoring probabilities < accuracy and minimize storage requirement const int BUFSIZE = 512; // buffer size double p[BUFSIZE+2]; // probabilities double * p1, * p2; // offset into p double mxo; // (m-x)*omega double Nmnx; // N-m-nu+x double y, y1; // save old p[x] before it is overwritten double d1, d2, dcom; // divisors in probability formula double accuracya; // absolute accuracy int32 xi, nu; // xi, nu = recursion values of x, n int32 x1, x2; // xi_min, xi_max accuracya = 0.005f * accuracy; // absolute accuracy p1 = p2 = p + 1; // make space for p1[-1] p1[-1] = 0.; p1[0] = 1.; // initialize for recursion x1 = x2 = 0; for (nu=1; nu<=n; nu++) { if (n - nu < x - x1 || p1[x1] < accuracya) { x1++; // increase lower limit when breakpoint passed or probability negligible p2--; // compensate buffer offset in order to reduce storage space } if (x2 < x && p1[x2] >= accuracya) { x2++; y1 = 0.; // increase upper limit until x has been reached } else { y1 = p1[x2]; } if (x1 > x2) return 0.; if (p2+x2-p > BUFSIZE) FatalError("buffer overrun in function CWalleniusNCHypergeometric::recursive"); mxo = (m-x2)*omega; Nmnx = N-m-nu+x2+1; for (xi = x2; xi >= x1; xi--) { // backwards loop d2 = mxo + Nmnx; mxo += omega; Nmnx--; d1 = mxo + Nmnx; dcom = 1. / (d1 * d2); // save a division by making common divisor y = p1[xi-1]*mxo*d2*dcom + y1*(Nmnx+1)*d1*dcom; y1 = p1[xi-1]; // (warning: pointer alias, can't swap instruction order) p2[xi] = y; } p1 = p2; } if (x < x1 || x > x2) return 0.; return p1[x]; } double CWalleniusNCHypergeometric::binoexpand() { // calculate by binomial expansion of integrand // only for x < 2 or n-x < 2 (not implemented for higher x because of loss of precision) int32 x1, m1, m2; double o; if (x > n/2) { // invert x1 = n-x; m1 = N-m; m2 = m; o = 1./omega; } else { x1 = x; m1 = m; m2 = N-m; o = omega; } if (x1 == 0) { return exp(FallingFactorial(m2,n) - FallingFactorial(m2+o*m1,n)); } if (x1 == 1) { double d, e, q, q0, q1; q = FallingFactorial(m2,n-1); e = o*m1+m2; q1 = q - FallingFactorial(e,n); e -= o; q0 = q - FallingFactorial(e,n); d = e - (n-1); return m1*d*(exp(q0) - exp(q1)); } FatalError("x > 1 not supported by function CWalleniusNCHypergeometric::binoexpand"); return 0; } double CWalleniusNCHypergeometric::laplace() { // Laplace's method with narrow integration interval, // using error function residues table, defined in erfres.cpp // Note that this function can only be used when the integrand peak is narrow. // findpars() must be called before this function. const int COLORS = 2; // number of colors const int MAXDEG = 40; // arraysize, maximum expansion degree int degree; // max expansion degree double accur; // stop expansion when terms below this threshold double omegai[COLORS] = {omega, 1.}; // weights for each color double xi[COLORS] = {double(x), double(n-x)}; // number of each color sampled double f0; // factor outside integral double rho[COLORS]; // r*omegai double qi; // 2^(-rho) double qi1; // 1-qi double qq[COLORS]; // qi / qi1 double eta[COLORS+1][MAXDEG+1]; // eta coefficients double phideri[MAXDEG+1]; // derivatives of phi double PSIderi[MAXDEG+1]; // derivatives of PSI double * erfresp; // pointer to table of error function residues // variables in asymptotic summation static const double sqrt8 = 2.828427124746190098; // sqrt(8) double qqpow; // qq^j double pow2k; // 2^k double bino; // binomial coefficient double vr; // 1/v, v = integration interval double v2m2; // (2*v)^(-2) double v2mk1; // (2*v)^(-k-1) double s; // summation term double sum; // Taylor sum int i; // loop counter for color int j; // loop counter for derivative int k; // loop counter for expansion degree int ll; // k/2 int converg = 0; // number of consequtive terms below accuracy int PrecisionIndex; // index into ErfRes table according to desired precision // initialize for (k = 0; k <= 2; k++) phideri[k] = PSIderi[k] = 0; // find rho[i], qq[i], first eta coefficients, and zero'th derivative of phi for (i = 0; i < COLORS; i++) { rho[i] = r * omegai[i]; if (rho[i] > 40.) { qi=0.; qi1 = 1.;} // avoid underflow else { qi1 = pow2_1(-rho[i], &qi);} // qi=2^(-rho), qi1=1.-2^(-rho) qq[i] = qi / qi1; // 2^(-r*omegai)/(1.-2^(-r*omegai)) // peak = zero'th derivative phideri[0] += xi[i] * log1mx(qi, qi1); // eta coefficients eta[i][0] = 0.; eta[i][1] = eta[i][2] = rho[i]*rho[i]; } // r, rd, and w must be calculated by findpars() // zero'th derivative phideri[0] -= (rd - 1.) * LN2; // scaled factor outside integral f0 = rd * exp(phideri[0] + lnbico()); vr = sqrt8 * w; phideri[2] = phi2d; // get table according to desired precision PrecisionIndex = (-FloorLog2((float)accuracy) - ERFRES_B + ERFRES_S - 1) / ERFRES_S; if (PrecisionIndex < 0) PrecisionIndex = 0; if (PrecisionIndex > ERFRES_N-1) PrecisionIndex = ERFRES_N-1; while (w * NumSDev[PrecisionIndex] > 0.3) { // check if integration interval is too wide if (PrecisionIndex == 0) { FatalError("Laplace method failed. Peak width too high in function CWalleniusNCHypergeometric::laplace"); break;} PrecisionIndex--; // reduce precision to keep integration interval narrow } erfresp = ErfRes[PrecisionIndex]; // choose desired table degree = MAXDEG; // max expansion degree if (degree >= ERFRES_L*2) degree = ERFRES_L*2-2; // set up for starting loop at k=3 v2m2 = 0.25 * vr * vr; // (2*v)^(-2) PSIderi[0] = 1.; pow2k = 8.; sum = 0.5 * vr * erfresp[0]; v2mk1 = 0.5 * vr * v2m2 * v2m2; accur = accuracy * sum; // summation loop for (k = 3; k <= degree; k++) { phideri[k] = 0.; // loop for all (2) colors for (i = 0; i < COLORS; i++) { eta[i][k] = 0.; // backward loop for all powers for (j = k; j > 0; j--) { // find coefficients recursively from previous coefficients eta[i][j] = eta[i][j]*(j*rho[i]-(k-2)) + eta[i][j-1]*rho[i]*(j-1); } qqpow = 1.; // forward loop for all powers for (j=1; j<=k; j++) { qqpow *= qq[i]; // qq^j // contribution to derivative phideri[k] += xi[i] * eta[i][j] * qqpow; } } // finish calculation of derivatives phideri[k] = -pow2k*phideri[k] + 2*(1-k)*phideri[k-1]; pow2k *= 2.; // 2^k // loop to calculate derivatives of PSI from derivatives of psi. // terms # 0, 1, 2, k-2, and k-1 are zero and not included in loop. // The j'th derivatives of psi are identical to the derivatives of phi for j>2, and // zero for j=1,2. Hence we are using phideri[j] for j>2 here. PSIderi[k] = phideri[k]; // this is term # k bino = 0.5 * (k-1) * (k-2); // binomial coefficient for term # 3 for (j = 3; j < k-2; j++) { // loop for remaining nonzero terms (if k>5) PSIderi[k] += PSIderi[k-j] * phideri[j] * bino; bino *= double(k-j)/double(j); } if ((k & 1) == 0) { // only for even k ll = k/2; s = PSIderi[k] * v2mk1 * erfresp[ll]; sum += s; // check for convergence of Taylor expansion if (fabs(s) < accur) converg++; else converg = 0; if (converg > 1) break; // update recursive expressions v2mk1 *= v2m2; } } // multiply by terms outside integral return f0 * sum; } double CWalleniusNCHypergeometric::integrate() { // Wallenius non-central hypergeometric distribution function // calculation by numerical integration with variable-length steps // NOTE: findpars() must be called before this function. double s; // result of integration step double sum; // integral double ta, tb; // subinterval for integration step lnbico(); // compute log of binomial coefficients // choose method: if (w < 0.02 || (w < 0.1 && (x==m || n-x==N-m) && accuracy > 1E-6)) { // normal method. Step length determined by peak width w double delta, s1; s1 = accuracy < 1E-9 ? 0.5 : 1.; delta = s1 * w; // integration steplength ta = 0.5 + 0.5 * delta; sum = integrate_step(1.-ta, ta); // first integration step around center peak do { tb = ta + delta; if (tb > 1.) tb = 1.; s = integrate_step(ta, tb); // integration step to the right of peak s += integrate_step(1.-tb,1.-ta);// integration step to the left of peak sum += s; if (s < accuracy * sum) break; // stop before interval finished if accuracy reached ta = tb; if (tb > 0.5 + w) delta *= 2.; // increase step length far from peak } while (tb < 1.); } else { // difficult situation. Step length determined by inflection points double t1, t2, tinf, delta, delta1; sum = 0.; // do left and right half of integration interval separately: for (t1=0., t2=0.5; t1 < 1.; t1+=0.5, t2+=0.5) { // integrate from 0 to 0.5 or from 0.5 to 1 tinf = search_inflect(t1, t2); // find inflection point delta = tinf - t1; if (delta > t2 - tinf) delta = t2 - tinf; // distance to nearest endpoint delta *= 1./7.; // 1/7 will give 3 steps to nearest endpoint if (delta < 1E-4) delta = 1E-4; delta1 = delta; // integrate from tinf forwards to t2 ta = tinf; do { tb = ta + delta1; if (tb > t2 - 0.25*delta1) tb = t2; // last step of this subinterval s = integrate_step(ta, tb); // integration step sum += s; delta1 *= 2; // double steplength if (s < sum * 1E-4) delta1 *= 8.; // large step when s small ta = tb; } while (tb < t2); if (tinf) { // integrate from tinf backwards to t1 tb = tinf; do { ta = tb - delta; if (ta < t1 + 0.25*delta) ta = t1; // last step of this subinterval s = integrate_step(ta, tb); // integration step sum += s; delta *= 2; // double steplength if (s < sum * 1E-4) delta *= 8.; // large step when s small tb = ta;} while (ta > t1); } } } return sum * rd; } double CWalleniusNCHypergeometric::integrate_step(double ta, double tb) { // integration subprocedure used by integrate() // makes one integration step from ta to tb using Gauss-Legendre method. // result is scaled by multiplication with exp(bico) double ab, delta, tau, ltau, y, sum, taur, rdm1; int i; // define constants for Gauss-Legendre integration with IPOINTS points #define IPOINTS 8 // number of points in each integration step #if IPOINTS == 3 static const double xval[3] = {-.774596669241,0,0.774596668241}; static const double weights[3] = {.5555555555555555,.88888888888888888,.55555555555555}; #elif IPOINTS == 4 static const double xval[4] = {-0.861136311594,-0.339981043585,0.339981043585,0.861136311594}, static const double weights[4] = {0.347854845137,0.652145154863,0.652145154863,0.347854845137}; #elif IPOINTS == 5 static const double xval[5] = {-0.906179845939,-0.538469310106,0,0.538469310106,0.906179845939}; static const double weights[5] = {0.236926885056,0.478628670499,0.568888888889,0.478628670499,0.236926885056}; #elif IPOINTS == 6 static const double xval[6] = {-0.932469514203,-0.661209386466,-0.238619186083,0.238619186083,0.661209386466,0.932469514203}; static const double weights[6] = {0.171324492379,0.360761573048,0.467913934573,0.467913934573,0.360761573048,0.171324492379}; #elif IPOINTS == 8 static const double xval[8] = {-0.960289856498,-0.796666477414,-0.525532409916,-0.183434642496,0.183434642496,0.525532409916,0.796666477414,0.960289856498}; static const double weights[8] = {0.10122853629,0.222381034453,0.313706645878,0.362683783378,0.362683783378,0.313706645878,0.222381034453,0.10122853629}; #elif IPOINTS == 12 static const double xval[12] = {-0.981560634247,-0.90411725637,-0.769902674194,-0.587317954287,-0.367831498998,-0.125233408511,0.125233408511,0.367831498998,0.587317954287,0.769902674194,0.90411725637,0.981560634247}; static const double weights[12]= {0.0471753363866,0.106939325995,0.160078328543,0.203167426723,0.233492536538,0.249147045813,0.249147045813,0.233492536538,0.203167426723,0.160078328543,0.106939325995,0.0471753363866}; #elif IPOINTS == 16 static const double xval[16] = {-0.989400934992,-0.944575023073,-0.865631202388,-0.755404408355,-0.617876244403,-0.458016777657,-0.281603550779,-0.0950125098376,0.0950125098376,0.281603550779,0.458016777657,0.617876244403,0.755404408355,0.865631202388,0.944575023073,0.989400934992}; static const double weights[16]= {0.027152459411,0.0622535239372,0.0951585116838,0.124628971256,0.149595988817,0.169156519395,0.182603415045,0.189450610455,0.189450610455,0.182603415045,0.169156519395,0.149595988817,0.124628971256,0.0951585116838,0.0622535239372,0.027152459411}; #else #error // IPOINTS must be a value for which the tables are defined #endif delta = 0.5 * (tb - ta); ab = 0.5 * (ta + tb); rdm1 = rd - 1.; sum = 0; for (i = 0; i < IPOINTS; i++) { tau = ab + delta * xval[i]; ltau = log(tau); taur = r * ltau; // possible loss of precision due to subtraction here: y = log1pow(taur*omega,x) + log1pow(taur,n-x) + rdm1*ltau + bico; if (y > -50.) sum += weights[i] * exp(y); } return delta * sum; } double CWalleniusNCHypergeometric::search_inflect(double t_from, double t_to) { // search for an inflection point of the integrand PHI(t) in the interval // t_from < t < t_to const int COLORS = 2; // number of colors double t, t1; // independent variable double rho[COLORS]; // r*omega[i] double q; // t^rho[i] / (1-t^rho[i]) double q1; // 1-t^rho[i] double xx[COLORS]; // x[i] double zeta[COLORS][4][4]; // zeta[i,j,k] coefficients double phi[4]; // derivatives of phi(t) = log PHI(t) double Z2; // PHI''(t)/PHI(t) double Zd; // derivative in Newton Raphson iteration double rdm1; // r * d - 1 double tr; // 1/t double log2t; // log2(t) double method; // 0 for z2'(t) method, 1 for z3(t) method int i; // color int iter; // count iterations rdm1 = rd - 1.; if (t_from == 0 && rdm1 <= 1.) return 0.; //no inflection point rho[0] = r*omega; rho[1] = r; xx[0] = x; xx[1] = n - x; t = 0.5 * (t_from + t_to); for (i = 0; i < COLORS; i++) { // calculate zeta coefficients zeta[i][1][1] = rho[i]; zeta[i][1][2] = rho[i] * (rho[i] - 1.); zeta[i][2][2] = rho[i] * rho[i]; zeta[i][1][3] = zeta[i][1][2] * (rho[i] - 2.); zeta[i][2][3] = zeta[i][1][2] * rho[i] * 3.; zeta[i][3][3] = zeta[i][2][2] * rho[i] * 2.; } iter = 0; do { t1 = t; tr = 1. / t; log2t = log(t)*(1./LN2); phi[1] = phi[2] = phi[3] = 0.; for (i=0; i> 1; // alternate between the two methods Z2 = phi[1]*phi[1] + phi[2]; Zd = method*phi[1]*phi[1]*phi[1] + (2.+method)*phi[1]*phi[2] + phi[3]; if (t < 0.5) { if (Z2 > 0) { t_from = t; } else { t_to = t; } if (Zd >= 0) { // use binary search if Newton-Raphson iteration makes problems t = (t_from ? 0.5 : 0.2) * (t_from + t_to); } else { // Newton-Raphson iteration t -= Z2 / Zd; } } else { if (Z2 < 0) { t_from = t; } else { t_to = t; } if (Zd <= 0) { // use binary search if Newton-Raphson iteration makes problems t = 0.5 * (t_from + t_to); } else { // Newton-Raphson iteration t -= Z2 / Zd; } } if (t >= t_to) t = (t1 + t_to) * 0.5; if (t <= t_from) t = (t1 + t_from) * 0.5; if (++iter > 20) FatalError("Search for inflection point failed in function CWalleniusNCHypergeometric::search_inflect"); } while (fabs(t - t1) > 1E-5); return t; } double CWalleniusNCHypergeometric::probability(int32 x_) { // calculate probability function. choosing best method x = x_; if (x < xmin || x > xmax) return 0.; if (xmin == xmax) return 1.; if (omega == 1.) { // hypergeometric return exp(lnbico() + LnFac(n) + LnFac(N-n) - LnFac(N)); } if (omega == 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in CWalleniusNCHypergeometric::probability"); return x == 0; } int32 x2 = n - x; int32 x0 = x < x2 ? x : x2; int em = (x == m || x2 == N-m); if (x0 == 0 && n > 500) { return binoexpand(); } if (double(n)*x0 < 1000 || (double(n)*x0 < 10000 && (N > 1000.*n || em))) { return recursive(); } if (x0 <= 1 && N-n <= 1) { return binoexpand(); } findpars(); if (w < 0.04 && E < 10 && (!em || w > 0.004)) { return laplace(); } return integrate(); } int32 CWalleniusNCHypergeometric::MakeTable(double * table, int32 MaxLength, int32 * xfirst, int32 * xlast, double cutoff) { // Makes a table of Wallenius noncentral hypergeometric probabilities // table must point to an array of length MaxLength. // The function returns 1 if table is long enough. Otherwise it fills // the table with as many correct values as possible and returns 0. // The tails are cut off where the values are < cutoff, so that // *xfirst may be > xmin and *xlast may be < xmax. // The value of cutoff will be 0.01 * accuracy if not specified. // The first and last x value represented in the table are returned in // *xfirst and *xlast. The resulting probability values are returned in // the first (*xfirst - *xlast + 1) positions of table. Any unused part // of table may be overwritten with garbage. // // The function will return the following information when MaxLength = 0: // The return value is the desired length of table. // *xfirst is 1 if it will be more efficient to call MakeTable than to call // probability repeatedly, even if only some of the table values are needed. // *xfirst is 0 if it is more efficient to call probability repeatedly. double * p1, * p2; // offset into p double mxo; // (m-x)*omega double Nmnx; // N-m-nu+x double y, y1; // probability. Save old p[x] before it is overwritten double d1, d2, dcom; // divisors in probability formula double area; // estimate of area needed for recursion method int32 xi, nu; // xi, nu = recursion values of x, n int32 x1, x2; // lowest and highest x or xi int32 i1, i2; // index into table int32 UseTable; // 1 if table method used int32 LengthNeeded; // Necessary table length // special cases if (n == 0 || m == 0) {x1 = 0; goto DETERMINISTIC;} if (n == N) {x1 = m; goto DETERMINISTIC;} if (m == N) {x1 = n; goto DETERMINISTIC;} if (omega <= 0.) { if (n > N-m) FatalError("Not enough items with nonzero weight in CWalleniusNCHypergeometric::MakeTable"); x1 = 0; DETERMINISTIC: if (MaxLength == 0) { if (xfirst) *xfirst = 1; return 1; } *xfirst = *xlast = x1; *table = 1.; return 1; } if (cutoff <= 0. || cutoff > 0.1) cutoff = 0.01 * accuracy; LengthNeeded = N - m; // m2 if (m < LengthNeeded) LengthNeeded = m; if (n < LengthNeeded) LengthNeeded = n; // LengthNeeded = min(m1,m2,n) area = double(n)*LengthNeeded; // Estimate calculation time for table method UseTable = area < 5000. || (area < 10000. && N > 1000. * n); if (MaxLength <= 0) { // Return UseTable and LengthNeeded if (xfirst) *xfirst = UseTable; i1 = LengthNeeded + 2; // Necessary table length if (!UseTable && i1 > 200) { // Calculate necessary table length from standard deviation double sd = sqrt(variance()); // calculate approximate standard deviation // estimate number of standard deviations to include from normal distribution i2 = (int32)(NumSD(accuracy) * sd + 0.5); if (i1 > i2) i1 = i2; } return i1; } if (UseTable && MaxLength > LengthNeeded) { // use recursion table method p1 = p2 = table + 1; // make space for p1[-1] p1[-1] = 0.; p1[0] = 1.; // initialize for recursion x1 = x2 = 0; for (nu = 1; nu <= n; nu++) { if (n - nu < xmin - x1 || p1[x1] < cutoff) { x1++; // increase lower limit when breakpoint passed or probability negligible p2--; // compensate buffer offset in order to reduce storage space } if (x2 < xmax && p1[x2] >= cutoff) { x2++; y1 = 0.; // increase upper limit until x has been reached } else { y1 = p1[x2]; } if (p2 - table + x2 >= MaxLength || x1 > x2) { goto ONE_BY_ONE; // Error: table length exceeded. Use other method } mxo = (m-x2)*omega; Nmnx = N-m-nu+x2+1; for (xi = x2; xi >= x1; xi--) { // backwards loop d2 = mxo + Nmnx; mxo += omega; Nmnx--; d1 = mxo + Nmnx; dcom = 1. / (d1 * d2); // save a division by making common divisor y = p1[xi-1]*mxo*d2*dcom + y1*(Nmnx+1)*d1*dcom; y1 = p1[xi-1]; // (warning: pointer alias, can't swap instruction order) p2[xi] = y; } p1 = p2; } // return results i1 = i2 = x2 - x1 + 1; // desired table length if (i2 > MaxLength) i2 = MaxLength; // limit table length *xfirst = x1; *xlast = x1 + i2 - 1; if (i2 > 0) memmove(table, table+1, i2*sizeof(table[0]));// copy to start of table return i1 == i2; // true if table size not reduced } else { // Recursion method would take too much time // Calculate values one by one ONE_BY_ONE: // Start to fill table from the end and down. start with x = floor(mean) x2 = (int32)mean(); x1 = x2 + 1; i1 = MaxLength; while (x1 > xmin) { // loop for left tail x1--; i1--; y = probability(x1); table[i1] = y; if (y < cutoff) break; if (i1 == 0) break; } *xfirst = x1; i2 = x2 - x1 + 1; if (i1 > 0 && i2 > 0) { // move numbers down to beginning of table memmove(table, table+i1, i2*sizeof(table[0])); } // Fill rest of table from mean and up i2--; while (x2 < xmax) { // loop for right tail if (i2 == MaxLength-1) { *xlast = x2; return 0; // table full } x2++; i2++; y = probability(x2); table[i2] = y; if (y < cutoff) break; } *xlast = x2; return 1; } } /*********************************************************************** calculation methods in class CMultiWalleniusNCHypergeometric ***********************************************************************/ CMultiWalleniusNCHypergeometric::CMultiWalleniusNCHypergeometric(int32 n_, int32 * m_, double * odds_, int colors_, double accuracy_) { // constructor accuracy = accuracy_; SetParameters(n_, m_, odds_, colors_); } void CMultiWalleniusNCHypergeometric::SetParameters(int32 n_, int32 * m_, double * odds_, int colors_) { // change parameters int32 N1; int i; n = n_; m = m_; omega = odds_; colors = colors_; r = 1.; for (N = N1 = 0, i = 0; i < colors; i++) { if (m[i] < 0 || omega[i] < 0) FatalError("Parameter negative in constructor for CMultiWalleniusNCHypergeometric"); N += m[i]; if (omega[i]) N1 += m[i]; } if (N < n) FatalError("Taking more items than there are in CMultiWalleniusNCHypergeometric"); if (N1< n) FatalError("Not enough items with nonzero weight in CMultiWalleniusNCHypergeometric"); } void CMultiWalleniusNCHypergeometric::mean(double * mu) { // calculate approximate mean of multivariate Wallenius noncentral hypergeometric // distribution. Result is returned in mu[0..colors-1] double omeg[MAXCOLORS]; // scaled weights double omr; // reciprocal mean weight double t, t1; // independent variable in iteration double To, To1; // exp(t*omega[i]), 1-exp(t*omega[i]) double H; // function to find root of double HD; // derivative of H double dummy; // unused return int i; // color index int iter; // number of iterations if (n == 0) { // needs special case for (i = 0; i < colors; i++) { mu[i] = 0.; } return; } // calculate mean weight for (omr=0., i=0; i < colors; i++) omr += omega[i] * m[i]; omr = N / omr; // scale weights to make mean = 1 for (i = 0; i < colors; i++) omeg[i] = omega[i] * omr; // Newton Raphson iteration iter = 0; t = -1.; // first guess do { t1 = t; H = HD = 0.; // calculate H and HD for (i = 0; i < colors; i++) { if (omeg[i] != 0.) { To1 = pow2_1(t * (1./LN2) * omeg[i], &To); H += m[i] * To1; HD -= m[i] * omeg[i] * To; } } t -= (H-n) / HD; if (t >= 0) { t = 0.5 * t1; } if (++iter > 20) { FatalError("Search for mean failed in function CMultiWalleniusNCHypergeometric::mean"); } } while (fabs(H - n) > 1E-5); // finished iteration. Get all mu[i] for (i = 0; i < colors; i++) { if (omeg[i] != 0.) { To1 = pow2_1(t * (1./LN2) * omeg[i], &dummy); mu[i] = m[i] * To1; } else { mu[i] = 0.; } } } void CMultiWalleniusNCHypergeometric::variance(double * var, double * mean_) { // calculates approximate variance and mean of multivariate // Wallenius' noncentral hypergeometric distribution // (accuracy is not too good). // Variance is returned in variance[0..colors-1]. // Mean is returned in mean_[0..colors-1] if not NULL. // The calculation is reasonably fast. double r1, r2; double mu[MAXCOLORS]; int i; // Store mean in array mu if mean_ is NULL if (mean_ == 0) mean_ = mu; // Calculate mean mean(mean_); // Calculate variance for (i = 0; i < colors; i++) { r1 = mean_[i] * (m[i]-mean_[i]); r2 = (n-mean_[i])*(mean_[i]+N-n-m[i]); if (r1 <= 0. || r2 <= 0.) { var[i] = 0.; } else { var[i] = N*r1*r2/((N-1)*(m[i]*r2+(N-m[i])*r1)); } } } // implementations of different calculation methods double CMultiWalleniusNCHypergeometric::binoexpand(void) { // binomial expansion of integrand // only implemented for x[i] = 0 for all but one i int i, j, k; double W = 0.; // total weight for (i=j=k=0; i 1) FatalError("More than one x[i] nonzero in CMultiWalleniusNCHypergeometric::binoexpand"); return exp(FallingFactorial(m[j],n) - FallingFactorial(W/omega[j],n)); } double CMultiWalleniusNCHypergeometric::lnbico(void) { // natural log of binomial coefficients bico = 0.; int i; for (i=0; i omax) omax = omega[i]; } omaxr = 1. / omax; dd = E = 0.; for (i = 0; i < colors; i++) { // scale weights to make max = 1 omeg[i] = omega[i] * omaxr; // calculate d and E dd += omeg[i] * (m[i]-x[i]); E += omeg[i] * m[i]; } dr = 1. / dd; E *= dr; rr = r * omax; if (rr <= dr) rr = 1.2 * dr; // initial guess // Newton-Raphson iteration to find r do { lastr = rr; rrc = 1. / rr; z = dd - rrc; // z(r) zd = rrc * rrc; // z'(r) for (i=0; i 0.) { // avoid overflow and division by 0 r21 = pow2_1(rt, &r2); // r2=2^r, r21=1.-2^r a = omeg[i] / r21; // omegai/(1.-2^r) b = x[i] * a; // x*omegai/(1.-2^r) z += b; zd += b * a * r2 * LN2; } } if (zd == 0) FatalError("can't find r in function CMultiWalleniusNCHypergeometric::findpars"); rr -= z / zd; // next r if (rr <= dr) rr = lastr * 0.125 + dr * 0.875; if (++j == 70) FatalError("convergence problem searching for r in function CMultiWalleniusNCHypergeometric::findpars"); } while (fabs(rr-lastr) > rr * 1.E-5); rd = rr * dd; r = rr * omaxr; // find peak width phi2d = 0.; for (i=0; i 0.) { // avoid overflow and division by 0 k1 = pow2_1(ro, &dummy); k1 = -1. / k1; k1 = omeg[i] * omeg[i] * (k1 + k1*k1); } else k1 = 0.; phi2d += x[i] * k1; } phi2d *= -4. * rr * rr; if (phi2d > 0.) FatalError("peak width undefined in function CMultiWalleniusNCHypergeometric::findpars"); wr = sqrt(-phi2d); w = 1. / wr; } double CMultiWalleniusNCHypergeometric::laplace(void) { // Laplace's method with narrow integration interval, // using error function residues table, defined in erfres.cpp // Note that this function can only be used when the integrand peak is narrow. // findpars() must be called before this function. const int MAXDEG = 40; // arraysize int degree; // max expansion degree double accur; // stop expansion when terms below this threshold double f0; // factor outside integral double rho[MAXCOLORS]; // r*omegai double qi; // 2^(-rho) double qi1; // 1-qi double qq[MAXCOLORS]; // qi / qi1 double eta[MAXCOLORS+1][MAXDEG+1]; // eta coefficients double phideri[MAXDEG+1]; // derivatives of phi double PSIderi[MAXDEG+1]; // derivatives of PSI double * erfresp; // pointer to table of error function residues // variables in asymptotic summation static const double sqrt8 = 2.828427124746190098; // sqrt(8) double qqpow; // qq^j double pow2k; // 2^k double bino; // binomial coefficient double vr; // 1/v, v = integration interval double v2m2; // (2*v)^(-2) double v2mk1; // (2*v)^(-k-1) double s; // summation term double sum; // Taylor sum int i; // loop counter for color int j; // loop counter for derivative int k; // loop counter for expansion degree int ll; // k/2 int converg = 0; // number of consequtive terms below accuracy int PrecisionIndex; // index into ErfRes table according to desired precision // initialize for (k = 0; k <= 2; k++) phideri[k] = PSIderi[k] = 0; // find rho[i], qq[i], first eta coefficients, and zero'th derivative of phi for (i = 0; i < colors; i++) { rho[i] = r * omega[i]; if (rho[i] == 0.) continue; if (rho[i] > 40.) { qi=0.; qi1 = 1.; // avoid underflow } else { qi1 = pow2_1(-rho[i], &qi); // qi=2^(-rho), qi1=1.-2^(-rho) } qq[i] = qi / qi1; // 2^(-r*omegai)/(1.-2^(-r*omegai)) // peak = zero'th derivative phideri[0] += x[i] * log1mx(qi, qi1); // eta coefficients eta[i][0] = 0.; eta[i][1] = eta[i][2] = rho[i]*rho[i]; } // d, r, and w must be calculated by findpars() // zero'th derivative phideri[0] -= (rd - 1.) * LN2; // scaled factor outside integral f0 = rd * exp(phideri[0] + lnbico()); // calculate narrowed integration interval vr = sqrt8 * w; phideri[2] = phi2d; // get table according to desired precision PrecisionIndex = (-FloorLog2((float)accuracy) - ERFRES_B + ERFRES_S - 1) / ERFRES_S; if (PrecisionIndex < 0) PrecisionIndex = 0; if (PrecisionIndex > ERFRES_N-1) PrecisionIndex = ERFRES_N-1; while (w * NumSDev[PrecisionIndex] > 0.3) { // check if integration interval is too wide if (PrecisionIndex == 0) { FatalError("Laplace method failed. Peak width too high in function CWalleniusNCHypergeometric::laplace"); break; } PrecisionIndex--; // reduce precision to keep integration interval narrow } erfresp = ErfRes[PrecisionIndex]; // choose desired table degree = MAXDEG; // max expansion degree if (degree >= ERFRES_L*2) degree = ERFRES_L*2-2; // set up for starting loop at k=3 v2m2 = 0.25 * vr * vr; // (2*v)^(-2) PSIderi[0] = 1.; pow2k = 8.; sum = 0.5 * vr * erfresp[0]; v2mk1 = 0.5 * vr * v2m2 * v2m2; accur = accuracy * sum; // summation loop for (k = 3; k <= degree; k++) { phideri[k] = 0.; // loop for all colors for (i = 0; i < colors; i++) { if (rho[i] == 0.) continue; eta[i][k] = 0.; // backward loop for all powers for (j = k; j > 0; j--) { // find coefficients recursively from previous coefficients eta[i][j] = eta[i][j]*(j*rho[i]-(k-2)) + eta[i][j-1]*rho[i]*(j-1); } qqpow = 1.; // forward loop for all powers for (j = 1; j <= k; j++) { qqpow *= qq[i]; // qq^j // contribution to derivative phideri[k] += x[i] * eta[i][j] * qqpow; } } // finish calculation of derivatives phideri[k] = -pow2k * phideri[k] + 2*(1-k)*phideri[k-1]; pow2k *= 2.; // 2^k // loop to calculate derivatives of PSI from derivatives of psi. // terms # 0, 1, 2, k-2, and k-1 are zero and not included in loop. // The j'th derivatives of psi are identical to the derivatives of phi for j>2, and // zero for j=1,2. Hence we are using phideri[j] for j>2 here. PSIderi[k] = phideri[k]; // this is term # k bino = 0.5 * (k-1) * (k-2); // binomial coefficient for term # 3 for (j=3; j < k-2; j++) { // loop for remaining nonzero terms (if k>5) PSIderi[k] += PSIderi[k-j] * phideri[j] * bino; bino *= double(k-j)/double(j); } if ((k & 1) == 0) { // only for even k ll = k/2; s = PSIderi[k] * v2mk1 * erfresp[ll]; sum += s; // check for convergence of Taylor expansion if (fabs(s) < accur) converg++; else converg = 0; if (converg > 1) break; // update recursive expressions v2mk1 *= v2m2; } } // multiply by terms outside integral return f0 * sum; } double CMultiWalleniusNCHypergeometric::integrate(void) { // Wallenius non-central hypergeometric distribution function // calculation by numerical integration with variable-length steps // NOTE: findpars() must be called before this function. double s; // result of integration step double sum; // integral double ta, tb; // subinterval for integration step lnbico(); // compute log of binomial coefficients // choose method: if (w < 0.02) { // normal method. Step length determined by peak width w double delta, s1; s1 = accuracy < 1E-9 ? 0.5 : 1.; delta = s1 * w; // integration steplength ta = 0.5 + 0.5 * delta; sum = integrate_step(1.-ta, ta); // first integration step around center peak do { tb = ta + delta; if (tb > 1.) tb = 1.; s = integrate_step(ta, tb); // integration step to the right of peak s += integrate_step(1.-tb,1.-ta);// integration step to the left of peak sum += s; if (s < accuracy * sum) break; // stop before interval finished if accuracy reached ta = tb; if (tb > 0.5 + w) delta *= 2.; // increase step length far from peak } while (tb < 1.); } else { // difficult situation. Step length determined by inflection points double t1, t2, tinf, delta, delta1; sum = 0.; // do left and right half of integration interval separately: for (t1=0., t2=0.5; t1 < 1.; t1+=0.5, t2+=0.5) { // integrate from 0 to 0.5 or from 0.5 to 1 tinf = search_inflect(t1, t2); // find inflection point delta = tinf - t1; if (delta > t2 - tinf) delta = t2 - tinf; // distance to nearest endpoint delta *= 1./7.; // 1/7 will give 3 steps to nearest endpoint if (delta < 1E-4) delta = 1E-4; delta1 = delta; // integrate from tinf forwards to t2 ta = tinf; do { tb = ta + delta1; if (tb > t2 - 0.25*delta1) tb = t2; // last step of this subinterval s = integrate_step(ta, tb); // integration step sum += s; delta1 *= 2; // double steplength if (s < sum * 1E-4) delta1 *= 8.; // large step when s small ta = tb; } while (tb < t2); if (tinf) { // integrate from tinf backwards to t1 tb = tinf; do { ta = tb - delta; if (ta < t1 + 0.25*delta) ta = t1; // last step of this subinterval s = integrate_step(ta, tb); // integration step sum += s; delta *= 2; // double steplength if (s < sum * 1E-4) delta *= 8.; // large step when s small tb = ta; } while (ta > t1); } } } return sum * rd; } double CMultiWalleniusNCHypergeometric::integrate_step(double ta, double tb) { // integration subprocedure used by integrate() // makes one integration step from ta to tb using Gauss-Legendre method. // result is scaled by multiplication with exp(bico) double ab, delta, tau, ltau, y, sum, taur, rdm1; int i, j; // define constants for Gauss-Legendre integration with IPOINTS points #define IPOINTS 8 // number of points in each integration step #if IPOINTS == 3 static const double xval[3] = {-.774596669241,0,0.774596668241}; static const double weights[3] = {.5555555555555555,.88888888888888888,.55555555555555}; #elif IPOINTS == 4 static const double xval[4] = {-0.861136311594,-0.339981043585,0.339981043585,0.861136311594}, static const double weights[4] = {0.347854845137,0.652145154863,0.652145154863,0.347854845137}; #elif IPOINTS == 5 static const double xval[5] = {-0.906179845939,-0.538469310106,0,0.538469310106,0.906179845939}; static const double weights[5] = {0.236926885056,0.478628670499,0.568888888889,0.478628670499,0.236926885056}; #elif IPOINTS == 6 static const double xval[6] = {-0.932469514203,-0.661209386466,-0.238619186083,0.238619186083,0.661209386466,0.932469514203}; static const double weights[6] = {0.171324492379,0.360761573048,0.467913934573,0.467913934573,0.360761573048,0.171324492379}; #elif IPOINTS == 8 static const double xval[8] = {-0.960289856498,-0.796666477414,-0.525532409916,-0.183434642496,0.183434642496,0.525532409916,0.796666477414,0.960289856498}; static const double weights[8] = {0.10122853629,0.222381034453,0.313706645878,0.362683783378,0.362683783378,0.313706645878,0.222381034453,0.10122853629}; #elif IPOINTS == 12 static const double xval[12] = {-0.981560634247,-0.90411725637,-0.769902674194,-0.587317954287,-0.367831498998,-0.125233408511,0.125233408511,0.367831498998,0.587317954287,0.769902674194,0.90411725637,0.981560634247}; static const double weights[12]= {0.0471753363866,0.106939325995,0.160078328543,0.203167426723,0.233492536538,0.249147045813,0.249147045813,0.233492536538,0.203167426723,0.160078328543,0.106939325995,0.0471753363866}; #elif IPOINTS == 16 static const double xval[16] = {-0.989400934992,-0.944575023073,-0.865631202388,-0.755404408355,-0.617876244403,-0.458016777657,-0.281603550779,-0.0950125098376,0.0950125098376,0.281603550779,0.458016777657,0.617876244403,0.755404408355,0.865631202388,0.944575023073,0.989400934992}; static const double weights[16]= {0.027152459411,0.0622535239372,0.0951585116838,0.124628971256,0.149595988817,0.169156519395,0.182603415045,0.189450610455,0.189450610455,0.182603415045,0.169156519395,0.149595988817,0.124628971256,0.0951585116838,0.0622535239372,0.027152459411}; #else #error // IPOINTS must be a value for which the tables are defined #endif delta = 0.5 * (tb - ta); ab = 0.5 * (ta + tb); rdm1 = rd - 1.; sum = 0; for (j = 0; j < IPOINTS; j++) { tau = ab + delta * xval[j]; ltau = log(tau); taur = r * ltau; y = 0.; for (i = 0; i < colors; i++) { // possible loss of precision due to subtraction here: if (omega[i]) { y += log1pow(taur*omega[i],x[i]); // ln((1-e^taur*omegai)^xi) } } y += rdm1*ltau + bico; if (y > -50.) sum += weights[j] * exp(y); } return delta * sum; } double CMultiWalleniusNCHypergeometric::search_inflect(double t_from, double t_to) { // search for an inflection point of the integrand PHI(t) in the interval // t_from < t < t_to double t, t1; // independent variable double rho[MAXCOLORS]; // r*omega[i] double q; // t^rho[i] / (1-t^rho[i]) double q1; // 1-t^rho[i] double zeta[MAXCOLORS][4][4]; // zeta[i,j,k] coefficients double phi[4]; // derivatives of phi(t) = log PHI(t) double Z2; // PHI''(t)/PHI(t) double Zd; // derivative in Newton Raphson iteration double rdm1; // r * d - 1 double tr; // 1/t double log2t; // log2(t) double method; // 0 for z2'(t) method, 1 for z3(t) method int i; // color int iter; // count iterations rdm1 = rd - 1.; if (t_from == 0 && rdm1 <= 1.) return 0.; //no inflection point t = 0.5 * (t_from + t_to); for (i = 0; i < colors; i++) { // calculate zeta coefficients rho[i] = r * omega[i]; zeta[i][1][1] = rho[i]; zeta[i][1][2] = rho[i] * (rho[i] - 1.); zeta[i][2][2] = rho[i] * rho[i]; zeta[i][1][3] = zeta[i][1][2] * (rho[i] - 2.); zeta[i][2][3] = zeta[i][1][2] * rho[i] * 3.; zeta[i][3][3] = zeta[i][2][2] * rho[i] * 2.; } iter = 0; do { t1 = t; tr = 1. / t; log2t = log(t)*(1./LN2); phi[1] = phi[2] = phi[3] = 0.; for (i=0; i> 1; // alternate between the two methods Z2 = phi[1]*phi[1] + phi[2]; Zd = method*phi[1]*phi[1]*phi[1] + (2.+method)*phi[1]*phi[2] + phi[3]; if (t < 0.5) { if (Z2 > 0) { t_from = t; } else { t_to = t; } if (Zd >= 0) { // use binary search if Newton-Raphson iteration makes problems t = (t_from ? 0.5 : 0.2) * (t_from + t_to); } else { // Newton-Raphson iteration t -= Z2 / Zd; } } else { if (Z2 < 0) { t_from = t; } else { t_to = t; } if (Zd <= 0) { // use binary search if Newton-Raphson iteration makes problems t = 0.5 * (t_from + t_to); } else { // Newton-Raphson iteration t -= Z2 / Zd; } } if (t >= t_to) t = (t1 + t_to) * 0.5; if (t <= t_from) t = (t1 + t_from) * 0.5; if (++iter > 20) FatalError("Search for inflection point failed in function CMultiWalleniusNCHypergeometric::search_inflect"); } while (fabs(t - t1) > 1E-5); return t; } double CMultiWalleniusNCHypergeometric::probability(int32 * x_) { // calculate probability function. choosing best method int i, j, em; int central; int32 xsum; x = x_; for (xsum = i = 0; i < colors; i++) xsum += x[i]; if (xsum != n) { FatalError("sum of x values not equal to n in function CMultiWalleniusNCHypergeometric::probability"); } if (colors < 3) { if (colors <= 0) return 1.; if (colors == 1) return x[0] == m[0]; // colors = 2 if (omega[1] == 0.) return x[0] == m[0]; return CWalleniusNCHypergeometric(n,m[0],N,omega[0]/omega[1],accuracy).probability(x[0]); } central = 1; for (i = j = em = 0; i < colors; i++) { if (x[i] > m[i] || x[i] < 0 || x[i] < n - N + m[i]) return 0.; if (x[i] > 0) j++; if (omega[i] == 0. && x[i]) return 0.; if (x[i] == m[i] || omega[i] == 0.) em++; if (i > 0 && omega[i] != omega[i-1]) central = 0; } if (n == 0 || em == colors) return 1.; if (central) { // All omega's are equal. // This is multivariate central hypergeometric distribution int32 sx = n, sm = N; double p = 1.; for (i = 0; i < colors - 1; i++) { // Use univariate hypergeometric (usedcolors-1) times p *= CWalleniusNCHypergeometric(sx, m[i], sm, 1.).probability(x[i]); sx -= x[i]; sm -= m[i]; } return p; } if (j == 1) { return binoexpand(); } findpars(); if (w < 0.04 && E < 10 && (!em || w > 0.004)) { return laplace(); } return integrate(); } /*********************************************************************** Methods for CMultiWalleniusNCHypergeometricMoments ***********************************************************************/ double CMultiWalleniusNCHypergeometricMoments::moments(double * mu, double * variance, int32 * combinations) { // calculates mean and variance of multivariate Wallenius noncentral // hypergeometric distribution by calculating all combinations of x-values. // Return value = sum of all probabilities. The deviation of this value // from 1 is a measure of the accuracy. // Returns the mean to mean[0...colors-1] // Returns the variance to variance[0...colors-1] double sumf; // sum of all f(x) values int32 msum; // temporary sum int i; // loop counter // get approximate mean mean(sx); // round mean to integers for (i=0; i < colors; i++) { xm[i] = (int32)(sx[i]+0.4999999); } // set up for recursive loops for (i=colors-1, msum=0; i >= 0; i--) { remaining[i] = msum; msum += m[i]; } for (i=0; i n) xmax = n; x0 = xm[c]; if (x0 < xmin) x0 = xmin; if (x0 > xmax) x0 = xmax; // loop for all x[c] from mean and up for (x = x0, s2 = 0.; x <= xmax; x++) { xi[c] = x; sum += s1 = loop(n-x, c+1); // recursive loop for remaining colors if (s1 < accuracy && s1 < s2) break; // stop when values become negligible s2 = s1; } // loop for all x[c] from mean and down for (x = x0-1; x >= xmin; x--) { xi[c] = x; sum += s1 = loop(n-x, c+1); // recursive loop for remaining colors if (s1 < accuracy && s1 < s2) break; // stop when values become negligible s2 = s1; } } else { // last color xi[c] = n; s1 = probability(xi); for (i=0; i < colors; i++) { sx[i] += s1 * xi[i]; sxx[i] += s1 * xi[i] * xi[i]; } sn++; sum = s1; } return sum; } BiasedUrn/src/urn2.cpp0000644000176200001440000013413612640160171014315 0ustar liggesusers/*************************** urn2.cpp ********************************** * Author: Agner Fog * Date created: 2006 * Last modified: 2011-08-05 * Project: BiasedUrn * Source URL: www.agner.org/random * * Description: * R interface to multivariate noncentral hypergeometric distributions * * Copyright 2006-2011 by Agner Fog. * GNU General Public License http://www.gnu.org/licenses/gpl.html *****************************************************************************/ #include #include #include "stocc.h" /****************************************************************************** dMFNCHypergeo Mass function for Multivariate Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP dMFNCHypergeo( SEXP rx, // Number of balls drawn of each color, vector or matrix SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1 || LENGTH(rprecision) != 1) error("Parameter n has wrong length"); int nres; // Number of results if (isMatrix(rx)) { nres = ncols(rx); if (nrows(rx) != colors) error("matrix x must have one row for each color and one column for each sample"); } else { nres = 1; if (LENGTH(rx) != colors) error("Length of vectors x, m, and odds must be the same"); } // Get parameter values int32 * px = INTEGER(rx); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int N; // Total number of balls int Nu; // Total number of balls with nonzero odds int i, j; // Loop counter int xsum; // Column sum of x = n // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CMultiFishersNCHypergeometric mfnc(n, pm, podds, colors, prec); // Loop over x inputs for (i = 0; i < nres; i++) { // Calculate x sum and check each x for (xsum = j = 0; j < colors; j++) { xsum += px[j]; /* Include this if you want error messages for x < 0 and x > m if (px[j] > pm[j]) { // Error if (nres == 1) error("x[%i] = %i is bigger than m[%i] = %i", j+1, px[j], j+1, pm[j]); else error("x[%i,%i] = %i is bigger than m[%i] = %i", j+1, i+1, px[j], j+1, pm[j]); } else if (px[j] < 0) { if (nres == 1) error("x[%i] = %i is negative", j+1, px[j]); else error("x[%i,%i] = %i is negative", j+1, i+1, px[j]); } */ } // Check x sum if (xsum != n) { // Error if (nres == 1) error("sum(x) = %i must be equal to n = %i", xsum, n); else error("sum(x[,%i]) = %i must be equal to n = %i", i+1, xsum, n); } // Calculate probability presult[i] = mfnc.probability(px); // Probability // Get next column px += colors; } // Return result UNPROTECT(1); return(result); } /****************************************************************************** dMWNCHypergeo Mass function for Multivariate Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP dMWNCHypergeo( SEXP rx, // Number of balls drawn of each color, vector or matrix SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1 || LENGTH(rprecision) != 1) error("Parameter n has wrong length"); int nres; // Number of results if (isMatrix(rx)) { nres = ncols(rx); if (nrows(rx) != colors) error("matrix x must have one row for each color and one column for each sample"); } else { nres = 1; if (LENGTH(rx) != colors) error("Length of vectors x, m, and odds must be the same"); } // Get parameter values int32 * px = INTEGER(rx); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int N; // Total number of balls int Nu; // Total number of balls with nonzero odds int i, j; // Loop counter int xsum; // Column sum of x = n // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Allocate result vector SEXP result; double * presult; PROTECT(result = allocVector(REALSXP, nres)); presult = REAL(result); // Make object for calculating probabilities CMultiWalleniusNCHypergeometric mwnc(n, pm, podds, colors, prec); // Loop over x inputs for (i = 0; i < nres; i++) { // Calculate x sum and check each x for (xsum = j = 0; j < colors; j++) { xsum += px[j]; /* Include this if you want error messages for x > m and x < 0 if (px[j] > pm[j]) { // Error if (nres == 1) error("x[%i] = %i is bigger than m[%i] = %i", j+1, px[j], j+1, pm[j]); else error("x[%i,%i] = %i is bigger than m[%i] = %i", j+1, i+1, px[j], j+1, pm[j]); } else if (px[j] < 0) { if (nres == 1) error("x[%i] = %i is negative", j+1, px[j]); else error("x[%i,%i] = %i is negative", j+1, i+1, px[j]); } */ } // Check x sum if (xsum != n) { // Error if (nres == 1) error("sum(x) = %i must be equal to n = %i", xsum, n); else error("sum(x[,%i]) = %i must be equal to n = %i", i+1, xsum, n); } // Calculate probability presult[i] = mwnc.probability(px); // Probability // Get next column px += colors; } // Return result UNPROTECT(1); return(result); } /****************************************************************************** rMFNCHypergeo Random variate generation function for Multivariate Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP rMFNCHypergeo( SEXP rnran, // Number of random variates desired, scalar SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1) error("Parameter n has wrong length"); if (LENGTH(rprecision) != 1) error("Parameter precision has wrong length"); // Get parameter values int nran = *INTEGER(rnran); if (LENGTH(rnran) > 1) nran = LENGTH(rnran); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i; // Loop counter int N; // Total number of balls int Nu; // Total number of balls with nonzero odds // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (nran <= 0) error("Parameter nran must be positive"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); // Allocate result vector SEXP result; int * presult; if (nran <= 1) { // One result. Make vector PROTECT(result = allocVector(INTSXP, colors)); } else { // Multiple results. Make matrix PROTECT(result = allocMatrix(INTSXP, colors, nran)); } presult = INTEGER(result); // Make object for generating variates StochasticLib3 sto(0); // Seed is not used sto.SetAccuracy(prec); // Set precision sto.InitRan(); // Initialize RNG in R.dll // Generate variates one by one for (i = 0; i < nran; i++) { sto.MultiFishersNCHyp(presult, pm, podds, n, colors); // Generate variate presult += colors; // Point to next column in matrix } sto.EndRan(); // Return RNG state to R.dll // Return result UNPROTECT(1); return(result); } /****************************************************************************** rMWNCHypergeo Random variate generation function for Multivariate Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP rMWNCHypergeo( SEXP rnran, // Number of random variates desired, scalar SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1) error("Parameter n has wrong length"); if (LENGTH(rprecision) != 1) error("Parameter precision has wrong length"); // Get parameter values int nran = *INTEGER(rnran); if (LENGTH(rnran) > 1) nran = LENGTH(rnran); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i; // Loop counter int N; // Total number of balls int Nu; // Total number of balls with nonzero odds // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (nran <= 0) error("Parameter nran must be positive"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 1E-7; // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); // Allocate result vector SEXP result; int * presult; if (nran <= 1) { // One result. Make vector PROTECT(result = allocVector(INTSXP, colors)); } else { // Multiple results. Make matrix PROTECT(result = allocMatrix(INTSXP, colors, nran)); } presult = INTEGER(result); // Make object for generating variates StochasticLib3 sto(0); // Seed is not used sto.SetAccuracy(prec); // Set precision sto.InitRan(); // Initialize RNG in R.dll // Generate variates one by one for (i = 0; i < nran; i++) { sto.MultiWalleniusNCHyp(presult, pm, podds, n, colors); // Generate variate presult += colors; // Point to next column in matrix } sto.EndRan(); // Return RNG state to R.dll // Return result UNPROTECT(1); return(result); } /****************************************************************************** momentsMFNCHypergeo Calculates the mean and variance of the Multivariate Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP momentsMFNCHypergeo( SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1) error("Parameter n has wrong length"); if (LENGTH(rprecision) != 1) error("Parameter precision has wrong length"); // Get parameter values int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i; // Loop counter int N; // Total number of balls int Nu; // Total number of balls with nonzero odds // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (!R_FINITE(prec) || prec < 0) prec = 1; // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); // Allocate result vector SEXP result; double * presult; PROTECT(result = allocMatrix(REALSXP, colors, 2)); presult = REAL(result); // Make object for calculating mean and variance CMultiFishersNCHypergeometric mfnc(n, pm, podds, colors, prec); if (prec >= 0.1) { // use approximate calculation methods mfnc.variance(presult + colors, presult); } else { // use exact calculation mfnc.moments(presult, presult + colors); } // Return result UNPROTECT(1); return(result); } /****************************************************************************** momentsMWNCHypergeo Calculates the mean and variance of the Multivariate Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ REXPORTS SEXP momentsMWNCHypergeo( SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rodds, // Odds for each color, vector SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } if (LENGTH(rn) != 1) error("Parameter n has wrong length"); if (LENGTH(rprecision) != 1) error("Parameter precision has wrong length"); // Get parameter values int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i; // Loop counter int N; // Total number of balls int Nu; // Total number of balls with nonzero odds // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (!R_FINITE(prec) || prec < 0) prec = 1; // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) error("Length of odds vector must match length of m vector"); } // Get N = sum(m) and check validity of m and odds for (N = Nu = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if (podds[i]) Nu += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); } if (n > N) error ("n > sum(m): Taking more items than there are"); if (n > Nu) error ("Not enough items with nonzero odds"); // Allocate result vector SEXP result; double * presult; PROTECT(result = allocMatrix(REALSXP, colors, 2)); presult = REAL(result); // Make object for calculating mean and variance CMultiWalleniusNCHypergeometricMoments mwnc(n, pm, podds, colors, prec); if (prec >= 0.1) { // use approximate calculation methods mwnc.variance(presult + colors, presult); } else { // use exact calculation mwnc.moments(presult, presult + colors); } // Return result UNPROTECT(1); return(result); } /****************************************************************************** oddsMFNCHypergeo Estimate odds ratio from mean for the Multivariate Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ // Uses the multivariate extension of Cornfield's approximation. // Precision is ignored REXPORTS SEXP oddsMFNCHypergeo( SEXP rmu, // Number of balls drawn of each color, vector or matrix SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } int nres; // Number of results if (isMatrix(rmu)) { nres = ncols(rmu); if (nrows(rmu) != colors) error("matrix mu must have one row for each color and one column for each sample"); } else { nres = 1; if (LENGTH(rmu) != colors) error("Length of vectors mu and m must be the same"); } // Get parameter values double *pmu = REAL(rmu); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double prec = *REAL(rprecision); int N; // Total number of balls int i, j; // Loop counter int x1, x2; // x limits int c0; // Reference color double xd0, xd1, xd2; // Used for searching for reference color double mu; // Mean double sum_mu = 0.; // Sum of means int err = 0; // Warning and error messages // Get N = sum(m) and check validity of m and odds for (N = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); sum_mu += pmu[i]; } if (n > 0 && fabs(sum_mu-n)/n > 0.1) { err |= 0x100; // sum of means should be equal to n } // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (n > N) error ("n > sum(m): Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.05) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, colors)); } else { PROTECT(result = allocMatrix(REALSXP, colors, nres)); } presult = REAL(result); // Loop over x inputs for (i = 0; i < nres; i++) { // Find the color with the highest variance to use as reference for (xd0 = 0., j = c0 = 0; j < colors; j++) { // Get limits for x[j] x1 = pm[j] + n - N; if (x1 < 0) x1 = 0; x2 = n; if (x2 > pm[j]) x2 = pm[j]; // Find max distance of mu from limits xd1 = pmu[j] - x1; xd2 = x2 - pmu[j]; if (xd1 > xd2) xd1 = xd2; if (xd1 > xd0) {xd0 = xd1; c0 = j;} } if (xd0 == 0.) { // All odds are indetermined err |= 0x10; for (j = 0; j < colors; j++) presult[j] = R_NaN; } else { // Use color c0 as reference presult[c0] = 1.; // Get odds for all colors except c0 for (j = 0; j < colors; j++) { if (j != c0) { // Get limits for x[j] x1 = pm[j] + n - N; if (x1 < 0) x1 = 0; x2 = n; if (x2 > pm[j]) x2 = pm[j]; mu = pmu[j]; // Check limits if (x1 == x2) { presult[j] = R_NaN; err |= 1; // Indetermined continue; } if (mu <= double(x1)) { if (mu == double(x1)) { presult[j] = 0.; err |= 2; // Zero continue; } presult[j] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(x2)) { if (mu == double(x2)) { presult[j] = R_PosInf; err |= 4; // Infinite continue; } presult[j] = R_NaN; err |= 8; // Out of range continue; } // Calculate odds relative to c0 presult[j] = pmu[j] * (pm[c0] - pmu[c0]) / (pmu[c0] * (pm[j] - pmu[j])); } } } presult += colors; pmu += colors; } // Check for errors if (err & 0x10) warning("All odds are indetermined"); else if (err & 8) error("mu out of range"); else if (err & 1) warning("odds is indetermined"); else { if (err & 4) warning("odds is infinite"); if (err & 2) warning("odds is zero with no precision"); } if (err & 0x100) warning("Sum of means should be equal to n"); // Return result UNPROTECT(1); return(result); } /****************************************************************************** oddsMWNCHypergeo Estimate odds ratio from mean for the Multivariate Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ // Uses Manly's approximation. Precision is ignored REXPORTS SEXP oddsMWNCHypergeo( SEXP rmu, // Number of balls drawn of each color, vector or matrix SEXP rm, // Number of balls of each color in urn, vector SEXP rn, // Number of balls drawn from urn, scalar SEXP rprecision // Precision of calculation, scalar ) { // Check number of colors int colors = LENGTH(rm); if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } int nres; // Number of results if (isMatrix(rmu)) { nres = ncols(rmu); if (nrows(rmu) != colors) error("matrix mu must have one row for each color and one column for each sample"); } else { nres = 1; if (LENGTH(rmu) != colors) error("Length of vectors mu and m must be the same"); } // Get parameter values double *pmu = REAL(rmu); int32 * pm = INTEGER(rm); int n = *INTEGER(rn); double prec = *REAL(rprecision); int N; // Total number of balls int i, j; // Loop counter int x1, x2; // x limits int c0; // Reference color double xd0, xd1, xd2; // Used for searching for reference color double mu; // Mean double sum_mu = 0.; // Sum of means int err = 0; // Warning and error messages // Get N = sum(m) and check validity of m and odds for (N = i = 0; i < colors; i++) { int32 m = pm[i]; if (m < 0) error("m[%i] < 0", i+1); N += m; if ((unsigned int)N > 2000000000) error ("Integer overflow"); sum_mu += pmu[i]; } if (n > 0 && fabs(sum_mu-n)/n > 0.1) { err |= 0x100; // sum of means should be equal to n } // Check validity of scalar parameters if (n < 0) error("Negative parameter n"); if (n > N) error ("n > sum(m): Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.02) warning ("Cannot obtain high precision"); // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, colors)); } else { PROTECT(result = allocMatrix(REALSXP, colors, nres)); } presult = REAL(result); // Loop over x inputs for (i = 0; i < nres; i++) { // Find the color with the highest variance to use as reference for (xd0 = 0., j = c0 = 0; j < colors; j++) { // Get limits for x[j] x1 = pm[j] + n - N; if (x1 < 0) x1 = 0; x2 = n; if (x2 > pm[j]) x2 = pm[j]; // Find max distance of mu from limits xd1 = pmu[j] - x1; xd2 = x2 - pmu[j]; if (xd1 > xd2) xd1 = xd2; if (xd1 > xd0) {xd0 = xd1; c0 = j;} } if (xd0 == 0.) { // All odds are indetermined err |= 0x10; for (j = 0; j < colors; j++) presult[j] = R_NaN; } else { // Use color c0 as reference presult[c0] = 1.; // Get odds for all colors except c0 for (j = 0; j < colors; j++) { if (j != c0) { // Get limits for x[j] x1 = pm[j] + n - N; if (x1 < 0) x1 = 0; x2 = n; if (x2 > pm[j]) x2 = pm[j]; mu = pmu[j]; // Check limits if (x1 == x2) { presult[j] = R_NaN; err |= 1; // Indetermined continue; } if (mu <= double(x1)) { if (mu == double(x1)) { presult[j] = 0.; err |= 2; // Zero continue; } presult[j] = R_NaN; err |= 8; // Out of range continue; } if (mu >= double(x2)) { if (mu == double(x2)) { presult[j] = R_PosInf; err |= 4; // Infinite continue; } presult[j] = R_NaN; err |= 8; // Out of range continue; } // Calculate odds relative to c0 presult[j] = log(1. - pmu[j] / pm[j]) / log(1. - pmu[c0] / pm[c0]); } } } presult += colors; pmu += colors; } // Check for errors if (err & 0x10) warning("All odds are indetermined"); else if (err & 8) error("mu out of range"); else if (err & 1) warning("odds is indetermined"); else { if (err & 4) warning("odds is infinite"); if (err & 2) warning("odds is zero with no precision"); } if (err & 0x100) warning("Sum of means should be equal to n"); // Return result UNPROTECT(1); return(result); } /****************************************************************************** numMFNCHypergeo Estimate number of balls of each color from experimental mean for Multivariate Fisher's NonCentral Hypergeometric distribution ******************************************************************************/ // Uses Cornfield's approximation. Precision is ignored. // Calculation method: Solves the multivariate Cornfield's equation by // Newton Raphson iteration with r as independent parameter. REXPORTS SEXP numMFNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rn, // Number of balls drawn from urn SEXP rN, // Number of balls in urn before sampling SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { int nres; // Number of results int colors; // Number of colors // Check for vectors if (LENGTH(rn) != 1 || LENGTH(rN) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Check mu matrix size if (isMatrix(rmu)) { nres = ncols(rmu); colors = nrows(rmu); } else { nres = 1; colors = LENGTH(rmu); } // Check number of colors if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } // Get parameter values double *pmu = REAL(rmu); int n = *INTEGER(rn); int N = *INTEGER(rN); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i, j; // Loop counter int err, err1 = 0; // Remember any error int cu = 0; // Number of colors with nonzero odds double smu; // Sum of means, reciprocal. double mu[MAXCOLORS]; // Normalized means // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) { // Size mismatch if (isMatrix(rmu)) { error("matrix mu must have one row for each color and one column for each sample"); } else { error("Length of vectors mu and odds must be the same"); } } } // Check validity of parameters if (n < 0 || N < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > N: Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.05) warning ("Cannot obtain high precision"); // Check validity of odds for (i = cu = 0; i < colors; i++) { if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); if (podds[i] > 0) cu++; } // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, colors)); } else { PROTECT(result = allocMatrix(REALSXP, colors, nres)); } presult = REAL(result); // Loop for all mu inputs for (j = 0; j < nres; j++, presult += colors, pmu += colors) { err = 0; // Make results NAN in case of error exits below for (i = 0; i < colors; i++) presult[i] = R_NaN; // Check limits if (n == 0) { err1 |= 1; // Indetermined continue; } // Check sum of mu must equal n for (i = 0, smu = 0.; i < colors; i++) smu += pmu[i]; if (smu <= 0.) { err1 |= 0x800; // Sum of means must be positive break; } if (fabs(smu - n) > 0.02 * n) { err |= 0x100; // Warning: sum not approx. equal to n } smu = n / smu; for (i = 0; i < colors; i++) { mu[i] = pmu[i] * smu; // Normalize mu } // More parameter checks if (n == N) { // Results known exactly for (i = 0; i < colors; i++) { if (podds[i] == 0 && mu[i] != 0) { err1 |= 0x10; // Out of range } else { presult[i] = mu[i]; } } continue; } // Check odds if (cu < colors || colors < 2) { for (i = 0; i < colors; i++) { if (podds[i] == 0) { if (mu[i] != 0) err1 |= 0x10; // Out of range else err1 |= 1; // Indetermined } else { if (cu == 1) presult[i] = N; // Known exactly } } continue; } // check mu within bounds for (i = 0; i < colors; i++) { if (mu[i] <= 0.) { if (mu[i] == 0.) { presult[i] = 0; err |= 2; // Zero } else { err |= 8; // Out of range } } if (mu[i] >= double(n)) { if (mu[i] == double(n)) { presult[i] = N; err |= 4; } else { err |= 8; // Out of range } } } if (err & 0x18) { // Results invalid err1 |= err; break; } // Calculate m[] double z; // Newton Raphson function value double zd; // Newton Raphson derivative of z double r, lastr; // Independent parameter in Newton Raphson iteration int niter = 0; // Number of iterations // Initial guess r = 1.; // Newton Raphson iteration do { lastr = r; // Calculate z and zd z = zd = 0.; for (i = 0; i < colors; i++) { z += mu[i] * (1. + 1./(r*podds[i])); zd -= mu[i] / (podds[i]*r*r); } r -= (z - N) / zd; if (r <= 0.) { // r must be positive. Get r within range if (r < -lastr) { r = lastr * 0.125; } else { r = lastr * 0.5; } } if (++niter > 200) error ("Convergence problem"); } while (fabs(r-lastr) > r * 1E-8); // Get results from r for (i = 0; i < colors; i++) { presult[i] = mu[i] * (r*podds[i] + 1.) / (r*podds[i]); } err1 |= err; } // Check for errors if (err1 & 0x808) error("Mean is out of range"); else { if (err1 & 0x010) warning("Zero odds conflicts with nonzero mean"); if (err1 & 1) warning("Number of items is indetermined"); if (err1 & 0x100) warning("Sum of means is not equal to n"); } // Return result UNPROTECT(1); return(result); } /****************************************************************************** numMWNCHypergeo Estimate number of balls of each color from experimental mean for Multivariate Wallenius' NonCentral Hypergeometric distribution ******************************************************************************/ // Uses Manly's approximation. Precision is ignored. // Calculation method: Solves Manly's equation by // Newton Raphson iteration with theta as independent parameter. REXPORTS SEXP numMWNCHypergeo( SEXP rmu, // Observed mean of x1 SEXP rn, // Number of balls drawn from urn SEXP rN, // Number of balls in urn before sampling SEXP rodds, // Odds of getting a red ball among one red and one white SEXP rprecision // Precision of calculation ) { int nres; // Number of results int colors; // Number of colors // Check for vectors if (LENGTH(rn) != 1 || LENGTH(rN) != 1 || LENGTH(rprecision) != 1 ) { error("Parameter has wrong length"); } // Check mu matrix size if (isMatrix(rmu)) { nres = ncols(rmu); colors = nrows(rmu); } else { nres = 1; colors = LENGTH(rmu); } // Check number of colors if (colors < 1) error ("Number of colors too small"); if (colors > MAXCOLORS) { error ("Number of colors (%i) exceeds maximum (%i).\n" "You may recompile the BiasedUrn package with a bigger value of MAXCOLORS in the file Makevars.", colors, MAXCOLORS); } // Get parameter values double *pmu = REAL(rmu); int n = *INTEGER(rn); int N = *INTEGER(rN); double *podds = REAL(rodds); double prec = *REAL(rprecision); int i, j; // Loop counter int err, err1 = 0; // Remember any error int cu = 0; // Number of colors with nonzero odds double smu; // Sum of means, reciprocal. double mu[MAXCOLORS]; // Normalized means // Check if odds = 1 double OddsOne[MAXCOLORS]; // Used if odds = 1 if (LENGTH(rodds) == 1 && *podds == 1.) { // Odds = scalar 1. Set to vector of all 1's for (i = 0; i < colors; i++) OddsOne[i] = 1.; podds = OddsOne; } else { if (LENGTH(rodds) != colors) { // Size mismatch if (isMatrix(rmu)) { error("matrix mu must have one row for each color and one column for each sample"); } else { error("Length of vectors mu and odds must be the same"); } } } // Check validity of parameters if (n < 0 || N < 0) error("Negative parameter"); if ((unsigned int)N > 2000000000) error("Overflow"); if (n > N) error ("n > N: Taking more items than there are"); if (!R_FINITE(prec) || prec < 0 || prec > 1) prec = 0.1; if (prec < 0.02) warning ("Cannot obtain high precision"); // Check validity of odds for (i = cu = 0; i < colors; i++) { if (!R_FINITE(podds[i]) || podds[i] < 0) error("Invalid value for odds[%i]", i+1); if (podds[i] > 0) cu++; } // Allocate result vector SEXP result; double * presult; if (nres == 1) { PROTECT(result = allocVector(REALSXP, colors)); } else { PROTECT(result = allocMatrix(REALSXP, colors, nres)); } presult = REAL(result); // Loop for all mu inputs for (j = 0; j < nres; j++, presult += colors, pmu += colors) { err = 0; // Make results NAN in case of error exits below for (i = 0; i < colors; i++) presult[i] = R_NaN; // Check limits if (n == 0) { err1 |= 1; // Indetermined continue; } // Check sum of mu must equal n for (i = 0, smu = 0.; i < colors; i++) smu += pmu[i]; if (smu <= 0.) { err1 |= 0x800; // Sum of means must be positive break; } if (fabs(smu - n) > 0.02 * n) { err |= 0x100; // Warning: sum not approx. equal to n } smu = n / smu; for (i = 0; i < colors; i++) { mu[i] = pmu[i] * smu; // Normalize mu } // More parameter checks if (n == N) { // Results known exactly for (i = 0; i < colors; i++) { if (podds[i] == 0 && mu[i] != 0) { err1 |= 0x10; // Out of range } else { presult[i] = mu[i]; } } continue; } // Check odds if (cu < colors || colors < 2) { for (i = 0; i < colors; i++) { if (podds[i] == 0) { if (mu[i] != 0) err1 |= 0x10; // Out of range else err1 |= 1; // Indetermined } else { if (cu == 1) presult[i] = N; // Known exactly } } continue; } // check mu within bounds for (i = 0; i < colors; i++) { if (mu[i] <= 0.) { if (mu[i] == 0.) { presult[i] = 0; err |= 2; // Zero } else { err |= 8; // Out of range } } if (mu[i] >= double(n)) { if (mu[i] == double(n)) { presult[i] = N; err |= 4; } else { err |= 8; // Out of range } } } if (err & 0x18) { // Results invalid err1 |= err; break; } // Calculate m[] double z; // Newton Raphson function value double zd; // Newton Raphson derivative of z double t, lastt; // Independent parameter in Newton Raphson iteration double eot; // exp(odds[i]*t) double eot1 = 1.; // 1 - exp(odds[i]*t) int niter = 0; // Number of iterations // Initial guess t = lastt = -1.; // Newton Raphson iteration do { // Calculate z and zd AGAIN: z = zd = 0.; for (i = 0; i < colors; i++) { eot = exp(podds[i]*t); eot1 = 1. - eot; if (eot1 <= 0. || eot <= 0.) { // Out of range lastt = t; t = 0.125 * lastt; goto AGAIN; } z += mu[i] / eot1; zd += mu[i] * podds[i] * eot / (eot1*eot1); } lastt = t; t -= (z - N) / zd; if (t >= 0.) { // t must be negative. Get t within range if (t > -lastt) { t = lastt * 0.125; } else { t = lastt * 0.5; } } if (++niter > 200) error ("Convergence problem"); } while (fabs(t-lastt) > -t * 1E-8); // Get results from t for (i = 0; i < colors; i++) { presult[i] = mu[i] / (1. - exp(podds[i]*t)); } err1 |= err; } // Check for errors if (err1 & 0x808) error("Mean is out of range"); else { if (err1 & 0x010) warning("Zero odds conflicts with nonzero mean"); if (err1 & 1) warning("Number of items is indetermined"); if (err1 & 0x100) warning("Sum of means is not equal to n"); } // Return result UNPROTECT(1); return(result); } BiasedUrn/NAMESPACE0000644000176200001440000000157512640160165013356 0ustar liggesusersuseDynLib(BiasedUrn) # Functions in urn1.R export(dFNCHypergeo) export(dWNCHypergeo) export(pFNCHypergeo) export(pWNCHypergeo) export(qFNCHypergeo) export(qWNCHypergeo) export(rFNCHypergeo) export(rWNCHypergeo) export(meanFNCHypergeo) export(meanWNCHypergeo) export(varFNCHypergeo) export(varWNCHypergeo) export(modeFNCHypergeo) export(modeWNCHypergeo) export(oddsFNCHypergeo) export(oddsWNCHypergeo) export(numFNCHypergeo) export(numWNCHypergeo) export(minHypergeo) export(maxHypergeo) # Functions in urn2.R export(dMFNCHypergeo) export(dMWNCHypergeo) export(rMFNCHypergeo) export(rMWNCHypergeo) export(momentsMFNCHypergeo) export(momentsMWNCHypergeo) export(meanMFNCHypergeo) export(meanMWNCHypergeo) export(varMFNCHypergeo) export(varMWNCHypergeo) export(oddsMFNCHypergeo) export(oddsMWNCHypergeo) export(numMFNCHypergeo) export(numMWNCHypergeo) export(minMHypergeo) export(maxMHypergeo) BiasedUrn/demo/0000755000176200001440000000000012640160165013053 5ustar liggesusersBiasedUrn/demo/CompareHypergeo.R0000644000176200001440000000151412640160165016270 0ustar liggesusers# CompareHypergeo.R # This demo shows the difference between the three distributions: # 1. Wallenius' noncentral hypergeometric distribution # 2. Fisher's noncentral hypergeometric distribution # 3. The (central) hypergeometric distribution require(BiasedUrn) require(stats) ComparePlot <- function(m1, m2, n, odds) { xmin <- minHypergeo(m1, m2, n) xmax <- maxHypergeo(m1, m2, n) x <- xmin : xmax wnc <- dWNCHypergeo(x, m1, m2, n, odds) fnc <- dFNCHypergeo(x, m1, m2, n, odds) hyp <- dhyper(x, m1, m2, n) plot (x, wnc, type="l", col="blue", main = "Hypergeometric distributions", sub = "Blue = Wallenius, Red = Fisher, Green = Central", xlab = "x", ylab = "Probability") points (x, fnc, type="l", col="red") points (x, hyp, type="l", col="green") } ComparePlot(80, 60, 100, 0.5) BiasedUrn/demo/OddsPrecision.R0000644000176200001440000000144612640160165015750 0ustar liggesusers# OddsPrecision.R # This demo tests the precision of the odds functions for # Wallenius' and a Fisher's noncentral hypergeometric distributions # by calculating the mean of distributions with known odds and then # estimating the odds from the means. require(BiasedUrn) require(stats) OddsEst <- function(m1, m2, n, odds) { meanW <- meanWNCHypergeo(m1, m2, n, odds, 1E-9) oddsEstW <- oddsWNCHypergeo(meanW, m1, m2, n) meanF <- meanFNCHypergeo(m1, m2, n, odds, 1E-9) oddsEstF <- oddsFNCHypergeo(meanF, m1, m2, n) list(Odds=odds, Wallenius.mean = meanW, Fisher.mean = meanF, Wallenius.estimated.odds = oddsEstW, Fisher.estimated.odds = oddsEstF, Wallenius.rel.error = (oddsEstW-odds)/odds, Fisher.rel.error = (oddsEstF-odds)/odds) } OddsEst(10, 12, 15, 0.6) BiasedUrn/demo/UrnTheory.R0000644000176200001440000000020412640160165015131 0ustar liggesusers# UrnTheory.R # This opens the file UrnTheory.pdf to explain the biased urn models. vignette("UrnTheory", package="BiasedUrn") BiasedUrn/demo/ApproxHypergeo.R0000644000176200001440000000171612640160165016157 0ustar liggesusers# ApproxHypergeo.R # This demo compares a Wallenius' and a Fisher's noncentral hypergeometric # distribution with the same mean rather than the same odds in order to # make them approximate each other better. require(BiasedUrn) require(stats) ApproxHypPlot <- function(m1, m2, n, w.odds) { xmin <- minHypergeo(m1, m2, n) xmax <- maxHypergeo(m1, m2, n) x <- xmin : xmax w.mean <- meanWNCHypergeo(m1, m2, n, w.odds) f.odds <- oddsFNCHypergeo(w.mean, m1, m2, n) wnc <- dWNCHypergeo(x, m1, m2, n, w.odds) fnc <- dFNCHypergeo(x, m1, m2, n, f.odds) fnc0 <- dFNCHypergeo(x, m1, m2, n, w.odds) plot (x, fnc, type="l", col="red", main = "Hypergeometric distributions", sub = "Blue = Wallenius, Red = Fisher w. same mean,\n Green = Fisher w. same odds", xlab = "", ylab = "Probability") points (x, wnc, type="l", col="blue") points (x, fnc0, type="l", col="green", lty="dashed") } ApproxHypPlot(80, 60, 100, 0.5) BiasedUrn/demo/SampleWallenius.R0000644000176200001440000000214012640160165016300 0ustar liggesusers# SampleWallenius.R # This demo makes random samples from Wallenius' noncentral hypergeometric # distribution and compares measured and expected frequencies require(BiasedUrn) require(stats) MakeSamples <- function(m1, m2, n, odds) { nsamp <- 100000 # Desired number of samples from distribution xmin <- minHypergeo(m1, m2, n) # Lower limit for x xmax <- maxHypergeo(m1, m2, n) # Upper limit for x # Make nsamp samples from Wallenius' distribution X <- rWNCHypergeo(nsamp, m1, m2, n, odds) # Get table of frequencies XTab <- as.data.frame(table(X)) # Relative frequencies XTab$Freq <- XTab$Freq / nsamp # Get expected frequencies XTab$Expected <- dWNCHypergeo(as.integer(levels(XTab$X)), m1, m2, n, odds) print("X frequencies in Wallenius' noncentral hypergeometric distribution") # List measured vs. expected frequencies # (How do I get rid of the row names?) print(XTab, digits=5) # Draw histogram # (Why does my histogram show densities bigger than 1?) hist(X, freq=FALSE) } MakeSamples(6, 8, 5, 1.5)BiasedUrn/demo/00Index0000644000176200001440000000062712640160165014212 0ustar liggesusersUrnTheory Vignette explaining the distributions of biased sampling CompareHypergeo Compares different noncentral hypergeometric distributions ApproxHypergeo Compares different noncentral hypergeometric distributions with same mean rather than same odds OddsPrecision Measures precision of odds function SampleWallenius Makes random variates from Wallenius noncentral hypergeometric distribution BiasedUrn/R/0000755000176200001440000000000012640160165012330 5ustar liggesusersBiasedUrn/R/urn2.R0000644000176200001440000003323012640160165013342 0ustar liggesusers# Package BiasedUrn, file urn2.R # R interface to multivariate noncentral hypergeometric distributions # ***************************************************************************** # dMFNCHypergeo # Mass function for # Multivariate Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** dMFNCHypergeo <- function( x, # Number of balls drawn of each color, vector or matrix m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision=1E-7) { # Precision of calculation, scalar stopifnot(is.numeric(x), is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); # Convert x to integer vector or matrix without loosing dimensions: if (is.matrix(x)) { xx <- matrix(as.integer(x), nrow=dim(x)[1], ncol=dim(x)[2]); } else { xx <- as.integer(x); } .Call("dMFNCHypergeo", xx, as.integer(m), as.integer(n), as.double(odds), as.double(precision), PACKAGE = "BiasedUrn"); } # ***************************************************************************** # dMWNCHypergeo # Mass function for # Multivariate Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** dMWNCHypergeo <- function( x, # Number of balls drawn of each color, vector or matrix m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision=1E-7) { # Precision of calculation, scalar stopifnot(is.numeric(x), is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); # Convert x to integer vector or matrix without loosing dimensions: if (is.matrix(x)) { xx <- matrix(as.integer(x), nrow=dim(x)[1], ncol=dim(x)[2]); } else { xx <- as.integer(x); } .Call("dMWNCHypergeo", xx, as.integer(m), as.integer(n), as.double(odds), as.double(precision), PACKAGE = "BiasedUrn"); } # ***************************************************************************** # rMFNCHypergeo # Random variate generation function for # Multivariate Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** rMFNCHypergeo <- function(nran, m, n, odds, precision=1E-7) { stopifnot(is.numeric(nran), is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("rMFNCHypergeo", as.integer(nran), # Number of random variates desired, scalar as.integer(m), # Number of balls of each color in urn, vector as.integer(n), # Number of balls drawn from urn, scalar as.double(odds), # Odds for each color, vector as.double(precision), # Precision of calculation, scalar PACKAGE = "BiasedUrn"); } # ***************************************************************************** # rMWNCHypergeo # Random variate generation function for # Multivariate Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** rMWNCHypergeo <- function(nran, m, n, odds, precision=1E-7) { stopifnot(is.numeric(nran), is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("rMWNCHypergeo", as.integer(nran), # Number of random variates desired, scalar as.integer(m), # Number of balls of each color in urn, vector as.integer(n), # Number of balls drawn from urn, scalar as.double(odds), # Odds for each color, vector as.double(precision), # Precision of calculation, scalar PACKAGE = "BiasedUrn"); } # ***************************************************************************** # momentsMFNCHypergeo # Calculates the mean and variance of the # Multivariate Fisher's NonCentral Hypergeometric distribution. # Results are returned as a data frame. # ***************************************************************************** momentsMFNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar stopifnot(is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); res <- .Call("momentsMFNCHypergeo", as.integer(m), as.integer(n), as.double(odds), as.double(precision), PACKAGE = "BiasedUrn"); # Convert result to data frame colnames(res) <- list("xMean","xVariance") as.data.frame(res); } # ***************************************************************************** # momentsMWNCHypergeo # Calculates the mean and variance of the # Multivariate Wallenius' NonCentral Hypergeometric distribution. # Results are returned as a data frame. # ***************************************************************************** momentsMWNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar stopifnot(is.numeric(m), is.numeric(n), is.numeric(odds), is.numeric(precision)); res <- .Call("momentsMWNCHypergeo", as.integer(m), as.integer(n), as.double(odds), as.double(precision), PACKAGE = "BiasedUrn"); # Convert result to data frame colnames(res) <- list("xMean","xVariance") as.data.frame(res); } # ***************************************************************************** # meanMFNCHypergeo # Calculates the mean of the # Multivariate Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** meanMFNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar momentsMFNCHypergeo(m, n, odds, precision)$xMean } # ***************************************************************************** # meanMWNCHypergeo # Calculates the mean of the # Multivariate Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** meanMWNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar momentsMWNCHypergeo(m, n, odds, precision)$xMean } # ***************************************************************************** # varMFNCHypergeo # Calculates the variance of the # Multivariate Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** varMFNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar momentsMFNCHypergeo(m, n, odds, precision)$xVariance } # ***************************************************************************** # varMWNCHypergeo # Calculates the variance of the # Multivariate Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** varMWNCHypergeo <- function( m, # Number of balls of each color in urn, vector n, # Number of balls drawn from urn, scalar odds, # Odds for each color, vector precision = 0.1) { # Precision of calculation, scalar momentsMWNCHypergeo(m, n, odds, precision)$xVariance } # ***************************************************************************** # oddsMFNCHypergeo # Estimate odds ratio from mean for the # Multivariate Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** # Uses Cornfield's approximation. Specified precision is ignored. oddsMFNCHypergeo <- function(mu, m, n, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(m), is.numeric(n), is.numeric(precision)); # Convert mu to double vector or matrix without loosing dimensions: if (is.matrix(mu)) { mux <- matrix(as.double(mu), nrow=dim(mu)[1], ncol=dim(mu)[2]); } else { mux <- as.double(mu); } .Call("oddsMFNCHypergeo", mux, # Observed mean of each x, vector as.integer(m), # Number of balls of each color in urn, vector as.integer(n), # Number of balls drawn from urn, scalar as.double(precision), # Precision of calculation, scalar PACKAGE = "BiasedUrn"); } # ***************************************************************************** # oddsMWNCHypergeo # Estimate odds ratio from mean for the # Multivariate Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** # Uses approximation. Specified precision is ignored. oddsMWNCHypergeo <- function(mu, m, n, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(m), is.numeric(n), is.numeric(precision)); # Convert mu to double vector or matrix without loosing dimensions: if (is.matrix(mu)) { mux <- matrix(as.double(mu), nrow=dim(mu)[1], ncol=dim(mu)[2]); } else { mux <- as.double(mu); } .Call("oddsMWNCHypergeo", mux, # Observed mean of each x, vector as.integer(m), # Number of balls of each color in urn, vector as.integer(n), # Number of balls drawn from urn, scalar as.double(precision), # Precision of calculation, scalar PACKAGE = "BiasedUrn"); } # ***************************************************************************** # numMFNCHypergeo # Estimate number of balls of each color from experimental mean for # Multivariate Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** # Uses Cornfield's approximation. Specified precision is ignored. numMFNCHypergeo <- function(mu, n, N, odds, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(n), is.numeric(N), is.numeric(odds), is.numeric(precision)); # Convert mu to double vector or matrix without loosing dimensions: if (is.matrix(mu)) { mux <- matrix(as.double(mu), nrow=dim(mu)[1], ncol=dim(mu)[2]); } else { mux <- as.double(mu); } .Call("numMFNCHypergeo", mux, # Observed mean of each x, vector as.integer(n), # Number of balls drawn from urn, scalar as.integer(N), # Number of balls in urn before sampling, scalar as.double(odds), # Odds for each color, vector as.double(precision), # Precision of calculation, scalar (ignored) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # numMWNCHypergeo # Estimate number of balls of each color from experimental mean for # Multivariate Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** # Uses approximation. Specified precision is ignored. numMWNCHypergeo <- function(mu, n, N, odds, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(n), is.numeric(N), is.numeric(odds), is.numeric(precision)); # Convert mu to double vector or matrix without loosing dimensions: if (is.matrix(mu)) { mux <- matrix(as.double(mu), nrow=dim(mu)[1], ncol=dim(mu)[2]); } else { mux <- as.double(mu); } .Call("numMWNCHypergeo", mux, # Observed mean of each x, vector as.integer(n), # Number of balls drawn from urn, scalar as.integer(N), # Number of balls in urn before sampling, scalar as.double(odds), # Odds for each color, vector as.double(precision), # Precision of calculation, scalar (ignored) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # minMHypergeo # Minimum of x for central and noncentral # Multivariate Hypergeometric distributions # ***************************************************************************** # m = Number of balls of each color in urn, vector # n = Number of balls drawn from urn, scalar minMHypergeo <- function(m, n) { stopifnot(m>=0, n>=0, n<=sum(m)); pmax(n - sum(m) + m, 0); } # ***************************************************************************** # maxMHypergeo # Maximum of x for central and noncentral # Multivariate Hypergeometric distributions # ***************************************************************************** # m = Number of balls of each color in urn, vector # n = Number of balls drawn from urn, scalar maxMHypergeo <- function(m, n) { stopifnot(m>=0, n>=0, n<=sum(m)); pmin(m, n); } BiasedUrn/R/urn1.R0000644000176200001440000004272512640160165013352 0ustar liggesusers# Package BiasedUrn, file urn1.R # R interface to univariate noncentral hypergeometric distributions # ***************************************************************************** # dFNCHypergeo # Mass function, Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** dFNCHypergeo <- function(x, m1, m2, n, odds, precision=1E-7) { stopifnot(is.numeric(x), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("dFNCHypergeo", as.integer(x), # Number of red balls drawn, scalar or vector as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # dWNCHypergeo # Mass function, Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** dWNCHypergeo <- function(x, m1, m2, n, odds, precision=1E-7 ) { stopifnot(is.numeric(x), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("dWNCHypergeo", as.integer(x), # Number of red balls drawn, scalar or vector as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # pFNCHypergeo # Cumulative distribution function for # Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** pFNCHypergeo <- function(x, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) { stopifnot(is.numeric(x), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision), is.vector(lower.tail)); .Call("pFNCHypergeo", as.integer(x), # Number of red balls drawn, scalar or vector as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation as.logical(lower.tail), # TRUE: P(X <= x), FALSE: P(X > x) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # pWNCHypergeo # Cumulative distribution function for # Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** pWNCHypergeo <- function(x, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) { stopifnot(is.numeric(x), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision), is.vector(lower.tail)); .Call("pWNCHypergeo", as.integer(x), # Number of red balls drawn, scalar or vector as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation as.logical(lower.tail), # TRUE: P(X <= x), FALSE: P(X > x) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # qFNCHypergeo # Quantile function for # Fisher's NonCentral Hypergeometric distribution. # Returns the lowest x for which P(X<=x) >= p when lower.tail = TRUE # Returns the lowest x for which P(X >x) <= p when lower.tail = FALSE # ***************************************************************************** # Note: qWNCHypergeo if more accurate than qFNCHypergeo when odds = 1 qFNCHypergeo <- function(p, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) { stopifnot(is.numeric(p), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision), is.vector(lower.tail)); .Call("qFNCHypergeo", as.double(p), # Cumulative probability as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation as.logical(lower.tail), # TRUE: P(X <= x), FALSE: P(X > x) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # qWNCHypergeo # Quantile function for # Wallenius' NonCentral Hypergeometric distribution. # Returns the lowest x for which P(X<=x) >= p when lower.tail = TRUE # Returns the lowest x for which P(X >x) <= p when lower.tail = FALSE # ***************************************************************************** qWNCHypergeo <- function(p, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) { stopifnot(is.numeric(p), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision), is.vector(lower.tail)); .Call("qWNCHypergeo", as.double(p), # Cumulative probability as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation as.logical(lower.tail), # TRUE: P(X <= x), FALSE: P(X > x) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # rFNCHypergeo # Random variate generation function for # Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** rFNCHypergeo <- function(nran, m1, m2, n, odds, precision=1E-7) { stopifnot(is.numeric(nran), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("rFNCHypergeo", as.integer(nran), # Number of random variates desired as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # rWNCHypergeo # Random variate generation function for # Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** rWNCHypergeo <- function(nran, m1, m2, n, odds, precision=1E-7) { stopifnot(is.numeric(nran), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("rWNCHypergeo", as.integer(nran), # Number of random variates desired as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # meanFNCHypergeo # Calculates the mean of # Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** meanFNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=1E-7) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("momentsFNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), as.double(precision), as.integer(1), # 1 for mean, 2 for variance PACKAGE = "BiasedUrn"); } # ***************************************************************************** # meanWNCHypergeo # Calculates the mean of # Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** meanWNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=1E-7) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("momentsWNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), as.double(precision), as.integer(1), # 1 for mean, 2 for variance PACKAGE = "BiasedUrn"); } # ***************************************************************************** # varFNCHypergeo # Calculates the variance of # Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** varFNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=1E-7) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("momentsFNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), as.double(precision), as.integer(2), # 1 for mean, 2 for variance PACKAGE = "BiasedUrn"); } # ***************************************************************************** # varWNCHypergeo # Calculates the variance of # Wallenius' NonCentral Hypergeometric distribution. # ***************************************************************************** varWNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=1E-7) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("momentsWNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), as.double(precision), as.integer(2), # 1 for mean, 2 for variance PACKAGE = "BiasedUrn"); } # ***************************************************************************** # modeFNCHypergeo # Calculates the mode of # Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** # Note: The result is exact regardless of the precision parameter. # The precision parameter is included only for analogy with modeWNCHypergeo. modeFNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=0) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds)); .Call("modeFNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), PACKAGE = "BiasedUrn"); } # ***************************************************************************** # modeWNCHypergeo # Calculates the mode of # Fisher's NonCentral Hypergeometric distribution. # ***************************************************************************** modeWNCHypergeo <- function( m1, # Number of red balls in urn m2, # Number of white balls in urn n, # Number of balls drawn from urn odds, # Odds of getting a red ball among one red and one white precision=1E-7) { # Precision of calculation stopifnot(is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(odds), is.numeric(precision)); .Call("modeWNCHypergeo", as.integer(m1), as.integer(m2), as.integer(n), as.double(odds), as.double(precision), PACKAGE = "BiasedUrn"); } # ***************************************************************************** # oddsFNCHypergeo # Estimate odds ratio from mean for # Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** # Uses Cornfield's approximation. Specified precision is ignored. oddsFNCHypergeo <- function(mu, m1, m2, n, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(precision)); .Call("oddsFNCHypergeo", as.double(mu), # Observed mean of x1 as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # oddsWNCHypergeo # Estimate odds ratio from mean for # Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** oddsWNCHypergeo <- function(mu, m1, m2, n, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(m1), is.numeric(m2), is.numeric(n), is.numeric(precision)); .Call("oddsWNCHypergeo", as.double(mu), # Observed mean of x1 as.integer(m1), # Number of red balls in urn as.integer(m2), # Number of white balls in urn as.integer(n), # Number of balls drawn from urn as.double(precision), # Precision of calculation PACKAGE = "BiasedUrn"); } # ***************************************************************************** # numFNCHypergeo # Estimate number of balls of each color from experimental mean for # Fisher's NonCentral Hypergeometric distribution # ***************************************************************************** # Uses Cornfield's approximation. Specified precision is ignored. numFNCHypergeo <- function(mu, n, N, odds, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(n), is.numeric(N), is.numeric(odds), is.numeric(precision)); .Call("numFNCHypergeo", as.double(mu), # Observed mean of x1 as.integer(n), # Number of balls sampled as.integer(N), # Number of balls in urn before sampling as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation (ignored) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # numWNCHypergeo # Estimate number of balls of each color from experimental mean for # Wallenius' NonCentral Hypergeometric distribution # ***************************************************************************** # Uses approximation. Specified precision is ignored. numWNCHypergeo <- function(mu, n, N, odds, precision=0.1) { stopifnot(is.numeric(mu), is.numeric(n), is.numeric(N), is.numeric(odds), is.numeric(precision)); .Call("numWNCHypergeo", as.double(mu), # Observed mean of x1 as.integer(n), # Number of balls sampled as.integer(N), # Number of balls in urn before sampling as.double(odds), # Odds of getting a red ball among one red and one white as.double(precision), # Precision of calculation (ignored) PACKAGE = "BiasedUrn"); } # ***************************************************************************** # minHypergeo # Minimum of x for central and noncentral Hypergeometric distributions # ***************************************************************************** minHypergeo <- function(m1, m2, n) { stopifnot(m1>=0, m2>=0, n>=0, n<=m1+m2); max(n-m2, 0); } # ***************************************************************************** # maxHypergeo # Maximum of x for central and noncentral Hypergeometric distributions # ***************************************************************************** maxHypergeo <- function(m1, m2, n) { stopifnot(m1>=0, m2>=0, n>=0, n<=m1+m2); min(m1, n); } BiasedUrn/vignettes/0000755000176200001440000000000012640160171014134 5ustar liggesusersBiasedUrn/vignettes/UrnTheory.Rtex0000644000176200001440000005013712640160165016750 0ustar liggesusers\documentclass[a4paper]{article} % Note: Remember to edit the .Snw file, not the .tex file! %\VignetteIndexEntry{Biased Urn Theory} %\VignettePackage{BiasedUrn} \usepackage{amsmath} \usepackage{amssymb} % % \usepackage{c:/R/share/texmf/Sweave} \usepackage{Sweave} \begin{document} \title{Biased Urn Theory} \author{Agner Fog} \maketitle \section{Introduction} % Two different probability distributions are both known in the literature as ``the'' noncentral hypergeometric distribution. These two distributions will be called Fisher's and Wallenius' noncentral hypergeometric distribution, respectively. Both distributions can be associated with the classical experiment of taking colored balls at random from an urn without replacement. If the experiment is unbiased then the result will follow the well-known hypergeometric distribution. If the balls have different size or weight or whatever so that balls of one color have a higher probability of being taken than balls of another color then the result will be a noncentral hypergeometric distribution. The distribution depends on how the balls are taken from the urn. Wallenius' noncentral hypergeometric distribution is obtained if $n$ balls are taken one by one. Fisher's noncentral hypergeometric distribution is obtained if balls are taken independently of each other. Wallenius' distribution is used in models of natural selection and biased sampling. Fisher's distribution is used mainly for statistical tests in contingency tables. Both distributions are supported in the {\tt BiasedUrn} package. The difference between the two noncentral hypergeometric distributions is difficult to understand. I am therefore providing a detailed explanation in the following sections. \section{Definition of Wallenius' noncentral hypergeometric distribution} % Assume that an urn contains $N$ balls of $c$ different colors and let $m_i$ be the number of balls of color $i$. Balls of color $i$ have the weight $\omega_i$. $n$ balls are drawn from the urn, one by one, in such a way that the probability of taking a particular ball at a particular draw is equal to this ball's fraction of the total weight of all balls that lie in the urn at this moment. The colors of the $n$ balls that are taken in this way will follow Wallenius' noncentral hypergeometric distribution. This distribution has the probability mass function: % $$ \operatorname{dMWNCHypergeo}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \left( \prod_{i=1}^c \binom{m_i}{x_i} \right) \: \int_0^1 \prod_{i=1}^c (1-t^{{\omega_i}/{d}})^{x_i} \, \mathrm{d}t \;, $$ % $$ \text{where } \: d \:=\: \sum_{i=1}^c \omega_i(m_i-x_i) \,. $$ % $\boldsymbol{x}=(x_1,x_2,\ldots,x_c)$ is the number of balls drawn of each color.\\ $\boldsymbol{m}=(m_1,m_2,\ldots,m_c)$ is the initial number of balls of each color in the urn.\\ $\boldsymbol{\omega}=(\omega_1,\omega_2,\ldots,\omega_c)$ is the weight or odds of balls of each color.\\ $n = \sum_{i=1}^c x_i$ is the total number of balls drawn.\\ $c$ is the number of colors. The unexpected integral in this formula arises as the solution to a difference equation. (The above formula is invalid in the trivial case $n = N$.) \section{Definition of Fisher's noncentral hypergeometric distribution} % If the colored balls are taken from the urn in such a way that the probability of taking a particular ball of color $i$ is proportional to its weight $\omega_i$ and the probability for each particular ball is independent of what happens to the other balls, then the number of balls taken will follow a binomial distribution for each color. The total number of balls taken $n = \sum_{i=1}^c x_i$ is necessarily random and unknown prior to the experiment. After the experiment, we can determine $n$ and calculate the distribution of colors for the given value of $n$. This is Fisher's noncentral hypergeometric distribution, which is defined as the distribution of independent binomial variates conditional upon their sum $n$. The probability mass function of Fisher's noncentral hypergeometric distribution is given by % $$ \operatorname{dMFNCHypergeo}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \frac{\textrm{g}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega})} {\sum\limits_{\boldsymbol{y}\in \: \Xi} \textrm{g}(\boldsymbol{y};\boldsymbol{m},n,\boldsymbol{\omega})}\:, $$ % $$ \text{where } \: \textrm{g}(\boldsymbol{x};\boldsymbol{m},n,\boldsymbol{\omega}) \:=\: \prod_{i=1}^c \binom{m_i}{x_i}\omega_i^{\,x_i}\:, $$ % $$ \text{and the domain }\: \Xi \:=\: \left\{\boldsymbol{x}\in\mathbb{Z}^c \,\middle|\, \sum_{i=1}^c x_i = n \: \wedge \: \forall\, i \in [1,c] \: : \: 0 \leq x_i \leq m_i \right\}\:. $$ \section{Univariate distributions} % The univariate distributions are used when the number of colors $c$ is $2$. The multivariate distributions are used when the number of colors is more than $2$. The above formulas apply to any number of colors $c$. The univariate distributions can be expressed by setting $c=2$, $\:x_1=x$, $\:x_2=n-x$, $\:m_1=m$, $\:m_2=N-m$, $\:\omega_1=\omega$, $\:\omega_2=1$ in the above formulas. \section{Name confusion} Wallenius' and Fisher's distribution are both known in the literature as ``the'' noncentral hypergeometric distribution. Fisher's distribution was first given the name extended hypergeometric distribution, but some scientists are strongly opposed to using this name. There is a widespread confusion in the literature because these two distributions have been given the same name and because it is not obvious that they are different. Several publications have used the wrong distribution or erroneously assumed that the two distributions were identical. I am therefore recommending to use the prefixes Wallenius' and Fisher's to distinguish the two noncentral hypergeometric distributions. While this makes the names rather long, it has the advantage of emphasizing that there is more than one noncentral hypergeometric distribution, whereby the risk of confusion is minimized. Wallenius and Fisher are the names of the scientists who first described each of these two distributions. The following section explains why the two distributions are different and how to decide which distribution to use in a specific situation. \section{The difference between the two distributions} % Both distributions degenerate into the well-known hypergeometric distribution when all balls have the same weight. In other words: It doesn't matter how the balls are sampled if the balls are unbiased. Only if the urn experiment is biased can we get different distributions depending on how the balls are sampled. It is important to understand how this dependence on the sampling procedure arises. In the Wallenius model, there is competition between the balls. The probability that a particular ball is taken is lower when the other balls in the urn are heavier. The probability of taking a particular ball at a particular draw is equal to its fraction of the total weight of the balls that remain in the urn at that moment. This total weight depends on the weight of the balls that have been removed in previous draws. Therefore, each draw except the first one has a probability distribution that depends on the results of the previous draws. The fact that each draw depends on the previous draws is what makes Wallenius' distribution unique and makes the calculation of it complicated. What happens to each ball depends on what has happened to other balls in the preceding draws. In the Fisher model, there is no such dependence between draws. We may as well take all $n$ balls at the same time. Each ball has no ``knowledge'' of what happens to the other balls. For the same reason, it is impossible to know the value of $n$ before the experiment. If we tried to fix the value of $n$ then we would have no way of preventing ball number $n+1$ from being taken without violating the principle of independence between balls. $n$ is therefore a random variable and the Fisher distribution is a conditional distribution which can only be determined after the experiment when $n$ is known. The unconditional distribution is $c$ independent binomials. The difference between Wallenius' and Fisher's distributions is low when odds ratios are near 1, and $n$ is low compared to $N$. The difference between the two distributions becomes higher when odds ratios are high and $n$ is near $N$. Consider the extreme example where an urn contains one red ball with the weight 1000, and a thousand white balls each with the weight 1. We want to calculate the probability that the red ball is not taken when balls are taken one by one. The probability that the red ball is not taken in the first draw is $\frac{1000}{2000} = \frac 12$. The probability that the red ball is not taken in the second draw, under the condition that it was not taken in the first draw, is $\frac{999}{1999} \approx \frac 12$. The probability that the red ball is not taken in the third draw, under the condition that it was not taken in the first two draws, is $\frac{998}{1998} \approx \frac 12$. Continuing in this way, we can calculate that the probability of not taking the red ball in $n$ draws is approximately $2^{-n}$ for moderate values of $n$. In other words, the probability of not taking a very heavy ball in $n$ draws falls almost exponentially with $n$ in Wallenius' model. The exponential function arises because the probabilities for each draw are all multiplied together. This is not the case in Fisher's model where balls may be taken simultaneously. Here the draws are independent and the probabilities are therefore not multiplied together. The probability of not taking the heavy red ball in Fisher's model is approximately $\frac{1}{n+1}$. The two distributions are therefore very different in this extreme case. \vskip 5mm The following conditions must be fulfilled for Wallenius' distribution to be applicable: % \begin{itemize} % \item Items are taken randomly from a finite source containing different kinds of items without replacement. % \item Items are drawn one by one. % \item The probability of taking a particular item at a particular draw is equal to its fraction of the total weight of all items that have not yet been taken at that moment. The weight of an item depends only on its kind (color) $i$. (It is convenient to use the word ``weight'' for $\omega_i$ even if the physical property that determines the odds is something else than weight). % \item The total number $n$ of items to take is fixed and independent of which items happen to be taken. % \end{itemize} \vskip 5mm The following conditions must be fulfilled for Fisher's distribution to be applicable: % \begin{itemize} % \item Items are taken randomly from a finite source containing different kinds of items without replacement. % \item Items are taken independently of each other. Whether one item is taken is independent of whether another item is taken. Whether one item is taken before, after, or simultaneously with another item is irrelevant. % \item The probability of taking a particular item is proportional to its weight. The weight of an item depends only on its kind (color) $i$. % \item The total number $n$ of items that will be taken is not known before the experiment. % \item $n$ is determined after the experiment and the conditional distribution for $n$ known is desired. % \end{itemize} \section{Examples} % The following examples will further clarify which distribution to use in different situations. \subsection{Example 1} You are catching fish in a small lake that contains a limited number of fish. There are different kinds of fish with different weights. The probability of catching a particular fish is proportional to its weight when you only catch one fish. You are catching the fish one by one with a fishing rod. You have been ordered to catch $n$ fish. You are determined to catch exactly $n$ fish regardless of how long time it may take. You are stopping after you have caught $n$ fish even if you can see more fish that are tempting you. This scenario will give a distribution of the types of fish caught that is equal to Wallenius' noncentral hypergeometric distribution. \subsection{Example 2} You are catching fish as in example 1, but you are using a big net. You are setting up the net one day and coming back the next day to remove the net. You count how many fish you have caught and then you go home regardless of how many fish you have caught. Each fish has a probability of getting into the net that is proportional to its weight but independent of what happens to the other fish. This scenario gives Fisher's noncentral hypergeometric distribution after $n$ is known. \subsection{Example 3} You are catching fish with a small net. It is possible that more than one fish can go into the net at the same time. You are using the net multiple times until you have at least $n$ fish. This scenario gives a distribution that lies between Wallenius' and Fisher's distributions. The total number of fish caught can vary if you are getting too many fish in the last catch. You may put the excess fish back into the lake, but this still doesn't give Wallenius' distribution. This is because you are catching multiple fish at the same time. The condition that each catch depends on all previous catches does not hold for fish that are caught simultaneously or in the same operation. The resulting distribution will be close to Wallenius' distribution if there are only few fish in the net in each catch and you are catching many times. The resulting distribution will be close to Fisher's distribution if there are many fish in the net in each catch and you are catching few times. \subsection{Example 4} You are catching fish with a big net. Fish are swimming into the net randomly in a situation that resembles a Poisson process. You are watching the net all the time and take up the net as soon as you have caught exactly $n$ fish. The resulting distribution will be close to Fisher's distribution because the fish swim into the net independently of each other. But the fates of the fish are not totally independent because a particular fish can be saved from getting caught if $n$ other fish happen to get into the net before the time that this particular fish would have been caught. This is more likely to happen if the other fish are heavy than if they are light. \subsection{Example 5} You are catching fish one by one with a fishing rod as in example 1. You need a particular amount of fish in order to feed your family. You are stopping when the total weight of the fish you have caught exceeds a predetermined limit. The resulting distribution will be close to Wallenius' distribution, but not exactly because the decision to stop depends on the weight of the fish you have caught so far. $n$ is therefore not known exactly before the fishing trip. \subsection{Conclusion} These examples show that the distribution of the types of fish you catch depends on the way they are caught. Many situations will give a distribution that lies somewhere between Wallenius' and Fisher's noncentral hypergeometric distributions. An interesting consequence of the difference between these two distributions is that you will get more of the heavy fish, on average, if you catch $n$ fish one by one than if you catch all $n$ at the same time. These conclusions can of course be applied to biased sampling of other items than fish. \section{Applications} % The biased urn models can be applied to many different situations where items are sampled with bias and without replacement. \subsection{\tt Calculating probabilities etc.} Probabilities, mean and variance can be calculated with the appropriate functions. More complicated systems, such as the natural selection of animals, can be treated with Monte Carlo simulation, using the random variate generating functions. \subsection{\tt Measuring odds ratios} The odds of a sampling process can be measured by an experiment or a series of experiments where the number of items sampled of each kind (color) is counted. It is recommended to use sampling with replacement if possible. Sampling with replacement makes it possible to use the binomial distribution, whereby the calculation of the odds becomes simpler and more accurate. If sampling with replacement is not possible, then the procedure of sampling without replacement must be carefully controlled in order to get a pure Wallenius' distribution or a pure Fisher's distribution rather than a mixture of the two, as explained in the examples above. Use the {\tt odds} functions to calculate the odds ratios from experimental values of the mean. \subsection{\tt Estimating the number of items of a particular kind from experimental sampling} It is possible to estimate the number of items of a particular kind, for example defective items in a production, from biased sampling. The traditional procedure is to use unbiased sampling. But a model of biased sampling may be used if bias is unavoidable or if bias is desired in order to increase the probability of detecting e.g. defective items. It is recommended to use sampling with replacement if possible. Sampling with replacement makes it possible to use the binomial distribution, whereby the calculation of the number of items becomes simpler and more accurate. If sampling with replacement is not possible, then the procedure of sampling without replacement must be carefully controlled in order to get a pure Wallenius' distribution or a pure Fisher's distribution rather than a mixture of the two, as explained in the examples above. The value of the bias (odds ratio) must be determined before the numbers can be calculated. Use the functions with names beginning with ``{\tt num}'' to calculate the number of items of each kind from the result of a sampling experiment with known odds ratios. \section{Demos} % The following demos are included in the {\tt BiasedUrn} package: \subsection{\tt CompareHypergeo} % This demo shows the difference between the hypergeometric distribution and the two noncentral hypergeometric distributions by plotting the probability mass functions. \subsection{\tt ApproxHypergeo} % This demo shows shows that the two noncentral hypergeometric distributions are approximately equal when the parameters are adjusted so that they have the same mean rather than the same odds. \subsection{\tt OddsPrecision} % Calculates the precision of the {\tt oddsWNCHypergeo} and {\tt oddsFNCHypergeo} functions that are used for estimating the odds from a measured mean. \subsection{\tt SampleWallenius} % Makes 100,000 random samples from Wallenius noncentral hypergeometric distribution and compares the measured mean with the theoretical mean. \subsection{\tt UrnTheory} % Displays this document. \section{Calculation methods} % The {\tt BiasedUrn} package can calculate the univariate and multivariate Wallenius' and Fisher's noncentral hypergeometric distributions. Several different calculation methods are used, depending on the parameters. The calculation methods and sampling methods are documented at \\ {\tt http://www.agner.org/random/theory/}. \section{References} \noindent Fog, A. (2008a). Calculation Methods for Wallenius' Noncentral Hypergeometric Distribution. {\it Communications in Statistics, Simulation and Computation}. Vol. 37, no. 2, pp 258-273. \vskip 3mm % \noindent Fog, A. (2008b). Sampling Methods for Wallenius' and Fisher's Noncentral Hypergeometric Distributions. {\it Communications in Statistics, Simulation and Computation}. Vol. 37, no. 2, pp 241-257. \vskip 3mm % \noindent Johnson, N. L., Kemp, A. W. Kotz, S. (2005). {\it Univariate Discrete Distributions}. Hoboken, New Jersey: Wiley and Sons. \vskip 3mm % \noindent McCullagh, P., Nelder, J. A. (1983). {\it Generalized Linear Models}. London: Chapman \& Hall. \vskip 3mm % \noindent {\tt http://www.agner.org/random/theory/}. \end{document} BiasedUrn/MD50000644000176200001440000000272312640166105012443 0ustar liggesusers85f839c1984347af7ac5e7627045d6fe *DESCRIPTION 9fa4a3e4d963627db9d413967e9d9035 *NAMESPACE ec4aeb239b877144b70e3f3704367577 *R/urn1.R e8c596d16048677b6ffaa18704123b1b *R/urn2.R 4c54999418c75264f6cde4c74453107b *build/vignette.rds e92f1eef3885a16d9434e377add583ff *demo/00Index c6b954448030b0e8c07a378b8ce58824 *demo/ApproxHypergeo.R 0923f2e69cc488f8184b4973dd7cdd82 *demo/CompareHypergeo.R adab2da4435745974b8b256e97a50f68 *demo/OddsPrecision.R ca257d52b737cf05ab2fc234337f4b43 *demo/SampleWallenius.R b3569fe26b9aa87e6704636440db6bc2 *demo/UrnTheory.R ce2ab2b8db398976a55e06637399e0de *inst/doc/UrnTheory.Rtex 69913004cac8403c6cc2f6f6c5cccd89 *inst/doc/UrnTheory.pdf a95229ba9b90590be861c30ff444a80d *man/BiasedUrn-1-Package.Rd 97403bdfab6aaf656a4679416e22a877 *man/BiasedUrn-2-Univariate.Rd 37777167d425c4814aa40743a600faa0 *man/BiasedUrn-3-Multivariate.Rd 42ccfaba5f55a5dc2977e86c8f517bd3 *src/Makevars 1c81532e7a97515f3d4cea2f1b7f4a40 *src/erfres.h b66f879a752c7f9b2c015d80de9c5423 *src/fnchyppr.cpp d2819bb817f16c170d749808fc8ef0d9 *src/randomc.h 4bdf94a3ed6df4755cf8b1671f931329 *src/stoc1.cpp 8cd472f044c6c8f00d39d43769a9add2 *src/stoc3.cpp 07c99ea27028a3a74080d0ef829bd3e5 *src/stocR.cpp b2fb76cd6f7ec73231499db763d364bf *src/stocR.h 196790e709f48dc5809fe12148d95be5 *src/stocc.h 645795fc46d1d9c51c8ad2c045544ed3 *src/urn1.cpp 2408d260c33a7f94bafd55ea7c2bed27 *src/urn2.cpp c7ad7f6edc61c320261fcac84d20cb45 *src/wnchyppr.cpp ce2ab2b8db398976a55e06637399e0de *vignettes/UrnTheory.Rtex BiasedUrn/build/0000755000176200001440000000000012640160171013223 5ustar liggesusersBiasedUrn/build/vignette.rds0000644000176200001440000000031412640160171015560 0ustar liggesusersb```b`fbb`b2 1# ' - H/ *I@tL,NMQ*RBS^& ^̇ 9`~Ht&${+%$Q/nK׮BiasedUrn/DESCRIPTION0000644000176200001440000000133012640166105013632 0ustar liggesusersPackage: BiasedUrn Type: Package Title: Biased Urn Model Distributions Version: 1.07 Date: 2015-12-28 Author: Agner Fog Maintainer: Agner Fog Description: Statistical models of biased sampling in the form of univariate and multivariate noncentral hypergeometric distributions, including Wallenius' noncentral hypergeometric distribution and Fisher's noncentral hypergeometric distribution (also called extended hypergeometric distribution). See vignette("UrnTheory") for explanation of these distributions. License: GPL-3 URL: http://www.agner.org/random/ http://www.r-project.org Packaged: 2015-12-28 07:10:49 UTC; A NeedsCompilation: yes Repository: CRAN Date/Publication: 2015-12-28 09:01:09 BiasedUrn/man/0000755000176200001440000000000012640160165012702 5ustar liggesusersBiasedUrn/man/BiasedUrn-3-Multivariate.Rd0000644000176200001440000001713712640160165017662 0ustar liggesusers\name{BiasedUrn-Multivariate} \alias{BiasedUrn-Multivariate} \alias{dMWNCHypergeo} \alias{dMFNCHypergeo} \alias{rMWNCHypergeo} \alias{rMFNCHypergeo} \alias{meanMWNCHypergeo} \alias{meanMFNCHypergeo} \alias{varMWNCHypergeo} \alias{varMFNCHypergeo} \alias{momentsMWNCHypergeo} \alias{momentsMFNCHypergeo} \alias{oddsMWNCHypergeo} \alias{oddsMFNCHypergeo} \alias{numMWNCHypergeo} \alias{numMFNCHypergeo} \alias{minMHypergeo} \alias{maxMHypergeo} \title{Biased urn models: Multivariate distributions} \description{ Statistical models of biased sampling in the form of multivariate noncentral hypergeometric distributions, including Wallenius' noncentral hypergeometric distribution and Fisher's noncentral hypergeometric distribution (also called extended hypergeometric distribution). These are distributions that you can get when taking colored balls from an urn without replacement, with bias. The univariate distributions are used when there are two colors of balls. The multivariate distributions are used when there are more than two colors of balls. Please see \code{vignette("UrnTheory")} for a definition of these distributions and how to decide which distribution to use in a specific case. } \usage{ dMWNCHypergeo(x, m, n, odds, precision = 1E-7) dMFNCHypergeo(x, m, n, odds, precision = 1E-7) rMWNCHypergeo(nran, m, n, odds, precision = 1E-7) rMFNCHypergeo(nran, m, n, odds, precision = 1E-7) meanMWNCHypergeo(m, n, odds, precision = 0.1) meanMFNCHypergeo(m, n, odds, precision = 0.1) varMWNCHypergeo(m, n, odds, precision = 0.1) varMFNCHypergeo(m, n, odds, precision = 0.1) momentsMWNCHypergeo(m, n, odds, precision = 0.1) momentsMFNCHypergeo(m, n, odds, precision = 0.1) oddsMWNCHypergeo(mu, m, n, precision = 0.1) oddsMFNCHypergeo(mu, m, n, precision = 0.1) numMWNCHypergeo(mu, n, N, odds, precision = 0.1) numMFNCHypergeo(mu, n, N, odds, precision = 0.1) minMHypergeo(m, n) maxMHypergeo(m, n) } \arguments{ \item{x}{Number of balls of each color sampled. Vector with length = number of colors, or matrix with nrows = number of colors.} \item{m}{Initial number of balls of each color in the urn. Length of vector = number of colors.} \item{n}{Total number of balls sampled. Scalar.} \item{N}{Total number of balls in urn before sampling. Scalar.} \item{odds}{Odds or weight for each color, arbitrarily scaled. Length of vector = number of colors. Gives the (central) multivariate hypergeometric distribution if all odds are equal.} \item{nran}{Number of random variates to generate. Scalar.} \item{mu}{Mean x for each color. Length of vector = number of colors.} \item{precision}{Desired precision of calculation. Scalar.} } \details{ \bold{Allowed parameter values} \cr \code{x}, \code{m}, \code{odds} and \code{mu} are all vectors with one element for each color. These vectors must have the same length. \code{x} can also be a matrix with one column for each observation. The number of rows in this matrix must be equal to the number of colors. The maximum number of colors is currently set to 32. All parameters must be non-negative. \code{n} cannot exceed \code{N = sum(m)}. The odds may be arbitrarily scaled. The code has been tested with odds ratios in the range \eqn{10^{-9} \ldots 10^9}{1E-9 to 1E9} and zero. The code may work with odds ratios outside this range, but errors or NAN can occur for extreme values of odds. A ball with odds = 0 is equivalent to no ball. \code{mu} must be within the possible range of \code{x}. \bold{Calculation time} \cr The calculation time depends on the specified precision and the number of colors. The calculation time can be high for rMWNCHypergeo and rMFNCHypergeo when nran is high. The calculation time can be extremely high for dMFNCHypergeo when n is high and the number of colors is high. The calculation time can be extremely high for the mean... var... and moments... functions when \code{precision} < 0.1 and n is high and the number of colors is high. } \value{ \code{dMWNCHypergeo} and \code{dMFNCHypergeo} return the probability mass function for the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A single value is returned if \code{x} is a vector with length = number of colors. Multiple values are returned if \code{x} is a matrix with one column for each observation. The number of rows must be equal to the number of colors. \cr \code{rMWNCHypergeo} and \code{rMFNCHypergeo} return random vectors with the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A vector is returned when \code{nran = 1}. A matrix with one column for each observation is returned when \code{nran > 1}. \cr \code{meanMWNCHypergeo} and \code{meanMFNCHypergeo} return the mean of the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A simple and fast approximation is used when \code{precision} >= 0.1. A full calculation of all possible x combinations is used when \code{precision} < 0.1. This can take extremely long time when the number of colors is high. \cr \code{varMWNCHypergeo} and \code{varMFNCHypergeo} return the variance of the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A simple and fast approximation is used when \code{precision} >= 0.1. A full calculation of all possible x combinations is used when \code{precision} < 0.1. This can take extremely long time when the number of colors is high. \cr \code{momentsMWNCHypergeo} and \code{momentsMFNCHypergeo} return a data frame with the mean and variance of the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. Calculating the mean and variance in the same operation saves time when \code{precision} < 0.1. \cr \code{oddsMWNCHypergeo} and \code{oddsMFNCHypergeo} estimate the odds from an observed mean for the multivariate Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A vector of odds is returned if \code{mu} is a vector. A matrix is returned if \code{mu} is a matrix with one row for each color. A simple and fast approximation is used regardless of the specified precision. Exact calculation is not supported. See \code{demo(OddsPrecision)}. \cr \code{numMWNCHypergeo} and \code{numMFNCHypergeo} estimate the number of balls of each color in the urn before sampling from experimental mean and known odds ratios for Wallenius' and Fisher's noncentral hypergeometric distributions. The returned \code{m} values are not integers. A vector of \code{m} is returned if \code{mu} is a vector. A matrix of \code{m} is returned if \code{mu} is a matrix with one row for each color. A simple and fast approximation is used regardless of the specified precision. Exact calculation is not supported. The precision of calculation is indicated by \code{demo(OddsPrecision)}. \cr \code{minMHypergeo} and \code{maxMHypergeo} calculate the minimum and maximum value of \code{x} for the multivariate distributions. The values are valid for the multivariate Wallenius' and Fisher's noncentral hypergeometric distributions as well as for the multivariate (central) hypergeometric distribution. } \seealso{ \code{vignette("UrnTheory")} \cr \code{\link{BiasedUrn-Univariate}}. \cr \code{\link{BiasedUrn}}. } \examples{ # get probability dMWNCHypergeo(c(8,10,6), c(20,30,20), 24, c(1.,2.5,1.8)) } \references{ \url{http://www.agner.org/random/} } \keyword{ distribution } \keyword{ univar } \keyword{ multivariate } BiasedUrn/man/BiasedUrn-1-Package.Rd0000644000176200001440000000712412640160165016540 0ustar liggesusers\name{BiasedUrn-package} \alias{BiasedUrn} \concept{noncentral hypergeometric distribution} \concept{Wallenius' noncentral hypergeometric distribution} \concept{Fisher's noncentral hypergeometric distribution} \concept{extended hypergeometric distribution} \concept{multivariate hypergeometric distribution} \concept{biased urn model} \concept{biased sampling} \concept{evolution by natural selection} \docType{package} \title{Biased Urn Model Distributions} \description{ Statistical models of biased sampling in the form of univariate and multivariate noncentral hypergeometric distributions, including Wallenius' noncentral hypergeometric distribution and Fisher's noncentral hypergeometric distribution (also called extended hypergeometric distribution). These are distributions that you can get when taking colored balls from an urn without replacement, with bias. The univariate distributions are used when there are two colors of balls. The multivariate distributions are used when there are more than two colors of balls. The (central) univariate and multivariate hypergeometric distribution can be obtained by setting \code{odds} = 1. Please see \code{vignette("UrnTheory")} for a definition of these distributions and how to decide which distribution to use in a specific case. } \details{ \tabular{ll}{ Package: \tab BiasedUrn\cr Type: \tab Package\cr Version: \tab 1.06\cr Date: \tab 2013-11-06\cr License: \tab GPL\cr } \bold{Univariate functions in this package} \tabular{lcc}{ \tab Wallenius' noncentral hypergeometric \tab Fisher's noncentral hypergeometric \cr Probability mass function \tab dWNCHypergeo \tab dFNCHypergeo \cr Cumulative distribution function \tab pWNCHypergeo \tab pFNCHypergeo \cr Quantile function \tab qWNCHypergeo \tab qFNCHypergeo \cr Random variate generation function \tab rWNCHypergeo \tab rFNCHypergeo \cr Calculate mean \tab meanWNCHypergeo \tab meanFNCHypergeo \cr Calculate variance \tab varWNCHypergeo \tab varFNCHypergeo \cr Calculate mode \tab modeWNCHypergeo \tab modeFNCHypergeo \cr Estimate odds from mean \tab oddsWNCHypergeo \tab oddsFNCHypergeo \cr Estimate number from mean and odds \tab numWNCHypergeo \tab numFNCHypergeo \cr Minimum x \tab minHypergeo \tab minHypergeo \cr Maximum x \tab maxHypergeo \tab maxHypergeo } \bold{Multivariate functions in this package} \tabular{lcc}{ \tab Wallenius' noncentral hypergeometric \tab Fisher's noncentral hypergeometric \cr Probability mass function \tab dMWNCHypergeo \tab dMFNCHypergeo \cr Random variate generation function \tab rMWNCHypergeo \tab rMFNCHypergeo \cr Calculate mean \tab meanMWNCHypergeo \tab meanMFNCHypergeo \cr Calculate variance \tab varMWNCHypergeo \tab varMFNCHypergeo \cr Calculate mean and variance \tab momentsMWNCHypergeo \tab momentsMFNCHypergeo \cr Estimate odds from mean \tab oddsMWNCHypergeo \tab oddsMFNCHypergeo \cr Estimage number from mean and odds \tab numMWNCHypergeo \tab numMFNCHypergeo \cr Minimum x \tab minMHypergeo \tab minMHypergeo \cr Maximum x \tab maxMHypergeo \tab maxMHypergeo } } \note{The implementation cannot run safely in multiple threads simultaneously } \author{ Agner Fog Maintainer: Agner Fog } \references{ \url{http://www.agner.org/random/} } \keyword{ package } \keyword{ distribution } \keyword{ univar } \keyword{ multivariate } \seealso{ \code{vignette("UrnTheory")} \cr \code{\link{BiasedUrn-Univariate}}. \cr \code{\link{BiasedUrn-Multivariate}}. \cr \code{\link{dhyper}} \cr \code{\link{fisher.test}} } \examples{ dWNCHypergeo(12, 25, 32, 20, 2.5) } BiasedUrn/man/BiasedUrn-2-Univariate.Rd0000644000176200001440000001521612640160165017316 0ustar liggesusers\name{BiasedUrn-Univariate} \alias{BiasedUrn-Univariate} \alias{dWNCHypergeo} \alias{dFNCHypergeo} \alias{pWNCHypergeo} \alias{pFNCHypergeo} \alias{qWNCHypergeo} \alias{qFNCHypergeo} \alias{rWNCHypergeo} \alias{rFNCHypergeo} \alias{meanWNCHypergeo} \alias{meanFNCHypergeo} \alias{varWNCHypergeo} \alias{varFNCHypergeo} \alias{modeWNCHypergeo} \alias{modeFNCHypergeo} \alias{oddsWNCHypergeo} \alias{oddsFNCHypergeo} \alias{numWNCHypergeo} \alias{numFNCHypergeo} \alias{minHypergeo} \alias{maxHypergeo} \title{Biased urn models: Univariate distributions} \description{ Statistical models of biased sampling in the form of noncentral hypergeometric distributions, including Wallenius' noncentral hypergeometric distribution and Fisher's noncentral hypergeometric distribution (also called extended hypergeometric distribution). These are distributions that you can get when taking colored balls from an urn without replacement, with bias. The univariate distributions are used when there are two colors of balls. The multivariate distributions are used when there are more than two colors of balls. Please see \code{vignette("UrnTheory")} for a definition of these distributions and how to decide which distribution to use in a specific case. } \usage{ dWNCHypergeo(x, m1, m2, n, odds, precision=1E-7) dFNCHypergeo(x, m1, m2, n, odds, precision=1E-7) pWNCHypergeo(x, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) pFNCHypergeo(x, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) qWNCHypergeo(p, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) qFNCHypergeo(p, m1, m2, n, odds, precision=1E-7, lower.tail=TRUE) rWNCHypergeo(nran, m1, m2, n, odds, precision=1E-7) rFNCHypergeo(nran, m1, m2, n, odds, precision=1E-7) meanWNCHypergeo(m1, m2, n, odds, precision=1E-7) meanFNCHypergeo(m1, m2, n, odds, precision=1E-7) varWNCHypergeo(m1, m2, n, odds, precision=1E-7) varFNCHypergeo(m1, m2, n, odds, precision=1E-7) modeWNCHypergeo(m1, m2, n, odds, precision=1E-7) modeFNCHypergeo(m1, m2, n, odds, precision=0) oddsWNCHypergeo(mu, m1, m2, n, precision=0.1) oddsFNCHypergeo(mu, m1, m2, n, precision=0.1) numWNCHypergeo(mu, n, N, odds, precision=0.1) numFNCHypergeo(mu, n, N, odds, precision=0.1) minHypergeo(m1, m2, n) maxHypergeo(m1, m2, n) } \arguments{ \item{x}{Number of red balls sampled.} \item{m1}{Initial number of red balls in the urn.} \item{m2}{Initial number of white balls in the urn.} \item{n}{Total number of balls sampled.} \item{N}{Total number of balls in urn before sampling.} \item{odds}{Probability ratio of red over white balls.} \item{p}{Cumulative probability.} \item{nran}{Number of random variates to generate.} \item{mu}{Mean x.} \item{precision}{Desired precision of calculation.} \item{lower.tail}{if TRUE (default), probabilities are \eqn{P(X \le x)}{P(X <= x)}, otherwise, \eqn{P(X > x)}{P(X > x)}.} } \details{ \bold{Allowed parameter values} \cr All parameters must be non-negative. \code{n} cannot exceed \code{N = m1 + m2}. The code has been tested with odds in the range \eqn{10^{-9} \ldots 10^9}{1E-9 to 1E9} and zero. The code may work with odds outside this range, but errors or NAN can occur for extreme values of odds. A ball with odds = 0 is equivalent to no ball. \code{mu} must be within the possible range of \code{x}. \bold{Calculation time} \cr The calculation time depends on the specified precision. } \value{ \code{dWNCHypergeo} and \code{dFNCHypergeo} return the probability mass function for Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A single value is returned if \code{x} is a scalar. Multiple values are returned if \code{x} is a vector. \cr \code{pWNCHypergeo} and \code{pFNCHypergeo} return the cumulative probability function for Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A single value is returned if \code{x} is a scalar. Multiple values are returned if \code{x} is a vector. \cr \code{qWNCHypergeo} and \code{qFNCHypergeo} return the quantile function for Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A single value is returned if \code{p} is a scalar. Multiple values are returned if \code{p} is a vector. \cr \code{rWNCHypergeo} and \code{rFNCHypergeo} return random variates with Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. \cr \code{meanWNCHypergeo} and \code{meanFNCHypergeo} calculate the mean of Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A simple and fast approximation is used when \eqn{precision \geq 0.1}{precision >= 0.1}. \cr \code{varWNCHypergeo} and \code{varFNCHypergeo} calculate the variance of Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. A simple and fast approximation is used when \eqn{precision \geq 0.1}{precision >= 0.1}. \cr \code{modeWNCHypergeo} and \code{modeFNCHypergeo} calculate the mode of Wallenius' and Fisher's noncentral hypergeometric distribution, respectively. \cr \code{oddsWNCHypergeo} and \code{oddsFNCHypergeo} estimate the odds of Wallenius' and Fisher's noncentral hypergeometric distribution from a measured mean. A single value is returned if \code{mu} is a scalar. Multiple values are returned if \code{mu} is a vector. A simple and fast approximation is used regardless of the specified precision. Exact calculation is not supported. See \code{demo(OddsPrecision)}. \cr \code{numWNCHypergeo} and \code{numFNCHypergeo} estimate the number of balls of each color in the urn before sampling from an experimental mean and a known odds ratio for Wallenius' and Fisher's noncentral hypergeometric distributions. The returned numbers \code{m1} and \code{m2} are not integers. A vector of \code{m1} and \code{m2} is returned if \code{mu} is a scalar. A matrix is returned if \code{mu} is a vector. A simple approximation is used regardless of the specified precision. Exact calculation is not supported. The precision of calculation is indicated by \code{demo(OddsPrecision)}. \cr \code{minHypergeo} and \code{maxHypergeo} calculate the minimum and maximum value of \code{x}. The value is valid for Wallenius' and Fisher's noncentral hypergeometric distribution as well as for the (central) hypergeometric distribution. } \seealso{ \code{vignette("UrnTheory")} \cr \code{\link{BiasedUrn-Multivariate}}. \cr \code{\link{BiasedUrn}}. \cr \code{\link{fisher.test}} } \examples{ # get probability dWNCHypergeo(12, 25, 32, 20, 2.5) } \references{ \url{http://www.agner.org/random/} } \keyword{ distribution } \keyword{ univar }