fdrtool/0000755000176200001440000000000012547153107011730 5ustar liggesusersfdrtool/src/0000755000176200001440000000000012547036335012522 5ustar liggesusersfdrtool/src/isomean.c0000644000176200001440000000361112547036335014322 0ustar liggesusers/* isomean.c (2007-07-06) * * Copyright 2007 Korbinian Strimmer * * ported from R code originally by Kaspar Rufibach / June 2004 * * This file is part of the `fdrtool' library for R and related languages. * It is made available under the terms of the GNU General Public * License, version 2, or at your option, any later version, * incorporated herein by reference. * * This program is distributed in the hope that it will be * useful, but WITHOUT ANY WARRANTY; without even the implied * warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR * PURPOSE. See the GNU General Public License for more * details. * * You should have received a copy of the GNU General Public * License along with this program; if not, write to the Free * Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, * MA 02111-1307, USA */ #include /* * input: y measured values in a regression setting * w weights * n length of y vector (> 1) * output: ghat vector containing estimated (isotonic) values */ void C_isomean(double* y, double* w, int* n, double* ghat) { int c, j, nn; double neu; double* gew; int* k; nn = *n; /* nn > 1 */ /* allocate vector - error handling is done by R */ k = (int *) Calloc((size_t) nn, int); gew = (double *) Calloc((size_t) nn, double); c = 0; k[c] = 0; gew[c] = w[0]; ghat[c] = y[0]; for (j=1; j < nn; j++) { c = c+1; k[c] = j; gew[c] = w[j]; ghat[c] = y[j]; /* c is at least 1 as nn is > 1 */ while (ghat[c-1] >= ghat[c]) { neu = gew[c]+gew[c-1]; ghat[c-1] = ghat[c-1]+(gew[c]/neu)*(ghat[c]-ghat[c-1]); gew[c-1] = neu; c = c-1; if (c==0) break; } } while (nn >= 1) { for (j=k[c]; j < nn; j++) { ghat[j] = ghat[c]; } nn = k[c]; c = c-1; } /* free vector */ Free(k); Free(gew); } fdrtool/NAMESPACE0000644000176200001440000000104312547035660013150 0ustar liggesusersexport( "censored.fit", "dcor0", "dhalfnorm", "fdrtool", "fitted.monoreg", "fndr.cutoff", "gcmlcm", "grenander", "hc.score", "hc.thresh", "monoreg", "pcor0", "phalfnorm", "plot.grenander", "plot.monoreg", "pval.estimate.eta0", "qcor0", "qhalfnorm", "rcor0", "residuals.monoreg", "rhalfnorm", "sd2theta", "theta2sd" ) S3method("fitted", "monoreg") S3method("plot", "grenander") S3method("plot", "monoreg") S3method("residuals", "monoreg") import("graphics") import("grDevices") import("stats") useDynLib("fdrtool") fdrtool/NEWS0000644000176200001440000001466712547036271012447 0ustar liggesusers Release History of "fdrtool" Package ======================================== CHANGES IN fdrtool VERSION 1.2.15 - add import statements required by R-devel. CHANGES IN fdrtool VERSION 1.2.14 - fix broken URLs in documentation. - fix "S3 generic/method consistency" NOTE raised by R-devel. CHANGES IN fdrtool VERSION 1.2.13 - change of maintainer email address. CHANGES IN fdrtool VERSION 1.2.12 - removed DUP=FALSE option in .C() call in monoreg() as this option is depricated in R 3.1.0. CHANGES IN fdrtool VERSION 1.2.11 - depends now on R (>=2.15.1) - updated reference to Klaus and Strimmer (2013) - small changes in documentation to get rid of warnings in current R-devel - option "studentt" was removed as "normal" is preferable in most cases. CHANGES IN fdrtool VERSION 1.2.10 - added two new functions for Higher Criticism (HC): hc.score() computes HC scores from p-values and hc.thresh() determines the HC threshold for signal identification - the range of p-values (0..1) is now checked CHANGES IN fdrtool VERSION 1.2.9 - bug fix for computation of local FDR for separated null and alternative CHANGES IN fdrtool VERSION 1.2.8 - NAMESPACE file added - useDynLib() instead of .First.lib() to load compiled C code CHANGES IN fdrtool VERSION 1.2.7 - small change in gcmlcm() to make sure that the raw slope never equals Inf (to avoid numeric problems with very small p-values) CHANGES IN fdrtool VERSION 1.2.6 - a small bug was fixed in get.nullmodel()$get.pval() so that the argument Inf returns p-value 0 - in the output of censored.fit() the parameter "N0" was renamed to "N.cens" to avoid confusion with N0=eta0*N (note that N.cens is the number of data points retained for estimation) - reference to papers updated. CHANGES IN fdrtool VERSION 1.2.5 - a small bug in censored.fit() was fixed that produced NaNs when null model did not fit the data well (reported by Jana Sillmann) - obsolete method get(getOption("device"))() replaced by dev.new() - R >= 2.7.0 is now required - small updates in the documentation CHANGES IN fdrtool VERSION 1.2.4 - various warning messages were introduced to indicate potential problems with FDR computations if there are too few input test statistics (fdrtool() and related functions) CHANGES IN fdrtool VERSION 1.2.3 - the previous bug fix (v.1.2.2) unfortunately broke the optimization of FDR for correlations which necessitated a second bug fix. - small changes to the man pages. CHANGES IN fdrtool VERSION 1.2.2 - a bug was fixed in the optimization part of the censored.fit() function. CHANGES IN fdrtool VERSION 1.2.1 - option "color.figure" added, so that both color and b&w figures may be output. - a more sensible error message is now produced when the argument supplying the test statistics is not a vector. - for the option cutoff.method=="locfdr" in fdrtool() the corresponding algorithm was updated to match that of locfdr version 1.1-6. CHANGES IN fdrtool VERSION 1.2.0 This version constitutes a major rewrite. As a result, the interface to the main functions (especially to lesser used options) has been changed. See manual for details. Some specific changes include: - fit of null model using censored.fit() is now much more reliable. - estimates of null model parameter and null proportions now carry error bars. - fdrtool() now offers three different methods for choosing appropriate cutoff points (minimum false nondiscovery rate, the heuristic of the locfdr package, and using a fixed fraction of the data) - pval.estimate.eta0 now offers "quantile" approach. - a number of miscellaneous helper functions have been introduced. - no dependency on the "locfdr" package any more. - change of license to "GNU GPL 3 or any later version". CHANGES IN fdrtool VERSION 1.1.4 - monoreg(), the monotone regression function, is now partly written in C. This allows for much faster computation of the FDR calculations (which are based on the modified Grenander estimator. CHANGES IN fdrtool VERSION 1.1.3 - fixed a bug in plotting the F und FA distribution functions - fixed a bug in ecdf.pval() that occasionally caused Fdr to be larger than fdr (which for a decreasing density should never occur) - grenander() now also estimates increasing densities - plot.grenander() now uses linear y-scale (previously, log-scale) CHANGES IN fdrtool VERSION 1.1.2 - fdrtool() now has "dots" as option to allow the specification of arguments for the locfdr function CHANGES IN fdrtool VERSION 1.1.1 - the default behaviour of censored.fit() has been changed such that for multiple pct0 (i.e. length(pct0) > 1) the scale parameter is estimated for each element of pct0, subsequently a smoothing spline is computed, and finally the optimal parameter is taken as the minimum of the spline smoother. - new "verbose" option in fdrtool() - new "diagnostic.plot" option in censored.fit() - option to rely on locfdr >= 1.1-4 for fitting null distribution of correlation and normal scores CHANGES IN fdrtool VERSION 1.1.0 This version contains some major new functionality. In particular, it now offers functions to estimate both tail area based Fdr as well as density based fdr values for various kind of null models: New functions: - fdrtool: the central function for computing fdr/Fdr values. - censored.fit: learn null model from censored sample - monoreg: isotonic and antitonic regression with weights - gcmlcm: find greatest convex minorant and least concave majorant - grenander: non-parametric estimate of concave CDF and decreasing density - halfnormal: functions for half-normal distribution - dcor0: distribution of vanishing correlation coefficient Removed functions: - fdr.estimate.eta0: was replaced by pval.estimate.eta() - fdr.control: the function fdrtool() should be used. - density.pr: not needed any more Other: - dependency on locfdr package removed - fdrtool now requires R 2.2.1 CHANGES IN fdrtool VERSION 1.0.0 This is the first standalone release (9 August 2006). Previously, the functions available in this package were part of the GeneTS package (version 2.10.2) fdrtool/data/0000755000176200001440000000000012413051605012631 5ustar liggesusersfdrtool/data/pvalues.rda0000644000176200001440000007755412235226461015030 0ustar liggesusers w4RRh!HHOdSȌJ6;H{ 3{s.YqenReR""bBGbB#$ _?}k]n42'[|p&^6eO1xG6M2[eBg`Cqޛ~-BBgXo&T.k.a:Ls鵝1ph{{jd _DݟOYp1B;U~eabCv[Gw5g5qfhn<%M~8~{3Txt_8P31.iД$ uPٯ;-[+6.3pSz(@Pk<ҦҿbcEhna1}O~5f(wb:9rFQ[D_G C[V\r)/s41pmx`ů wmT0H̸{քfuޜ3poyvEvO9^BG5oqt(?zz bSGd[hE/CUD{V8"Z#.Ǒ1E'JMa\^[a %t'4!P|S+w9JD&'*>y 7)"7o+, oE,W-21dhj0d/&@Xu#76$BKA 6 $6F_|,S? l.&?R>3"$n+Yhx\o"_e z*aVM|<{Z:??qy;k<1Tؕ_DGpf!T>$ -Qho0/3\u`~Aey`S)MPqgM oQ\ʂ>bnN9d bj͆q+Wھ6фɷZEX7;-];xPxu0 ^ CgRcV@e*AKd-]Ȇ7ߐjDk{{iy"<ֆh2oQ,S/TD_?EIѝMu> %-AˇP)zr{cB}urv40mbFev0cNQu>Tsê)-j6 ׾A2O 2$y5VG4#ʟCv{PEu!U9Zːy>ɽl=]eR 2?Ǐ$ ߎi]\2t|~];9(Lm e*0:0Fu Z~aG``dVwjn1I5rW e,9dXU-:lg 5o=W߉QwB% ~'<铨`{t ^ N𿎆FzMwD}Eȿi|>BF(1t埽QBOq>(y*! ~-pl&]ž36 >ZgD#\xqSL(z:Җ &Czq'ƄM b%8g8%َ?7 ϳ|ՇPEj]4z> m3s]@O^ ˄/g^4nmSZp?nY"&Y'/f~:~s(G=G˓R3ۆiO1 ;ޕH{#uT\tWv Ʀ:Bxr3CI'_0[DwŰK<纏CdN %J_֘6L 'czXȞb/%EbzѤTNo"5Q*9E) Kģz,x-n4ԥ sٯc%h5RVea8cҝ)Iӻw3+$+c7a' ]!nOiA+^/LdSi[2tyLt(RcvWV#R،I T{oArD_ ;x)9MT7rm^t3K!!Oߥ_Tlgc?K1Uziyr_7#nS+5PBїeb T畷0^\6UZ"@SkvzӻX^ayWt.s 3=jIFt~G `qވ+/%X܎"&# j7B(r',F(88nNȝf4 -^/fZ+ٙ ݻdTsxu|Y=z|t?b \{vJRæ||>XR|Sך|[Қ0vK+(zE^)pYt_V4{T:ߥ+zGO'z.C[_G|sD8 ?P4^l JGATʭ^ID`qf$E^OÅu>?Ƽ$OlwRW9AxuJd$hϯza)bQxȇ)khcAߤ3Ͽŝak ??asPˢ!;-&{d_32ko`Gn+A} 尧\ '/bHCM*!  KE36ՄpG)S#`D:UԎyh/ //Fv_@j n8}՚]2}巣#XQeT8StPBFK|XDıG.Ƚ9 ˦>1+V,6uUj+ZwleBK%m9B~AL6Z&I MۮmB"7)`1 )31uj;v?iȓ㨑JCm;2!C+LnVeߵ zP|j3{~byy#_ve}Ȅ ɇhwmH榱7UG ?I-Dz}bn>#WcmQ\m ָveU:Z  5#a0~8KfNT[bJFPҴ^[|Y?c |BGwr"䱸}]ކ3|kGwU$&91$H̺5'5r ٧!9JtF{7nL䑡P;ګ&yF.Ũm~?c9vG/a2&/<С{w ô>܈UlTR }bld; =od>_i>| Bڱ|u SQax3Gr-IM&Zd=WOM|Y=Xn9)Q_(Aߩ _*P˪06 ˑqS'zI\Ag9֗(Rjz_5scxIciw8]CKs"v8^V M<(o3=|#z4Ĵ|1uZgDoEf۪5kW륙˳c=a#B"xK&alqXoTvLi6MfEdYK)bCd\K8vjmx.8taZ즨my=?,U]40:JZqPkuQoF~/ƎkuoX6FV/yUͳ#U̙HȖ`1G\I[? d]PuB$ȼ=s)-FQ}r1}\z$sϏ|E bmTLMuڬHכL|bp53R?Z968:uʅ8FU?0)V{= C&\UEZfGEjӻaM3(ڍzǐg{D6q]:llr!OQرjc[3 sXz&L){sa=>yҶ m$v~t6O2z.Pѣ.(m,=~=hZ,ё9?_bAyS(]kF!ѱct TCg ev:h:J:ɁrʼV*!^pBudWؓݼ/GL̎;N!=m{0 +Un#F7G0t\ z tхst "g|Òy>] &̓vPbotLSL#H պ)TQf2r g%g_f A ݗ@qºR/sAf mus6a8ӈhGjfX0g}ǣ'5{u=Y)^ߑWbÜ g7E{Q|3C}>eTb8Fb(.!z\6'¾z Z`K*:9,x9 x,:<ޡjJ4m4LtZ3b/o=9}b$:=Ei|_=T}{hW^ RaD$&ty[]N/\ДaEp63əFW,\i|snIȄzABtd䂱Ӱ(uGՌ)sG a6TܳC=P=yN krGrl(+& V~9Ql2OSn룯D?e{sȑOiSBه3ѧ>6ٖ*:[УT &,N"|9l^=0Ϻ7Q,!$&'kcL%_~uF_@{bWР-E6~6;ĝȈqJ5 {9i>9AF5̓$0C&V&XѼ6^ R:}Ty 䵮q\3i^7:VZ,TsD96 4QqG `L*=z |*ߛ41"EGGW8mGHHMO\AkS>fg~ؽ-g}FmkSK?81ڙ䪊Ӻs%BѬ>3"]>+PcQ?&_h%^ ~A=Ze6TocߋȻOL uډ?u.^XQqF=ϊr%b;mL&o>3ČE 3e_6B*EE6I{\Dn߽#+w#CuiEHLƗst8MvDsۜ`}ky;ZT1~3fh+k{3Wk>f9zX2b0}BD8<Mqr i Mm ~3&*1tff1?&}~ExكNJBaAncքKw/ݣ' K7BD5_;olC㻐wIndҾji~qa}TZ%gL옻YDΪ[lOTeufǴecտZ j4AWZl@f ]v@1K j_tc8 ̩i]@?F3ٻ*h9HdpVK0dA9_>ޭ9q BЎ|dOFFLU |)ki?p;7\:(ߋGB2 Ȥ{asa[/8@!|GM6r\g'a);#tZ <~| *u5#oB^ÁaaXnA6*&rHuan~4vFli,=w\_v1"t=8xz0.9B_k8x6 /k{ ,m&(C+Q(1,Gbq&6ez!臘qM,z }%A݆yq|MT3qDs#|ǫOm2R"k#Ž S:ŋY=u$UG6P~]p">lYùp1κIz>^LtB_Qeyk|4NU֐ sQj:?H9+~L+ t%\q%DR?#h'8$J\17]9F*Zc6W*KGJHt2tW3u&,%| LYCw|>ӒcB|u)rE{~bw1bAewFVq;d֬/͢VGQD22Y;c97׸\"YBƿ~E 3N=WQNBMH6 '__C8zAm1kH pI k# k!|JZlqok(ϰW Ⰶw fdwbhz</!Ki{ڪ߿Ÿ'ɱL%"i_hXюœnhwWOޛRM%\pRG\d)&  qLtcpJj]7n%觟'  9C#<HB!bF`Fz JI)%wf,X0IutfߋvN`_FPZcTA Uv X 2ʹ -r]+1vZ zΈ<=N~f)D\`̷ò·vRP s(&m `uրqVߡߓV0goSjdC({b(vpO﵁O4`#{G>SIp/"USJ x3G~[GNз!1̈Sg=0C N1űWCG !P_uT_jlK0 XAeAҡHMSxtKVY"D,<}|X|wfZd7+? S3%CjA_[ȸ]ISʆ0>^|cKEĠ@}|?vAa;;e<)_7 DxTaO}x~]yº+d4nGy<-cx!j?;ykg ?",Db`fL֐aZ]F:mf4+"\ }#d&Q,* (U|1#E{>'U w96sΠiQf&~t,R?a,M^- ߂R_ ꏉzdjp?FygN}ս`Lu(U^=Lшe =tC|w^Y>Qq%<9@`Dt??Υq>ϓ02-Zafb\ 4hYbh2 Y<͇P1pvC'KqtEE][Q,$g3Dؚc~'N.ĔCuDh xbd-+!`8ru3IòpLIL^eT}nLC$"м$|#ʛʘ{46( cf$5ٟw*$.Vç4rCĕK[tR׶Y lFR y|%TW c Y8*1Ir6Wn<^Ñq5sy鸍鑲!CΜCȽlE D09OV [Ah |'[曧0KHCX(N8yl^E:ߓe$x53[KA} K0C!~h;^}}&Z%.\R/iogyi;e ق[Yu% ëvohTh|)5N@y~U X^h>,HY蟬,,oݽijUW]ЂUM+&z,vdeԟg"@W-ˈ5@C(.s"#2nE20r`{iB=IףGҝlg*h;!,DgV&;~r/9M l;H'2^_ۚǵƅ>tHP}V%/C&ayPΝ;l Ұ&SPa/Ra䬌! &]+UO؜5N;!ֈ$8s:{as‰y,KN5zv>?G~#Q m\Ma,g`B<=wtn Sc\.V %zhзv47 ^!9Ro2yH^ RN#3}cJ!9Gߥ!?-d*WCX ke4˷`|m8]#ҌHz-nt*+tM0FTښzrmW!`H;ܿNwߎ"q_ZjWoG &jۚ]ADIUlݣ (Bx)OEcJ¯A~>Q'_vBm1Cakzy* @Tt>?9'Ux9eзyLbߏ MCxnL'"7J=1ڴU*~g+П}a|y*$MC@S`&%wxSN3F;IRKaA3IN"$("lc_>bj|ߩ$6n;s&Vg0'/,rZ,m`D8_"rBie8ZE `D˨j~~xIՍT;/fk_m1.ZX{kaG/=c3\sx9@dϴ FoZmn?1ouxog4Ν E"ßoy2rhw~ڈ3'76rdl.i?Eں|0r2/檏aɆ<3TDYuߟˠ<4阚8ce5A-"=--on}Ð|y,pq|q Ue^kUzˣo~r_9FA(ؾ{#D̬PDkʇ@\&52t62tyAREə<{h?ͥ9Oy?meL@A)P*l_0CM'%.b:XYLZۺ3v ah0ێZ<խݶ֣@ϓB߸`Wnxfv1P$έ"Y֙%+} BݻCNjgl31XQ7 r@`M ưϟG1m$0n&/ B奒/& :Ny3c$C,L1Gᧉ +`2fFWξ( K o>3ࠈ3nX_]vG?&kUĕb'C]^d`4RԊckp6'-I7: J3*`h&Q3ɗ~3ve^Lu_ H c8=/Qn5:S!҉Gw05}39/ODZ8m7%jP#_Kzޢe"<j?wo=ɻ 9XN~Cxg9av7E>j˸aB;i$ ] ?RdD E_^њ;ЎE݋2k4($9&}J["niƒFw ua4y>BC0/E 9at)<8toh=4Sh.TPZQNh_'*dT¼gK!9.Lp2Gc<}r2_sbh;'ގJ-ۃQzzی1[Cѐ8}c|\@Eiz>_PdBAv$5~Zᱤx>E+D/dIU;YBNwn-qc_f(pEv~pCfmW 1OsA!An#.g4?bUGLcs$]*t:%^/,u \mċ9tR#(=&_c{L^,JN3atTtH$aE wXiu˲@U#"hM^:s)R /8 `X!Nh[yhMe1Azeu?LW&}>uHZwhj)M,,L;0]oedl]4%Fs:7x0 GMXמt)'~Gh~$fL }k[UtuC:d{4G((Bf<0 & /<Ƅ[;#v|Y:\kK~Zn!ҿEZ=xߧ`ϲ:d)fOQFc)҃?Y#jI{] TmK* c0Kmjd]);TEpƀşp H}B^0̽'pjHpxMk#j$(MDY"yR NpL*:s`)vC{舎c(+_eʹ:r͔W -r[$ DbݘT$Ĉ9{3hW;Ax|(B0Qt dcrp3G q峟6\{ 1~콤L}6Q:Mm&g!|Ũ-4./\Mk!<"Qz-KML~lc+:%(MK%p8)uߡNXw7( LGQAUyºGrq/XMU*lҹ9V[O%`&z(=uQ(m1eBy-Z>yߴʹ@o9(WC|CD9>-ro~BUyps,{{.`zt<~ͳ^Eob_KxY[6F֓1avm|HI򼄺Wn.fYdy%'zS*Tp ODɹM'ZR]Mhh Æ#UxZ9^6eH98<͸ '7̠">-:+TiX!I̱?luX* .s_hSs*=/䢂0K<[!?EqeR))D$㍌BE)"lJg(+2{VQ"{s9}?:'i()y;c$'WI}B榍ѣ.&ץ.^/#Z;s?&|17;2O}&Ef(9Pɏ!.^<req *{jrpPV MV%Tc;@ Fd#].!YoIO 2Dc03(;Ŀ?1/ HVLڊ |,W^,tӦl䋊 ?Ew}v˞B!s?@Gmz)*~?"Eԧ^=E-M"h}d-?+?ر$iEAlmihx_K|t4KrXsc&ѢrEWn|> JȦ\vw0@{췿|WUfQY/bNXnxִa7(?]VPKrJ!zL] cbNu% <랕)}ZmZ:C|^c49Q =}1UU{~xa1[ĭIM&ȤIffLD 5+1?`{= X2<`, Β[~.PVl[`ح۸;wpI<1|;I P=Tơ"9K8g哜;V  rx:'k wy0;cyL?r/:;*JPh#OK{?cz;( wn3Vb]h1X֙VҲShw^M;aP#)XYp}8Y?W:VbH& f}D.iw!fd25x2_ՋG=h e,nJVNaez`/+xw]}bĕ`|@ݶ])=G+P3oy ? = 9 <&+SXհFcd˄ԅ"ch@=j†J6F>&#]ܐ4o4nlAH;|ҠQ58d~OI<0 mWQݤp,4F..cZU~hb""L߳&|M9K_R')!cPW˴ Maո}2S3ߡ`Y1fgTL08_Ѝ{ %7Qyy}/,aѼ3/洎Ղ ]\^͑O_F+Rg5wN Ost AAKM= YwyD?7q_!-eDF~ѐCtkM ߕ~Hӛ%zg,4ahvr_zɜ0GGߐރ5Na]4P{яR./?б_-% ]h84R(ĶqZ~IDOO>,WdOPpQoq%foj,q@\cT=aK,KtNvJb <1N$@&'3ecjJq`dHlmҤds.V/ "ڌ}nXz&:(Pُ'} W,a˼" |/AyRr,}_W}B-Ffxp:J*f/NN 5roc0 z$\e5`ǩ|tV7Mp4C񋞫X \k;޿ QuȾ+_ǧ*F'"g1OC]\Zh#!"z .,dCcm |e8?Lކ$ ]{6^GWo4N|u<z%6X8#ÑNkPcl^+[E] De%13e񮜶ga$Xe|h YEE8m|Nij[TisO>>"u}@H8'U>M?!7|kOBפm: =F#_vUކ]EG7tFϜ414Rq&z&r_X?_G*]:4|ĵHSg{ЂݺxZ}~{`'߇C7FyZ23ZÇf^<&mFEϼE$P$|,k2%QWc-gVZ=PGE7 +8Łl {P1]GaF?q7a/,al S?_gASFSl$&5ů6G q9:!z &SLr ⦬8e ;ߐk.Go16$#L?Z1Fj]`C>i(JHTF#Q{IYn0-]f˔7":vfVJ^0|38ެR"wIusFVnì2?AWCה5@w6{ lA&ᒻa0r`j2 B sA_$P9e^ :^|yܜ`!>s.\q%35nĪo?  Us7*%C$R' 270KYZ&Fk;GTv;/ sJu#Z4yH.GwG'8b~$r+5+K+Mf2Qaֆ^;مaY${D/G{aK,hF朇& HS|+6Gj")&St9;: d)آ47oOPՖk>2f4hGm2tiR)5|0!uRR<@F .ޏw{nj>%(k$@7`LJYS\-q>d. "daf*n(t?@H S :ٟ~tJEtkto x'@2;͙?q } y"b-߻^޷~y`e_zvzwtn|\ íhwZR.csVFB2-:M, :&Xؾ!QG)ǫ)z>|OٺcMMcZV u"=_-*|Z!% !ɋ9u&/V^N DOP@Z,V8 vUJ3]_.Kx!$T+><\&UD& ('L]KǜnȾ_Hz{uE;=b2owc?bԘA WBpn늋~px; O]D,ŷ~qu3R 9 y/^GYEq9ԑ?㤌:QWː9}2W:1u^? dSybD`f(#S0X[ASۗC0x l!ە7QCE IŢ^> .5XFm旤&|s@uu5|)](ysϰ éVEK3NJ݀SH R~,S B2Zi|r5Qk1^xEqPթdr>lg'З3voS5/aTͣAfD=z #h*aE֚HU1D.8blZj6:q k<[q/2HCH@ Hi|EYk= pD)KPq,sɻ~qj78ݹ8a%6# %kzvR0$u&އ C=y(dُ?zTe;УtK"Jn? c%6 VP*9{$_'7=3:/mbt\kicX?L y9R,Ԏdgbʗ[@7܅%T$5L(Yb_"눩B/rc%*yD7:Dft-tk6 ~{^Àn7ދEޟ6(=Wd },:*`lUcyST̰09Zmu K&WߌþH!tIdY2}IJSg c< =C[OHN9^[W5=96c&z/ #G݇`Vw@|aZh[8Dd//8H{bb;wppcqš<ꥁ(K{PQŠ*Mk{%ӫ`u,~%ro@YD;?F-4p{TnAۄQOyQȜV $DZ^+x$ZJ`j)^ʁ*U܋/y9J%ޢ X--UG|;zTg:1D2uL<(n1Aeiߓz/d *xgUvoΣ?~3n '5fA:q'So6=cOȡsaQwD$\â;BG`śabʙ|6g^r=7I9tveEО1zج韂c$\]63IP,ԎDgC㼢90T] P:Ms0/JFF_ڷ0p|suxs;-dN8{9*\BgEwJ>t[@#_5gďD%ݥD5+HU`9QODa)-M(|i06㶲7 g@A 8[D lOxeH~k툄iK\yTS;W[k(Yͽox 뛡vAz[(Ŧ~r 1CizQWȥ<!2wsm4(TČq!FmY|_mt6,KffFHSTj=L؄^iX%s+^'_z *ϛn~̚B]E{xLe2.fdyrY<ڝ[XqoXk@۰>,9oL`ū1ƚ>peEX"&i0vFRm.x#?6P4]42 dH=:oso@#:(A'76UU\Qj)Cʬg},3=w-z~*[}yIJL,|FL8&c)ZbdE2 9A9zy/!0~tΑ]/ә5idviyUv7HP+;aE br#qyeX>f&DwT9=Q{0о_;½:0i Hic]e"ezf wCjM]#4f~:t F7YaF X\~m#QC\\&VTe1SSf"6Om=kAogh3i܍lc)s1b+(\K5@BVd `||71|(ۑT#v&zE_@nÁ蟿UoaqVU2їpnFx%BzSmEw^L?ƒ %r ܳ0J/ LJ@eDP p}*&pOyUTupY^Lwh+Y5ަ#<;^'@Zz7c@aP'/Y0o^k`,1THa,)0(t{$z;GB1w8ŧfLMG8 8pcK$r%^VI Qwg۷hDe wɢr>P.j}6 P=3^2z< diw³>Td) z:6Fu%x//Е|1Y鵭qٳ# sY ';!eG Oě*k03~+E*aSy(zE8+ғк9/|UCf\Ayg p v3J!GfqWxKUXsI5Ţ+]#!+Ψܞ <[q2 Xڱ@Hơ>dRŒ%?Xʏ Hxg0>Ԩ~!ʴA/\N_>bG) 񷐼u"J玊W悉}w5nEvkJk=vۏ*wC0vG^x"dvKbyA&?BpwDX~ߚ1 08h8g=Ј_ټG4*M*X`ՄƠ"#}EM<6> łzG/ wя_q(-w=t?d~ה *#&A Q8Eo]#0.细ڑR/~:H"ZWHk1_=vq!“O-0iQ{y!!,^/LjchH~CK{x|'d*z'EL3e'3|mя "{{3G~,IWh}HB=?^ʑ3??:ҭq:bi!w{=S_&wvQBwtDFNJ 7/p7p{"6W`:=i 6+ 0ļq BQ&ć9 Q9`k6ΐd52c勗ňr]L8?OH0sld0>vv?v:n?Vi7z+:hMyig`74NdT!fy/wx`BN5RBH{#gOM,!2IZzo?LS,br/FVΥԦpIx34~pc}䍭$T?v*SݵBwa3F//~ OS_g`7z^Kc>(LO<ƤwOo&o7Gzxx^_TxἚF_E hbvPaťKt|rNykSƅCZ&lI~4}p:7+a&j>^MCyV{*f6z :SJvɚsR!Jo gՈ!A 3AhI(@3$D,7 ad|YT]1 f5}yۡz/1{L$VW0!7WpP]9)gY.Q7 yv>vul-X1oү )ܕ췆EhT8S%+ Ł<8`_Ig&Ͻk4j:\4~h{Iq'RvV}x5KbgO:X# 6"4d~ӈyLZfΘ~X>"4u?}|pj- ]_] ;;t(i75SKaTj-Ғ;xh17Laj) Y  Ye' B)Vc4xhÔ d.fLye@b.QWuZNyq G6gE&g;c~w'"Y/e*>t/a\Zbf#87ݭEL(+?B7(u9ec_>aCuί ILLV!}id*,*ͻM,ˊ*)GTJsIcU?1(DGb}QѶ;;Zo~ތ#ʹɉ d2twY1rQf45lBiXkvm#Fa$y78FI1JJFs'c~"Wo]s@`߾5L~"~+J/3RLZE 4,ctS75 %t`ʼ^=6i/b= sA-J2~s_Dۯcc+;s˾)*,n{فO0q}&߹ź0%4]z9Mbo3<9 h07\hO=Oj6`xm(-+9c=?~ƛ\)űZaGѯZcgYkFv=x3L+'=XJәxG] ܯ>ƐnG[6cuM["H9Ӳ%vvӴ)gaժgvfCcܭۺמb~wMah%R"E|?Egs$P4J\Dp-1dH<7Gjnd(gOwemZǴZ ޮХ]X"&7G(PTG4&ۨc  .8N"%Xb8ݰ QcG֏젞M̹ūܟBo}'*b+ڗޟ;]ME.1YRx*GL|?@G>St1Z$sK KP=,lwn"?_6_iRcXPd}y$Q!̞?Co_Fp}Ī7^]_I/ZZ(5Wt!# @23^S >ԪǤ0Ie1[4,\`V$$=G,q)}\wKMU23 W">KS1>KNvf;[iͦƱ#LITO(ρ2B8N#703 idQ30BUNE+:es5#:z= ٗWQC_H*C#Ø3Nfih@̟ond u;.=L~OXQeY$RA6%:Xܧ^=̋B.ib4(jRO[õ ݘ%\Oz\j$Ufz^ߗUE9`:FE<Σu?ug hWt h>ǨUsLh2 Bt8 .|1:|1gGtoaT⠯'3Z.zqcFfK 1 B7-nW%d"zy!HBU>5ԎZ6,G׬C '儂W'Z`} v:x֝"]^j~UciO΃Xߣ݋|l(}3O뼅?-XULmrC4?O@LZ ~,Fh y"g=@&Z[S`jkGȆa>TX8 _Łs!ho@5[D+ڼBMrat+|E߻:NIb-/ݤ('dt )!௺-]ƈ\netוp1tOW(Qa`oF2&]CKNxA;KGd,J0ƼNq0 :>Q 2|X-JC+~o$k)_SDzk3ƴƽ(\fX{.?H #ϴЖ3PFϹw(;G1t3m(?-ŌKC >БTPGw+`5;Ck,qTr06qcwF7/a-gX  ٣sBh1+qr*8|v;.f ʨ>hwnFIW[R]>"GϚac,1YwLRVx6P8dȍෳ"A. "ޟb)j/cL2'f $p:,}idV`t5? ]R -9x¾4(-@r-Q*ݾy9'PkVlŘY}:Ń(1L]ys<J~ؠ LTuY񊟁̕QeC*mnؐ+މ#QlƋtu)iSX *I6@dKXeWȹDŽiw-O0kh;}Q9y!(_8:IB.%Zxb }.C@(|/E$y]k XzplC+SբXa$K|ƒH*h# 4.+Cc<>y}+_#SȠ6nDJ(9thqB(WlI`>eI Ngܠts|6hVYjyC/ fS_L߄e < U.P@YL3ϗ7Ibe<ð/^tzzAR_w<X5tY^yLMTƖ,`\:16܉4㫭 gmE+>`Nh(U*^hXF֬U:,MvV[m o^A#X1IM\l+/XRZ^bjxwReJ^?ے}&4!MtQ{afT&Lxb o%=`׽h7|4kOmE<(}x{H*a$'yUaD_G3B VMB(!;7,^ΦXܷ0®D4{/n>Umq0,6Ce:\ 'G~x:,!D}%윐o9LZFFqOڦ[vEb\-CɇC33eFbUL*غۅwZW,ƨbjY$aD״Ls >|ȕ}Ve7Q5ڀ,u4eh2]:%!ukr ɕCO[yb1ܣ^F 3=0G=Z7ĞoC'J8>w)Ǐ0G(.pKU1 vLWR:)7˔[|Ocmkf; n+$p, ſ6&fqjTKM1^tE<5<pkμ~߬) ,Qqk+ϼrG#8 2I[@etsAWmlC\EN[ARo=U~,"C98]£=a>>֢݌ Ҫ=3.5hq.RD=GSh(nb`SXd 5++Pv_;YOVQF'QQ,:PGk3O/+EƘ` t %PCH+ vZI +b~q_OI|էB ö~'eEdMٽ}> kub_M J/bǷKweZ2]"ZQ̼]cIM,.i5xe?ÞӋb~vgE!oE enV]%CTyD0:e7"! 5_nȢ޻z' _;u<=2`8`>a͖*jt䙭l7N#ϖN~{Eo:at8"!"J/uĈX[. L!86B`UGyvBg RgImӀɧdHleUCPkmBx GkOoTskt:'28,6ԴaEٸ OPo\MIJ9g efF̊! ㍪|cI96:o6# Eqb\?tZz7۞eUmfNc B)v[ ^x>Rç$}_0=欼K(pnRlݯ7.@5.ػ{`IvH")o..v éaXP I&A&)Y`a,PUTFO.ı -7nncx4RQlaEwz f&U 6 OXȝ$%_r%4h/!T>J*I6%؋^.>XL΄:jGuIlA?B~`Yc߉IX|Ho<5ԶMB I=u#()cdt4Eɓgg3Xɷ-]C?'8h:lǨ^YP)-fy״-71`Q5s+ >W㏦J ,1IISתG_ɡkWv3It$aE,+ ]uW}M]P<c7"ʗ>I9-{ T1{0}r"$W-?bw55MwV TZ WS_ AF kLi9KLz%Zü9i59 n,,IVC۵vj]11" E<÷3Q]Vks6hu+.Ma&qdH msRG:'-tX=FtJh3vEb(F1:JrcyYGqy}^FyUvݟ k>ܓ>_'3D) 9^q5+x#{'j/|Qc;2x)lLqg8.SylBCoT*:IiLJD-/TKqwKԗԸ.fݷT<~άxriacmnLDfA@J\Nhb!j$ī0'@alcDK3|9 n<uZV%x|[z ~c0OC\Y W NADJsyOuL__ y'o=[9 qm:d0n QKݦ" ;U^QwKV~MCB ]wݦfv.5tuAvjw:ȇMG|3vx~&i{`;6r;g=auI("{"xP mN@2Cf=рԼ䃎-snJ&K'u_Hg5:2D[B^2 `|(RY6km(AI8Vcl8`7/ی v\oMf`pIZ)gxR*V#O!CxXn eI8~CVj=9*ufWUD$Ĝy.7|W%xې.}h5lwa4&+ eTk& 8c{9uw2"I98 7E{76rp 'v+ƶ']cͯµ^<(2>pyz].#Z 6H(𜙾EG9F+ <ڸbܥX]|ab=R. O[C ^{*.Kýs-[xtIvv1T$zIBTfEG5ʞșc,c>fdrtool/R/0000755000176200001440000000000012235226461012127 5ustar liggesusersfdrtool/R/grenander.R0000644000176200001440000000361412235226461014223 0ustar liggesusers### grenander.R (2007-06-13) ### ### Grenander Density Estimator ### ### Copyright 2006-2007 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA grenander = function(F, type=c("decreasing", "increasing")) { if( !any(class(F) == "ecdf") ) stop("ecdf object required as input!") type <- match.arg(type) if (type == "decreasing") { # find least concave majorant of ECDF ll = gcmlcm(environment(F)$x, environment(F)$y, type="lcm") } else { # find greatest convex minorant of ECDF l = length(environment(F)$y) ll = gcmlcm(environment(F)$x, c(0,environment(F)$y[-l]), type="gcm") } f.knots = ll$slope.knots f.knots = c(f.knots, f.knots[length(f.knots)]) g = list(F=F, x.knots=ll$x.knots, F.knots=ll$y.knots, f.knots=f.knots) class(g) <- "grenander" return(g) } plot.grenander <- function(x, ...) { if (x$f.knots[1] > x$f.knots[2]) main = "Grenander Decreasing Density" else main = "Grenander Increasing Density" par(mfrow=c(1,2)) plot(x$x.knots, x$f.knots, type="s", xlab="x", ylab="fn(x)", main=main, col=4, lwd=2, ...) plot(x$F, do.points=FALSE) lines(x$x.knots, x$F.knots, type='l', col=4, lwd=2) par(mfrow=c(1,1)) } fdrtool/R/dcor0.R0000644000176200001440000000352512235226461013266 0ustar liggesusers### dcor0.R (2007-01-09) ### ### Distribution of the Correlation Coefficient (rho=0) ### and Related Functions ### ### ### Copyright 2003-07 Korbinian Strimmer ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # density function dcor0 <- function (x, kappa, log = FALSE) { t <- r2t(x, kappa) df <- kappa-1 vol <- sqrt(df)*(1-x^2)^(-3/2) if (log) d <- dt(t, df=df, log=log) + log(vol) else d <- dt(t, df=df, log=log) * vol return(d) } # distribution function pcor0 <- function(q, kappa, lower.tail=TRUE, log.p=FALSE) { t <- r2t(q, kappa) df <- kappa-1 p <- pt(t, df=df, lower.tail = lower.tail, log.p = log.p) return(p) } # quantile function qcor0 <- function(p, kappa, lower.tail=TRUE, log.p=FALSE) { df <- kappa-1 r <- t2r(qt(p, df=df, lower.tail = lower.tail, log.p = log.p), df) return(r) } # random number generator rcor0 <- function(n, kappa) { df <- kappa-1 r <- t2r(rt(n, df),df) return(r) } ### conversion from r to t statistic (and vice versa) r2t <- function(r, kappa) { t = r*sqrt((kappa-1)/(1-r*r)) return(t) # df = kappa-1 } t2r <- function(t, df) { r = t/sqrt(t*t+df) return(r) # kappa = df+1 } fdrtool/R/pval.estimate.eta0.R0000644000176200001440000001153312235226461015661 0ustar liggesusers### pval.estimate.eta0.R (2007-10-11) ### ### Estimating the Proportion of Null p-Values ### ### Copyright 2003-2007 Korbinian Strimmer ### ### Parts of this code is adapted from ### S-PLUS code (c) by Y. Benjamini (available from ### http://www.math.tau.ac.il/~roee/FDR_Splus.txt ) ### and from R code (c) J.D. Storey (available from ### http://faculty.washington.edu/~jstorey/qvalue/ ) ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA #Input #============================================================================= #p: a vector of p-values #method: method for computing eta0 #lambda: optional tuning parameter (vector, needed for "bootstrap" and "smoothing") # # conservative: Benjamini and Hochberg (1995) JRSSB # adaptive: Benjamini and Hochberg (2000) J. Behav. Educ. Statist. # bootstrap: Storey (2002) JRSSB # smoother: Storey and Tibshirani (2003) PNAS # quantile: similar to "smoother", with eta0 assumed to be quantile q (10%) #Output #============================================================================= #eta0: an estimate of the proportion of null p-values pval.estimate.eta0 <- function(p, method=c("smoother", "bootstrap", "conservative", "adaptive", "quantile"), lambda=seq(0,0.9,0.05), diagnostic.plot=TRUE, q=0.1) { method <- match.arg(method) if (method == "conservative") # Benjamini and Hochberg (1995) { eta0 = 1.0 } if (method == "adaptive") # Benjamini and Hochberg (2000) { m <- length(p) sortp <- sort(p) s <- sort(1 - sortp)/(1:m) m0raw <- m i <- m while(i > 1 && s[i] <= s[i - 1]) i <- i - 1 if(i > 1) m0raw <- 1/s[i - 1] else m0raw <- 1/s[1] m0 <- min(floor(1 + m0raw), m) eta0 <- m0/m } if(method == "bootstrap" || method == "smoother" || method == "quantile") { # for the remaining methods we a set of p-value thresholds if (length(lambda) < 4) stop("At least 4 values in lambda tuning vector required") e0.vec <- rep(0,length(lambda)) for(i in 1:length(lambda)) { e0.vec[i] <- mean(p >= lambda[i])/(1-lambda[i]) } } if(method == "quantile") { e0.vec <- pmax(0, pmin(1, e0.vec)) eta0 <- as.double(quantile( e0.vec, probs=c(q))) } if(method == "bootstrap") # Storey (2002) JRSSB { m <- length(p) mineta0 <- min(e0.vec) mse <- rep(0,length(lambda)) eta0.boot <- rep(0,length(lambda)) for(i in 1:100) { p.boot <- sample(p,size=m,replace=TRUE) for(i in 1:length(lambda)) { eta0.boot[i] <- mean(p.boot>lambda[i])/(1-lambda[i]) } mse <- mse + (eta0.boot-mineta0)^2 } idx <- which.min(mse)[1] lambda.min <- lambda[idx] eta0 <- max(0, min(e0.vec[idx], 1)) if (diagnostic.plot) { dev.new() # open new plot window par(mfrow=c(2,1)) plot(lambda, e0.vec, ylab="eta0") points( lambda.min, eta0, pch=20, col=2 ) plot(lambda, mse) points( lambda.min, min(mse), pch=20, col=2 ) par(mfrow=c(1,1)) } } if(method == "smoother") # Storey and Tibshirani (2003) PNAS { e0.spline <- smooth.spline(lambda, e0.vec, df=3) eta0 <- max(0,min( predict(e0.spline, x=max(lambda))$y, 1)) if (diagnostic.plot) { dev.new() # open new plot window plot(lambda, e0.vec, main="Smoothing Curve Employed For Estimating eta0", xlab="lambda", ylab="eta0") lines( e0.spline ) points( max(lambda), eta0, pch=20, col=2 ) } } if (diagnostic.plot) { dev.new() # open new plot window info0 = paste("method =", method) info1 = paste("eta0 =", round(eta0, 4)) h = hist(p, freq=FALSE, bre="FD", main="Diagnostic Plot: Distribution of p-Values and Estimated eta0", xlim=c(0,1), xlab="p-values") y0 = dunif(h$breaks)*eta0 lines(h$breaks, y0, col=2) maxy = max(h$density) text(0.5, 5/6*maxy, info0) text(0.5, 4/6*maxy, info1, col=2) } return(eta0) } fdrtool/R/censored.fit.R0000644000176200001440000001137512235226461014644 0ustar liggesusers### censored.fit.R (2009-11-19) ### ### Fit Null Distribution To Censored Data by Maximum Likelihood ### ### Copyright 2006-08 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # estimate parameters of null distribution # using using truncated distributions # available null distributions # - normal (with mean zero) # - correlation (with rho zero) # - student t # - uniform censored.fit = function(x, cutoff, statistic=c("normal", "correlation", "pvalue", "studentt")) { statistic = match.arg(statistic) cutoff = abs(cutoff) if ( !is.vector(x) ) stop("x needs to be a vector!") if (statistic=="pvalue") { result = matrix(nrow=length(cutoff), ncol=4) colnames(result)= c("cutoff", "N.cens", "eta0", "eta0.SE") } else { result = matrix(nrow=length(cutoff), ncol=6) colnames(result)= c("cutoff", "N.cens", "eta0", "eta0.SE", "sd", "sd.SE") } if (statistic=="correlation") colnames(result)[5] = "kappa" if (statistic=="studentt") colnames(result)[5] = "df" if (statistic=="correlation") colnames(result)[6] = "kappa.SE" if (statistic=="studentt") colnames(result)[6] = "df.SE" for (i in 1:length(cutoff)) { x0 = cutoff[i] result[i,1] = x0 out = pvt.fit.nullmodel(x, x0, statistic=statistic) result[i,2] = out$N.cens result[i,3] = out$eta0 result[i,4] = out$eta0.SE if (statistic!="pvalue") { result[i,5] = out$param result[i,6] = out$param.SE } } return(result) } ### helper functions # Richardson extrapolation approximation # for numerical computation of curvature num.curv = function(x, fun) { macheps = .Machine$double.eps h = max( 1e-4, macheps^(1/4)*abs(x) ) w = c(-1/12,4/3,-5/2,4/3,-1/12) xd = x + h*c(-2,-1,0,1,2) return( sum(w*fun(xd))/h^2 ) } ### internal functions pvt.fit.nullmodel = function(x, x0, statistic) { N = length(x) if (statistic=="pvalue") x.cens = x[ x >= x0 ] else x.cens = x[ abs(x) <= x0 ] N.cens = length(x.cens) if (N.cens > N) stop("N must be larger or equal to the size of the censored sample!") if (N.cens < 10) warning(paste("Censored sample for null model estimation has only size", length(x.cens), "!"), call.=FALSE) #if (N.cens < 2) # stop(paste("Adjust cutoff point - censored sample more null model has only size", # length(x.cens), "!"), call.=FALSE) ############## nm = get.nullmodel(statistic) # negative log-likelihood function (truncated density) nlogL = function(pp) { out = rep(0, length(pp)) for (i in 1:length(pp)) { out[i] = length(x.cens)*log(1-nm$get.pval(x0, pp[i]))- sum(nm$f0(x.cens, pp[i], log=TRUE)) } return(out) } ############## # estimate parameters of null model if (statistic!="pvalue") { start = iqr.fit(x.cens, statistic) # start value for scale parameter #sup = nm$get.support() #opt.out = nlminb( start, nlogL, lower=sup[1], upper=sup[2] ) #sc.param = opt.out$par[1] sup = nm$get.support() lo = max( start/1000, sup[1]) up = min( start*1000, sup[2]) sc.param = optimize(nlogL, lower=lo, upper=up)$minimum sc.var = 1/num.curv(sc.param,nlogL) # inverse curvature of negative logL if(is.na(sc.var)) { sc.var = 0 warning("Variance of scale parameter set to zero due to numerical problems") } if(sc.var < 0) { sc.var = 0 warning("Variance of scale parameter set to zero due to numerical problems") } sc.SE = sqrt(sc.var) } else { sc.param = NULL # no scale parameter sc.SE = NULL } # ML estimate of eta0 m = 1-nm$get.pval(x0, sc.param) th = N.cens/N eta0 = min(1, th / m ) #eta0 = th / m eta0.SE = sqrt( th*(1-th)/(N*m*m) ) rm(x.cens) return( list(N.cens=N.cens, eta0=eta0, # proportion eta0.SE=eta0.SE, # corresponding standard error param=sc.param, # scale parameter param.SE=sc.SE # corresponding standard error ) ) } fdrtool/R/ecdf.pval.R0000644000176200001440000000424512235226461014121 0ustar liggesusers### ecdf.pval.R (2007-06-15) ### ### Estimate Empirical Density of p-Values ### ### ### Copyright 2007 Korbinian Strimmer ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # empirical cumulative distribution of p-values, # constrained such that the known fraction eta0 of null p-values # is taken into account ecdf.pval <- function (x, eta0=1) { # compute empirical CDF as usual x = sort(x) n = length(x) if (n < 1) stop("'x' must have 1 or more non-missing values") vals = sort(unique(x)) F.raw = cumsum(tabulate(match(x, vals)))/n # control upper bound of F: # make sure that the maximum slope of (Grenander) F is eta0 F.raw = pmin(F.raw, 1-eta0*(1-vals) ) # control lower bound of F: # make sure that (Grenander F) >= eta0*vals F.raw = pmax(F.raw, eta0*vals) # if necessary add an atom at 1 to make it a proper CDF if (vals[length(vals)] != 1) { F.raw = c(F.raw, 1) vals = c(vals, 1) } # if necessary also add an atom at 0 with weight zero to get support [0,1] if (vals[1] != 0) { F.raw = c(0, F.raw) vals = c(0, vals) } # finally, modify F such that the last slope of the Grenander F # is *exactly* eta0 i = length(vals)-1 F.raw[i] = 1-eta0*(1-vals[i]) rval <- approxfun(vals, F.raw, method = "constant", yleft = 0, yright = 1, f = 0, ties = "ordered") class(rval) = c("ecdf", "stepfun", class(rval)) attr(rval, "call") <- sys.call() rval } fdrtool/R/nullmodel.R0000644000176200001440000000711512235226461014251 0ustar liggesusers### nullmodel.R (2009-11-19) ### ### Details on the FDR Null Model ### ### Copyright 2007-2009 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # this function specifies all that is needed to define a null model get.nullmodel = function( statistic=c("normal", "correlation", "pvalue", "studentt") ) { statistic <- match.arg(statistic) ###### normal z-scores ###### if (statistic=="normal") { # untruncated density f0 = function(x, param, log=FALSE) { return( dnorm(x, sd=param, log=log) ) } # corresponding distribution function F0 = function(x, param) { return( pnorm(x, sd=param) ) } # interquartile range iqr = function(param) { return( qnorm(.75, sd=param)-qnorm(.25, sd=param) ) } # parameter support get.support = function() return( c(1e-9,Inf) ) } ###### p-values ###### if (statistic=="pvalue") { # untruncated density f0 = function(x, param, log=FALSE) { if(log==TRUE) return( rep(0, length(x)) ) else return( rep(1, length(x)) ) } # corresponding distribution function F0 = function(x, param) { return( x ) } # interquartile range iqr = function(param) { return( 0.5 ) } # parameter support get.support = NULL } ###### correlation coefficients ###### if (statistic=="correlation") { # untruncated density f0 = function(x, param, log=FALSE) { return( dcor0(x, kappa=param, log=log) ) } # corresponding distribution function F0 = function(x, param) { return( pcor0(x, kappa=param) ) } # interquartile range iqr = function(param) { return( qcor0(.75, kappa=param)-qcor0(.25, kappa=param) ) } # parameter support get.support = function() return( c(3,1e9) ) } ###### t scores ###### if (statistic=="studentt") { # untruncated density f0 = function(x, param, log=FALSE) { return( dt(x, df=param, log=log) ) } # corresponding distribution function F0 = function(x, param) { return( pt(x, df=param) ) } # interquartile range iqr = function(param) { return( qt(.75, df=param)-qt(.25, df=param) ) } # parameter support get.support = function() return( c(1,1000) ) } ###### corresponding p-values ###### if (statistic=="pvalue") { # one-sided p-values get.pval = function(x, param) { #return( F0(x) ) return( x ) } } else { # two-sided p-values get.pval = function(x, param) { ax = abs(x) # return pval=0 only if abs(x)=Inf return( ifelse(ax==Inf, 0, pmax(.Machine$double.eps, 2-2*F0(ax, param))) ) } } return(list( f0 = f0, F0=F0, iqr=iqr, get.pval = get.pval, get.support = get.support )) } fdrtool/R/gcmlcm.R0000644000176200001440000000344612235226461013523 0ustar liggesusers### gcmlcm.R (2011-03-19) ### ### ### Greatest Convex Minorant (GCM) and Least Concave Majorant (LCM) ### ### ### Copyright 2006-2011 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # find greatest convex minorant (gcm) or # least concave majorant (lcm) gcmlcm = function(x, y, type=c("gcm", "lcm")) { type=match.arg(type) if (is.unsorted(x)) stop("The x values must be arranged in sorted order!") if (any(duplicated(x))) stop("No duplicated x values allowed!") ######## dx = diff(x) dy = diff(y) rawslope = dy/dx # make sure there are no Inf in rawslope rawslope[rawslope == Inf] <- .Machine$double.xmax rawslope[rawslope == -Inf] <- -.Machine$double.xmax if (type == "gcm") slope <- pvt.isoMean(rawslope, dx) if (type == "lcm") slope <- -pvt.isoMean(-rawslope, dx) # remove duplicate slopes keep = !duplicated(slope) x.knots = x[c(keep, TRUE)] # also keep last point dx.knots = diff(x.knots) slope.knots = slope[keep] y.knots = y[1]+c(0, cumsum(dx.knots*slope.knots)) list(x.knots=x.knots, y.knots=y.knots, slope.knots=slope.knots) } fdrtool/R/approximate.fit.R0000644000176200001440000000370012235226461015364 0ustar liggesusers### approximate.fit.R (2007-10-19) ### ### First Guess of Null Model Parameters ### ### Copyright 2007 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # first guess of null model parameters approximate.fit = function(x, statistic=c("normal", "correlation", "pvalue", "studentt"), lambda=seq(0,0.9,0.05)) { statistic <- match.arg(statistic) nm = get.nullmodel(statistic) param = iqr.fit(x, statistic) # approximate estimate of scale parameter pval = nm$get.pval(x, param) # compute corresponding p-values # estimate eta0 eta0 = pval.estimate.eta0(pval, method="quantile", q=0.1, diagnostic.plot=FALSE, lambda=lambda) return(list(eta0=eta0, param=param)) } # find robust estimate of scale by fitting IQR iqr.fit = function(x, statistic=c("normal", "correlation", "pvalue", "studentt")) { statistic <- match.arg(statistic) nm = get.nullmodel(statistic) # observed interquantile range iqr.obs = as.double(diff(quantile(x, probs=c(.25, .75)))) if (statistic=="pvalue") { param = NULL } else if (statistic=="normal") { param = iqr.obs/(2*qnorm(.75)) } else { mfun = function(param) return( (nm$iqr(param)-iqr.obs)^2 ) supp = nm$get.support() param = optimize(mfun, supp)$minimum } return(param) } fdrtool/R/fndr.cutoff.R0000644000176200001440000000414612235226461014475 0ustar liggesusers### fndr.cutoff.R (2008-03-05) ### ### Find Approximate Cutoff Point by an FNDR Criterion ### ### Copyright 2007-08 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # find approximate cutoff based on false nondiscovery rate fndr.cutoff <- function(x, statistic=c("normal", "correlation", "pvalue", "studentt")) { statistic <- match.arg(statistic) nm = get.nullmodel(statistic) if(statistic=="pvalue") { ax = 1-x F0 <- function(zeta) return( nm$F0(zeta, sc.param) ) } else { ax = abs(x) F0 <- function(zeta) return( 2*nm$F0(zeta, sc.param)-1 ) } fndrfunc = function(x) { F.x = sum(ax < x)/length(ax) if (F.x == 0) { FNDR.x = 0 } else { FNDR.x = max(0, (F.x-e0.guess*F0(x)) / F.x) } return(FNDR.x) } # first, find approximate null model ("guess") g = approximate.fit(x, statistic) sc.param = g$param e0.guess = g$eta0 # second, find cutoff such that fndr is as small as possible MAXPCT0 = 0.99 # never use all the data zeta0 = as.double(quantile(ax, probs=min(MAXPCT0, e0.guess))) #cat("DEBUG: zeta0 =", zeta0, "\n") fndr2 = fndrfunc(zeta0) fndr1 = fndrfunc(0.9*zeta0) while ( fndr1 < fndr2 ) { zeta0 = zeta0 *0.9 #cat("DEBUG: zeta0 =", zeta0, "\n") fndr2 = fndr1 fndr1 = fndrfunc(0.9*zeta0) } if(statistic == "pvalue") x0 = 1-zeta0 else x0 = zeta0 names(x0) = "cutoff" rm(ax) return(x0) } fdrtool/R/monoreg.R0000644000176200001440000000761512324331553013727 0ustar liggesusers### monoreg.R (2014-04-15) ### ### Monotone Regression ### ### Copyright 2006-2014 Korbinian Strimmer ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # monotone regression monoreg = function(x, y=NULL, w=rep(1, length(x)), type=c("isotonic", "antitonic")) { # get x-y coordinates xy = xy.coords(x,y) x = xy$x y = xy$y # remove duplicated x values xvals = unique(x) lx = length(xvals) if (lx == length(x)) # x values are all unique { wts = w yvals = y } else # merge duplicated x values { wts = rep(NA, lx) yvals = rep(NA, lx) for (i in 1:lx) { idx = which(xvals[i]==x) if (length(idx) > 1) { warning("Duplicated x value (x=", xvals[i], ") detected!\nThe corresponding weights and y values will be merged.") wi = w[idx] wts[i] = sum(wi) # add all weights yvals[i] = sum(y[idx]*wi)/wts[i] # weighted mean } else { wts[i] = w[idx] yvals[i] = xy$y[idx] } } } # sort ord = order(xvals) xvals = xvals[ord] yvals = yvals[ord] wts = wts[ord] # perform monotonic regression type = match.arg(type) if (type=="isotonic") { yf = pvt.isoMean(yvals, wts) } if (type=="antitonic") { yf = -pvt.isoMean(-yvals, wts) } # output results out = list(x=xvals, y=yvals, w=wts, yf=yf, type=type, call = match.call()) class(out) = c("monoreg") return(out) } fitted.monoreg = function(object, ...) object$yf residuals.monoreg = function(object, ...) object$y - fitted(object) plot.monoreg = function(x, main, main2, plot.type = c("single", "row.wise", "col.wise"), ...) { plot.type = match.arg(plot.type) if (plot.type=="row.wise") par(mfrow=c(2,1)) if (plot.type=="col.wise") par(mfrow=c(1,2)) if (missing(main)) { if (x$type=="isotonic") main = paste("Isotonic Regression:", deparse(x$call)) else main = paste("Antitonic Regression:", deparse(x$call)) } plot(x$x, x$y, main=main, xlab="x", ylab="y", ...) lines(x$x, x$yf, col=4, lty=3) points(x$x, x$yf, col=4, pch=20) if (plot.type != "single") { if (missing(main2)) { if(x$type == "isotonic") main2="Cumulative Sum Diagram and Greatest Convex Minorant" else main2="Cumulative Sum Diagram and Least Concave Majorant" } G = c(0, cumsum(x$y*x$w)) M = c(0, cumsum(x$yf*x$w)) W = c(0, cumsum(x$w)) plot(W, G, main=main2, xlab="cumsum(w)", ylab="cumsum(y*w)", type="l") points(W, G) lines(W, M, col=4, lty=3) points(W, M, col=4, pch=20) par(mfrow=c(1,1)) } } ######## internal function ################### pvt.isoMean = function(y, w) { # Input: y: measured values in a regression setting # w: weights # Output: vector containing estimated (isotonic) values n = length(y) if(n == 1) { return(y) } else { ghat = .C("C_isomean", as.double(y), as.double(w), as.integer(n), ghat=double(n), PACKAGE="fdrtool")$ghat return(ghat) } } fdrtool/R/hc.score.R0000644000176200001440000000405712235226461013764 0ustar liggesusers### hc.score.R (2012-07-25) ### ### Compute empirical higher criticism score and threshold from p-values ### ### Copyright 2010-2012 Bernd Klaus and Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA # compute empirical HC scores from p-values hc.score = function(pval) { if (max(pval) > 1 | min(pval) < 0) stop("input p-values must all be in the range 0 to 1!") d = length(pval) F = rank(pval, ties.method="max")/d v = F*(1-F)/d # variance v[v==0] = min( v[v > 0] ) # just to make sure we have no zero variance HC = abs(F-pval)/sqrt(v) return( HC ) } # determine HC decision threshold from p-values # pval: p-values # alpha0: look only at a fraction alpha0 of the p-values (default: 1) # plot: produce a plot of HC curve hc.thresh = function(pval, alpha0=1, plot=TRUE) { spval = sort(pval) # sort p-values for plotting hcval = hc.score(spval) alpha0.idx = 1:ceiling(alpha0*length(hcval)) # the fraction of HC values to maximize over hcstat.idx = which.max( hcval[alpha0.idx] ) # idx of maximum HC hcstat = hcval[hcstat.idx] # maximum HC hcstat.pval = spval[hcstat.idx] # pval of maximum HC if (plot) { plot(spval[alpha0.idx], hcval[alpha0.idx], type="l", xlab="ordered p-values", ylab="HC score") lines( c(hcstat.pval, hcstat.pval), c(0, hcstat) , col=2) } return(hcstat.pval) } fdrtool/R/halfnorm.R0000644000176200001440000000363512235226461014067 0ustar liggesusers### halfnorm.R (2007-01-01) ### ### Half-Normal Distribution ### ### Copyright 2006-2007 Korbinian Strimmer ### ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA dhalfnorm <- function(x, theta=sqrt(pi/2), log=FALSE) { sd.norm = theta2sd(theta) if (log) d = ifelse(x<0, -Inf, log(2)+dnorm(x, mean=0, sd=sd.norm, log=TRUE)) else d = ifelse(x<0, 0, 2*dnorm(x, mean=0, sd=sd.norm)) return(d) } phalfnorm <- function(q, theta=sqrt(pi/2), lower.tail=TRUE, log.p=FALSE) { sd.norm = theta2sd(theta) p = ifelse(q < 0, 0, 2*pnorm(q, mean=0, sd=sd.norm)-1) if (lower.tail == FALSE) p = 1-p if(log.p) p = log(p) return( p ) } qhalfnorm <- function(p, theta=sqrt(pi/2), lower.tail=TRUE, log.p=FALSE) { sd.norm = theta2sd(theta) if (log.p) p = exp(p) if (lower.tail == FALSE) p = 1-p q = ifelse(p < 0, NaN, qnorm((p+1)/2, mean=0, sd=sd.norm)) return(q) } rhalfnorm <- function(n, theta=sqrt(pi/2)) { sd.norm = theta2sd(theta) return( abs(rnorm(n, mean=0, sd=sd.norm)) ) } # conversion between standard deviation of normal distribution # and theta parameter of corresponding half-normal distribution sd2theta <- function(sd) { return(sqrt(pi/2)/sd) } theta2sd <- function(theta) { return(sqrt(pi/2)/theta) } fdrtool/R/fdrtool.R0000644000176200001440000001764212235226461013735 0ustar liggesusers### fdrtool.R (2013-09-15) ### ### Estimate (Local) False Discovery Rates For Diverse Test Statistics ### ### ### Copyright 2007-13 Korbinian Strimmer ### ### This file is part of the `fdrtool' library for R and related languages. ### It is made available under the terms of the GNU General Public ### License, version 3, or at your option, any later version, ### incorporated herein by reference. ### ### This program is distributed in the hope that it will be ### useful, but WITHOUT ANY WARRANTY; without even the implied ### warranty of MERCHANTABILITY or FITNESS FOR A PARTICULAR ### PURPOSE. See the GNU General Public License for more ### details. ### ### You should have received a copy of the GNU General Public ### License along with this program; if not, write to the Free ### Software Foundation, Inc., 59 Temple Place - Suite 330, Boston, ### MA 02111-1307, USA fdrtool = function(x, statistic=c("normal", "correlation", "pvalue"), #statistic=c("normal", "correlation", "pvalue", "studentt"), plot=TRUE, color.figure=TRUE, verbose=TRUE, cutoff.method=c("fndr", "pct0", "locfdr"), pct0=0.75) { statistic = match.arg(statistic) cutoff.method = match.arg(cutoff.method) if ( is.vector(x) == FALSE ) stop("input test statistics must be given as a vector!") if ( length(x) < 200 ) warning("There may be too few input test statistics for reliable FDR calculations!") if (statistic=="pvalue") { if (max(x) > 1 | min(x) < 0) stop("input p-values must all be in the range 0 to 1!") } #### step 1 #### if(verbose) cat("Step 1... determine cutoff point\n") # determine cutoff point for censoring if (cutoff.method=="pct0") { # use specified quantile if(statistic=="pvalue") x0 = quantile(x, probs=1-pct0) else x0 = quantile(abs(x), probs=pct0) } else if ( cutoff.method=="locfdr" & (statistic=="normal" | statistic=="correlation") ) { # use same procedure as in locfdr R package (due to Brit Katzen-Turnbull) if(statistic=="normal") z = x if(statistic=="correlation") z = atanh(x) iqr = as.double(diff(quantile(z, probs=c(.25, .75)))) sdhat = iqr/(2*qnorm(.75)) N = length(z) # b = 3.55-.44*log(N, 10) # locfdr 1.1-3 b = ifelse(N > 500000, 1, 4.3 * exp(-0.26*log(N,10)) ) # locfdr 1.1-6 z0 = b*sdhat if(statistic=="normal") x0 = z0 if(statistic=="correlation") x0 = tanh(z0) } else { if(cutoff.method=="locfdr") warning("cutoff.method=\"locfdr\" only available for normal and correlation statistic.") # control false nondiscovery rate x0 = fndr.cutoff(x, statistic) } #### step 2 #### if(verbose) cat("Step 2... estimate parameters of null distribution and eta0\n") cf.out <- censored.fit(x=x, cutoff=x0, statistic=statistic) # cf.out looks as follows for p-values # cutoff N0 eta0 eta0.var #[1,] 0.96 64 0.3730473 0.002141996 # the other test statistics have two more colums containing the scale parameter if (statistic=="pvalue") scale.param = NULL else scale.param <- cf.out[1,5] # variance parameter eta0 = cf.out[1,3] #### step 2 #### if(verbose) cat("Step 3... compute p-values and estimate empirical PDF/CDF\n") nm = get.nullmodel(statistic) pval = nm$get.pval(x, scale.param) # determine cumulative empirical distribution function (pvalues) ee <- ecdf.pval(pval, eta0=eta0) g.pval <- grenander(ee) #cat("DEBUG: Grenander eta0=", g.pval$f.knots[length(g.pval$f.knots)], "\n") #cat("DEBUG: estimated eta0=", eta0 , "\n\n") # mixture density and CDF f.pval = approxfun( g.pval$x.knots, g.pval$f.knots, method="constant", rule=2) f0.pval = function(x) return( ifelse(x > 1 | x < 0, 0, rep(1, length(x))) ) F.pval = approxfun( g.pval$x.knots, g.pval$F.knots, method="linear", yleft=0, yright=g.pval$F.knots[length(g.pval$F.knots)]) F0.pval = function(x) return( ifelse(x > 1, 1, ifelse(x < 0, 0, x )) ) #fdr.pval = function(p) pmin( eta0 / f.pval(p), 1) # eta0*f0/ f fdr.pval = function(p) { p[ p == .Machine$double.eps ] = 0 pmin( eta0 / f.pval(p), 1) # eta0*f0/ f } Fdr.pval = function(p) pmin( eta0*p / F.pval(p), 1) # eta0*F0/ F #### step 4 #### if(verbose) cat("Step 4... compute q-values and local fdr\n") qval <- Fdr.pval(pval) lfdr <- fdr.pval(pval) #### return results #### result = list(pval=pval, qval=qval, lfdr=lfdr, statistic=statistic, param=cf.out) if (plot) { if(verbose) cat("Step 5... prepare for plotting\n") ############## # zeta > 0 in the following if(statistic=="pvalue") { f0 <- function(zeta) return( nm$f0(zeta, scale.param) ) F0 <- function(zeta) return( nm$F0(zeta, scale.param) ) get.pval <- function(zeta) return( nm$get.pval(1-zeta, scale.param) ) x0 = 1-x0 } else { f0 <- function(zeta) return( 2*nm$f0(zeta, scale.param) ) F0 <- function(zeta) return( 2*nm$F0(zeta, scale.param)-1 ) get.pval <- function(zeta) return( nm$get.pval(zeta, scale.param) ) } fdr = function(zeta) fdr.pval(get.pval(zeta)) Fdr = function(zeta) Fdr.pval(get.pval(zeta)) F = function(zeta) 1-eta0*get.pval(zeta)/Fdr(zeta) FA = function(zeta) (F(zeta)-eta0*F0(zeta))/(1-eta0) f = function(zeta) eta0*(f0(zeta))/fdr(zeta) fA = function(zeta) (f(zeta)-eta0*f0(zeta))/(1-eta0) ############## ax = abs(x) if (statistic=="pvalue") ax = 1-ax # reverse p-val plot xxx = seq(0, max(ax), length.out=500) ll = pvt.plotlabels(statistic, scale.param, eta0) par(mfrow=c(3,1)) if (color.figure) cols = c(2,4) # colors for f0,F0 and fA,FA else cols = c(1,1) hist(ax, freq=FALSE, bre=50, main=ll$main, xlab=ll$xlab, cex.main=1.8) lines(xxx, eta0*f0(xxx), col=cols[1], lwd=2, lty=3 ) lines(xxx, (1-eta0)*fA(xxx), col=cols[2], lwd=2 ) if (statistic=="pvalue") pos1 = "topleft" else pos1="topright" legend(pos1, c("Mixture", "Null Component", "Alternative Component"), lwd=c(1, 2, 2), col=c(1,cols), lty=c(1,3,1), bty="n", cex=1.5) plot(xxx, F(xxx), lwd=1, type="l", ylim=c(0,1), main="Density (first row) and Distribution Function (second row)", xlab=ll$xlab, ylab="CDF", cex.main=1.5) lines(xxx, eta0*F0(xxx), col=cols[1], lwd=2, lty=3) lines(xxx, (1-eta0)*FA(xxx), col=cols[2], lwd=2) # DEBUG show cutoff in green line #lines(c(x0,x0),c(0,1), col=3) plot(xxx, Fdr(xxx), type="l", lwd=2, ylim=c(0,1), main="(Local) False Discovery Rate", ylab="Fdr and fdr", xlab=ll$xlab, lty=3, cex.main=1.5) lines(xxx, fdr(xxx), lwd=2) if (eta0 > 0.98) pos2 = "bottomleft" else pos2="topright" legend(pos2, c("fdr (density-based)", "Fdr (tail area-based)"), lwd=c(2,2), lty=c(1,3), bty="n", cex=1.5) # DEBUG show cutoff in green line #lines(c(x0,x0),c(0,1), col=3) par(mfrow=c(1,1)) rm(ax) } if(verbose) cat("\n") return(result) } ##### ## create labels for plots pvt.plotlabels <- function(statistic, scale.param, eta0) { if (statistic=="pvalue") { main = paste("Type of Statistic: p-Value (eta0 = ", round(eta0, 4), ")", sep="") xlab ="1-pval" } if (statistic=="studentt") { df = scale.param main = paste("Type of Statistic: t-Score (df = ", round(df,3), ", eta0 = ", round(eta0, 4), ")", sep="") xlab = "abs(t)" } if (statistic=="normal") { sd = scale.param main = paste("Type of Statistic: z-Score (sd = ", round(sd,3), ", eta0 = ", round(eta0, 4), ")", sep="") xlab = "abs(z)" } if (statistic=="correlation") { kappa =scale.param main = paste("Type of Statistic: Correlation (kappa = ", round(kappa,1), ", eta0 = ", round(eta0, 4), ")", sep="") xlab = "abs(r)" } return(list(main=main, xlab=xlab)) } fdrtool/MD50000644000176200001440000000262012547153107012240 0ustar liggesusersba039a34fab816dc200ce5cc5a1b033c *DESCRIPTION 54b61b01124dcef4f17488f33b32812e *NAMESPACE 3335394c8c49ca8ef152831d855b9630 *NEWS fb8a05a5983bcdac209e6f6a0ce5d570 *R/approximate.fit.R b65308906bf121a2588edcec600d5dba *R/censored.fit.R f38f86491f5602fb3daceb45c334d9f3 *R/dcor0.R 5f77d5c6d805ec5a9f10c174d20078fe *R/ecdf.pval.R 2972495b2770da402da56d43efd3b915 *R/fdrtool.R 64997636bd46b2533f0e3d1a4e10443f *R/fndr.cutoff.R 542284c1ba229bb88dde79ee07c0a154 *R/gcmlcm.R fca370a4a1e5215a4115afb35a6dd8b5 *R/grenander.R 31679f197e18121a1ee7e0e23c2f1400 *R/halfnorm.R ca6e13120d7896054c1303c9cce65c54 *R/hc.score.R 4f6c105befa203f63e7701df56f0dbf6 *R/monoreg.R a8ef5c71def44b462aa350119b2cf8f6 *R/nullmodel.R 7555c7888e2f0d9ec38c448f5014ffce *R/pval.estimate.eta0.R eea063ddb6e028d8304ea379c27339f4 *data/pvalues.rda 114741e398186db223fdd03aa7a02e96 *man/censored.fit.Rd e8eec3f7c4ffe295ba7ebfc51ec19b61 *man/dcor0.Rd 8cf87a77c0bb5fbd9b58148912684b88 *man/fdrtool-internal.Rd fc87b7a929f28768e015db5f9f43a6a7 *man/fdrtool.Rd b71d704b64bb9c031b1d100a18eb2585 *man/gcmlcm.Rd 0e3048ce14186628260bdf0b5e827de9 *man/grenander.Rd 191080259e04bc4068fd4d08a9601947 *man/halfnorm.Rd 7e77f28ad8da19159272c64d5caf999e *man/hc.score.Rd e12ae73f8c32443ee2876f0d579d4dd7 *man/monoreg.Rd 2a0d230e39b6c522fea7244111d9fba0 *man/pval.estimate.eta0.Rd 5a83b31ae27d06e5a76967d96018982e *man/pvalues.Rd 6e76a11a518d68915d295d8ad3f14fbf *src/isomean.c fdrtool/DESCRIPTION0000644000176200001440000000235012547153107013436 0ustar liggesusersPackage: fdrtool Version: 1.2.15 Date: 2015-07-07 Title: Estimation of (Local) False Discovery Rates and Higher Criticism Author: Bernd Klaus and Korbinian Strimmer. Maintainer: Korbinian Strimmer Depends: R (>= 3.0.2) Suggests: Imports: graphics, grDevices, stats Description: Estimates both tail area-based false discovery rates (Fdr) as well as local false discovery rates (fdr) for a variety of null models (p-values, z-scores, correlation coefficients, t-scores). The proportion of null values and the parameters of the null distribution are adaptively estimated from the data. In addition, the package contains functions for non-parametric density estimation (Grenander estimator), for monotone regression (isotonic regression and antitonic regression with weights), for computing the greatest convex minorant (GCM) and the least concave majorant (LCM), for the half-normal and correlation distributions, and for computing empirical higher criticism (HC) scores and the corresponding decision threshold. License: GPL (>= 3) URL: http://strimmerlab.org/software/fdrtool/ Packaged: 2015-07-07 20:55:57 UTC; strimmer NeedsCompilation: yes Repository: CRAN Date/Publication: 2015-07-08 09:50:31 fdrtool/man/0000755000176200001440000000000012477433553012513 5ustar liggesusersfdrtool/man/grenander.Rd0000644000176200001440000000410012235226461014730 0ustar liggesusers\name{grenader} \alias{grenander} \alias{plot.grenander} \title{Grenander Estimator of a Decreasing or Increasing Density} \description{ The function \code{grenander} computes the Grenander estimator of a one-dimensional decreasing or increasing density. } \usage{ grenander(F, type=c("decreasing", "increasing")) } \arguments{ \item{F}{an \code{\link{ecdf}} containing the empirical cumulative density.} \item{type}{specifies whether the distribution is decreasing (the default) or increasing.} } \details{ The Grenander (1956) density estimator is given by the slopes of the least concave majorant (LCM) of the empirical distribution function (ECDF). It is a decreasing piecewise-constant function and can be shown to be the non-parametric maximum likelihood estimate (NPMLE) under the assumption of a decreasing density (note that the ECDF is the NPMLE without this assumption). Similarly, an increasing density function is obtained by using the greatest convex minorant (GCM) of the ECDF. } \value{ A list of class \code{grenander} with the following components: \item{F}{the empirical distribution function specified as input. } \item{x.knots}{x locations of the knots of the least concave majorant of the ECDF.} \item{F.knots}{the corresponding y locations of the least concave majorant of the ECDF.} \item{f.knots}{the corresponding slopes (=density).} } \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). } \references{ Grenander, U. (1956). On the theory of mortality measurement, Part II. \emph{Skan. Aktuarietidskr}, \bold{39}, 125--153. } \seealso{\code{\link{ecdf}}, \code{\link{gcmlcm}}, \code{\link{density}}.} \examples{ # load "fdrtool" library library("fdrtool") # samples from random exponential variable z = rexp(30,1) e = ecdf(z) g = grenander(e) g # plot ecdf, concave cdf, and Grenander density estimator (on log scale) plot(g, log="y") # for comparison the kernel density estimate plot(density(z)) # area under the Grenander density estimator sum( g$f.knots[-length(g$f.knots)]*diff(g$x.knots) ) } \keyword{univar} fdrtool/man/halfnorm.Rd0000644000176200001440000000725412235226461014606 0ustar liggesusers\name{halfnormal} \alias{halfnormal} \alias{dhalfnorm} \alias{phalfnorm} \alias{qhalfnorm} \alias{rhalfnorm} \alias{sd2theta} \alias{theta2sd} \title{The Half-Normal Distribution} \description{ Density, distribution function, quantile function and random generation for the half-normal distribution with parameter \code{theta}. } \usage{ dhalfnorm(x, theta=sqrt(pi/2), log = FALSE) phalfnorm(q, theta=sqrt(pi/2), lower.tail = TRUE, log.p = FALSE) qhalfnorm(p, theta=sqrt(pi/2), lower.tail = TRUE, log.p = FALSE) rhalfnorm(n, theta=sqrt(pi/2)) sd2theta(sd) theta2sd(theta) } \arguments{ \item{x,q}{vector of quantiles.} \item{p}{vector of probabilities.} \item{n}{number of observations. If \code{length(n) > 1}, the length is taken to be the number required.} \item{theta}{parameter of half-normal distribution.} \item{log, log.p}{logical; if TRUE, probabilities p are given as log(p).} \item{lower.tail}{logical; if TRUE (default), probabilities are \eqn{P[X \le x]}{P[X <= x]}, otherwise, \eqn{P[X > x]}{P[X > x]}.} \item{sd}{standard deviation of the zero-mean normal distribution that corresponds to the half-normal with parameter \code{theta}. } } \value{ \code{dhalfnorm} gives the density, \code{phalfnorm} gives the distribution function, \code{qhalfnorm} gives the quantile function, and \code{rhalfnorm} generates random deviates. \code{sd2theta} computes a \code{theta} parameter. \code{theta2sd} computes a \code{sd} parameter. } \details{ \code{x = abs(z)} follows a half-normal distribution with if \code{z} is a normal variate with zero mean. The half-normal distribution has density \deqn{ f(x) = \frac{2 \theta}{\pi} e^{-x^2 \theta^2/\pi}}{ f(x) = 2*theta/pi e^-(x^2*theta^2/pi) } It has mean \eqn{E(x) = \frac{1}{\theta}}{E(x) = 1/theta} and variance \eqn{Var(x) = \frac{\pi-2}{2 \theta^2}}{Var(x) = (pi-2)/(2*theta^2)}. The parameter \eqn{\theta}{theta} is related to the standard deviation \eqn{\sigma}{sigma} of the corresponding zero-mean normal distribution by the equation \eqn{\theta = \sqrt{\pi/2}/\sigma}{theta = sqrt(pi/2)/sigma}. If \eqn{\theta}{theta} is not specified in the above functions it assumes the default values of \eqn{\sqrt{\pi/2}}{sqrt(pi/2)}, corresponding to \eqn{\sigma=1}{sigma=1}. } \seealso{ \code{\link{Normal}}. } \examples{ # load "fdrtool" library library("fdrtool") ## density of half-normal compared with a corresponding normal par(mfrow=c(1,2)) sd.norm = 0.64 x = seq(0, 5, 0.01) x2 = seq(-5, 5, 0.01) plot(x, dhalfnorm(x, sd2theta(sd.norm)), type="l", xlim=c(-5, 5), lwd=2, main="Probability Density", ylab="pdf(x)") lines(x2, dnorm(x2, sd=sd.norm), col=8 ) plot(x, phalfnorm(x, sd2theta(sd.norm)), type="l", xlim=c(-5, 5), lwd=2, main="Distribution Function", ylab="cdf(x)") lines(x2, pnorm(x2, sd=sd.norm), col=8 ) legend("topleft", c("half-normal", "normal"), lwd=c(2,1), col=c(1, 8), bty="n", cex=1.0) par(mfrow=c(1,1)) ## distribution function integrate(dhalfnorm, 0, 1.4, theta = 1.234) phalfnorm(1.4, theta = 1.234) ## quantile function qhalfnorm(-1) # NaN qhalfnorm(0) qhalfnorm(.5) qhalfnorm(1) qhalfnorm(2) # NaN ## random numbers theta = 0.72 hz = rhalfnorm(10000, theta) hist(hz, freq=FALSE) lines(x, dhalfnorm(x, theta)) mean(hz) 1/theta # theoretical mean var(hz) (pi-2)/(2*theta*theta) # theoretical variance ## relationship with two-sided normal p-values z = rnorm(1000) # two-sided p-values pvl = 1- phalfnorm(abs(z)) pvl2 = 2 - 2*pnorm(abs(z)) sum(pvl-pvl2)^2 # equivalent hist(pvl2, freq=FALSE) # uniform distribution # back to half-normal scores hz = qhalfnorm(1-pvl) hist(hz, freq=FALSE) lines(x, dhalfnorm(x)) } \keyword{distribution} fdrtool/man/pvalues.Rd0000644000176200001440000000115412235226461014450 0ustar liggesusers\name{pvalues} \alias{pvalues} \title{Example p-Values} \description{ This data set contains 4,289 p-values. These data are used to illustrate the functionality of the functions \code{\link{fdrtool}} and \code{\link{pval.estimate.eta0}}. } \usage{ data(pvalues) } \format{ \code{pvalues} is a vector with 4,289 p-values. } \examples{ # load fdrtool library library("fdrtool") # load data set data(pvalues) # estimate density and distribution function, # and compute corresponding (local) false discovery rates fdrtool(pvalues, statistic="pvalue") } \keyword{datasets} fdrtool/man/monoreg.Rd0000644000176200001440000000622512235226461014443 0ustar liggesusers\name{monoreg} \alias{monoreg} \alias{plot.monoreg} \alias{fitted.monoreg} \alias{residuals.monoreg} \title{Monotone Regression: Isotonic Regression and Antitonic Regression} \usage{ monoreg(x, y=NULL, w=rep(1, length(x)), type=c("isotonic", "antitonic")) } \description{ \code{monoreg} performs monotone regression (either isotonic or antitonic) with weights. } \arguments{ \item{x, y}{coordinate vectors of the regression points. Alternatively a single \dQuote{plotting} structure can be specified: see \code{\link{xy.coords}}.} \item{w}{data weights (default values: 1).} \item{type}{fit a monotonely increasing ("isotonic") or monotonely decreasing ("antitonic") function.} } \details{ \code{monoreg} is similar to \code{\link{isoreg}}, with the addition that \code{monoreg} accepts weights. If several identical \code{x} values are given as input, the corresponding \code{y} values and the weights \code{w} are automatically merged, and a warning is issued. The \code{plot.monoreg} function optionally plots the cumulative sum diagram with the greatest convex minorant (isotonic regression) or the least concave majorant (antitonic regression), see the examples below. } \value{ A list with the following entries: \item{x}{the sorted and unique x values} \item{y}{the corresponding y values} \item{w}{the corresponding weights} \item{yf}{the fitted y values} \item{type}{the type of monotone regression ("isotonic" or "antitonic"} \item{call}{the function call} } \references{ Robertson, T., F. T. Wright, and R. L. Dykstra. 1988. Order restricted statistical inference. John Wiley and Sons. } \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). Part of this function is C code that has been ported from R code originally written by Kaspar Rufibach. } \seealso{\code{\link{isoreg}}.} \examples{ # load "fdrtool" library library("fdrtool") # an example with weights # Example 1.1.1. (dental study) from Robertson, Wright and Dykstra (1988) age = c(14, 14, 8, 8, 8, 10, 10, 10, 12, 12, 12) size = c(23.5, 25, 21, 23.5, 23, 24, 21, 25, 21.5, 22, 19) mr = monoreg(age, size) # sorted x values mr$x # 8 10 12 14 # weights and merged y values mr$w # 3 3 3 2 mr$y # 22.50000 23.33333 20.83333 24.25000 # fitted y values mr$yf # 22.22222 22.22222 22.22222 24.25000 fitted(mr) residuals(mr) plot(mr, ylim=c(18, 26)) # this shows the averaged data points points(age, size, pch=2) # add original data points ### y = c(1,0,1,0,0,1,0,1,1,0,1,0) x = 1:length(y) mr = monoreg(y) # plot with greatest convex minorant plot(mr, plot.type="row.wise") # this is the same mr = monoreg(x,y) plot(mr) # antitonic regression and least concave majorant mr = monoreg(-y, type="a") plot(mr, plot.type="row.wise") # the fit yf is independent of the location of x and y plot(monoreg(x + runif(1, -1000, 1000), y +runif(1, -1000, 1000)) ) ### y = c(0,0,2/4,1/5,2/4,1/2,4/5,5/8,7/11,10/11) x = c(5,9,13,18,22,24,29,109,120,131) mr = monoreg(x,y) plot(mr, plot.type="row.wise") # the fit (yf) only depends on the ordering of x monoreg(1:length(y), y)$yf monoreg(x, y)$yf } \keyword{regression} \keyword{smooth} fdrtool/man/fdrtool-internal.Rd0000644000176200001440000000073412235226461016257 0ustar liggesusers\name{fdrtool-internal} \alias{pvt.isoMean} \alias{r2t} \alias{t2r} \alias{pvt.nullfunction} \alias{pvt.plotlabels} \alias{ecdf.pval} \alias{num.curv} \alias{approximate.fit} \alias{iqr.fit} \alias{get.nullmodel} \alias{pvt.fit.nullmodel} \title{Internal fdrtool Functions} \description{ Internal fdrtool functions. } \note{ These are not to be called by the user (or in some cases are just waiting for proper documentation to be written). } \keyword{internal} fdrtool/man/hc.score.Rd0000644000176200001440000000346112235226461014500 0ustar liggesusers\name{hc.score} \alias{hc.score} \alias{hc.thresh} \title{Compute Empirical Higher Criticism Scores and Corresponding Decision Threshold From p-Values} \usage{ hc.score(pval) hc.thresh(pval, alpha0=1, plot=TRUE) } \description{ \code{hc.score} computes the empirical higher criticism (HC) scores from p-values. \code{hc.thresh} determines the HC decision threshold by searching for the p-value with the maximum HC score. } \arguments{ \item{pval}{vector of p-values.} \item{alpha0}{look only at a fraction \code{alpha0} of the p-values (default: 1, i.e. all p-values).} \item{plot}{show plot with HC decision threshold.} } \details{ Higher Criticism (HC) provides an alternative means to determine decision thresholds for signal identification, especially if the signal is rare and weak. See Donoho and Jin (2008) for details of this approach and Klaus and Strimmer (2012) for a review and connections with FDR methdology. } \value{ \code{hc.score} returns a vector with the HC score corresponding to each p-value. \code{hc.thresh} returns the p-value corresponding to the maximum HC score. } \author{ Bernd Klaus and Korbinian Strimmer (\url{http://strimmerlab.org}). } \references{ Donoho, D. and J. Jin. (2008). Higher criticism thresholding: optimal feature selection when useful features are rare and weak. Proc. Natl. Acad. Sci. USA 105:14790-15795. Klaus, B., and K. Strimmer (2013). Signal identification for rare and weak features: higher criticism or false discovery rates? Biostatistics 14: 129-143. Preprint available from \url{http://arxiv.org/abs/1112.2615}. } \seealso{\code{\link{fdrtool}}.} \examples{ # load "fdrtool" library library("fdrtool") # some p-values data(pvalues) # compute HC scores hc.score(pvalues) # determine HC threshold hc.thresh(pvalues) } \keyword{htest} fdrtool/man/gcmlcm.Rd0000644000176200001440000000316012235226461014232 0ustar liggesusers\name{gcmlcm} \alias{gcmlcm} \title{Greatest Convex Minorant and Least Concave Majorant} \usage{ gcmlcm(x, y, type=c("gcm", "lcm")) } \description{ \code{gcmlcm} computes the greatest convex minorant (GCM) or the least concave majorant (LCM) of a piece-wise linear function. } \arguments{ \item{x, y}{coordinate vectors of the piece-wise linear function. Note that the x values need to be unique and be arranged in sorted order.} \item{type}{specifies whether to compute the greatest convex minorant (\code{type="gcm"}, the default) or the least concave majorant (\code{type="lcm"}).} } \details{ The GCM is obtained by isotonic regression of the raw slopes, whereas the LCM is obtained by antitonic regression. See Robertson et al. (1988). } \value{ A list with the following entries: \item{x.knots}{the x values belonging to the knots of the LCM/GCM curve} \item{y.knots}{the corresponding y values} \item{slope.knots}{the slopes of the corresponding line segments} } \references{ Robertson, T., F. T. Wright, and R. L. Dykstra. 1988. Order restricted statistical inference. John Wiley and Sons. } \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). } \seealso{\code{\link{monoreg}}.} \examples{ # load "fdrtool" library library("fdrtool") # generate some data x = 1:20 y = rexp(20) plot(x, y, type="l", lty=3, main="GCM (red) and LCM (blue)") points(x, y) # greatest convex minorant (red) gg = gcmlcm(x,y) lines(gg$x.knots, gg$y.knots, col=2, lwd=2) # least concave majorant (blue) ll = gcmlcm(x,y, type="lcm") lines(ll$x.knots, ll$y.knots, col=4, lwd=2) } \keyword{smooth} fdrtool/man/pval.estimate.eta0.Rd0000644000176200001440000000674212477433551016415 0ustar liggesusers\name{pval.estimate.eta0} \alias{pval.estimate.eta0} \title{Estimate the Proportion of Null p-Values} \usage{ pval.estimate.eta0(p, method=c("smoother", "bootstrap", "conservative", "adaptive", "quantile"), lambda=seq(0,0.9,0.05), diagnostic.plot=TRUE, q=0.1) } \description{ \code{pval.estimate.eta0} estimates the proportion eta0 of null p-values in a given vector of p-values. } \arguments{ \item{p}{vector of p-values} \item{method}{algorithm used to estimate the proportion of null p-values. Available options are "conservative" , "adaptive", "bootstrap", quantile, and "smoother" (default).} \item{lambda}{optional tuning parameter vector needed for "bootstrap" and "smoothing" methods (defaults to \code{seq(0,0.9,0.05)}) - see Storey (2002) and Storey and Tibshirani (2003).} \item{diagnostic.plot}{if \code{TRUE} (the default) the histogram of the p-values together with the estimate of \code{eta0} null line is plotted. This is useful to visually check the fit of the estimated proportion of null p-values.} \item{q}{quantile used for estimating eta0 - only if \code{method}="quantile"} } \details{ This quantity \code{eta0}, i.e. the proportion eta0 of null p-values in a given vector of p-values, is an important parameter when controlling the false discovery rate (FDR). A conservative choice is eta0 = 1 but a choice closer to the true value will increase efficiency and power - see Benjamini and Hochberg (1995, 2000) and Storey (2002) for details. The function \code{pval.estimate.eta0} provides five algorithms: the "conservative" method always returns eta0 = 1 (Benjamini and Hochberg, 1995), "adaptive" uses the approach suggested in Benjamini and Hochberg (2000), "bootstrap" employs the method from Storey (2002), "smoother" uses the smoothing spline approach in Storey and Tibshirani (2003), and "quantile" is a simplified version of "smoother". } \value{ The estimated proportion eta0 of null p-values. } \references{ \emph{"conservative" procedure:} Benjamini, Y., and Y. Hochberg (1995) Controlling the false discovery rate: a practical and powerful approach to multiple testing. \emph{J. Roy. Statist. Soc. B}, \bold{57}, 289--300. \emph{"adaptive" procedure:} Benjamini, Y., and Y. Hochberg (2000) The adaptive control of the false discovery rate in multiple hypotheses testing with independent statistics. \emph{J. Behav. Educ. Statist.}, \bold{25}, 60--83. \emph{"bootstrap" procedure:} Storey, J. D. (2002) A direct approach to false discovery rates. \emph{J. Roy. Statist. Soc. B.}, \bold{64}, 479--498. \emph{"smoother" procedure:} Storey, J. D., and R. Tibshirani (2003) Statistical significance for genome-wide experiments. \emph{Proc. Nat. Acad. Sci. USA}, \bold{100}, 9440-9445. \emph{"quantile" procedure:} similar to smoother, except that the lower q quantile of all eta0 computed in dependence of lambda is taken as overall estimate of eta0. } \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). Adapted in part from code by Y. Benjamini and J.D. Storey. } \seealso{\code{\link{fdrtool}}.} \examples{ # load "fdrtool" library and p-values library("fdrtool") data(pvalues) # Proportion of null p-values for different methods pval.estimate.eta0(pvalues, method="conservative") pval.estimate.eta0(pvalues, method="adaptive") pval.estimate.eta0(pvalues, method="bootstrap") pval.estimate.eta0(pvalues, method="smoother") pval.estimate.eta0(pvalues, method="quantile") } \keyword{htest} fdrtool/man/censored.fit.Rd0000644000176200001440000000364712235226461015365 0ustar liggesusers\name{censored.fit} \alias{censored.fit} \alias{fndr.cutoff} \title{Fit Null Distribution To Censored Data by Maximum Likelihood} \usage{ censored.fit(x, cutoff, statistic=c("normal", "correlation", "pvalue", "studentt")) fndr.cutoff(x, statistic=c("normal", "correlation", "pvalue", "studentt")) } \description{ \code{censored.fit} fits a null distribution to censored data. \code{fndr.cutoff} finds a suitable cutoff point based on the (approximate) false non-discovery rate (FNDR). } \arguments{ \item{x}{vector of test statistics.} \item{cutoff}{truncation point (this may a single value or a vector).} \item{statistic}{type of statistic - normal, correlation, or student t.} } \details{ As null model truncated normal, truncated student t or a truncated correlation density is assumed. The truncation point is specified by the cutoff parameter. All data points whose absolute value are large than the cutoff point are ignored when fitting the truncated null model via maximum likelihood. The total number of data points is only used to estimate the fraction of null values eta0. } \value{ \code{censored.fit} returns a matrix whose rows contain the estimated parameters and corresponding errors for each cutoff point. \code{fndr.cutoff} returns a tentative cutoff point. } \seealso{\code{\link{fdrtool}}.} \examples{ # load "fdrtool" library library("fdrtool") # simulate normal data sd.true = 2.232 n = 5000 z = rnorm(n, sd=sd.true) censored.fit(z, c(2,3,5), statistic="normal") # simulate contaminated mixture of correlation distribution r = rcor0(700, kappa=10) u1 = runif(200, min=-1, max=-0.7) u2 = runif(200, min=0.7, max=1) rc = c(r, u1, u2) censored.fit(r, 0.7, statistic="correlation") censored.fit(rc, 0.7, statistic="correlation") # pvalue example data(pvalues) co = fndr.cutoff(pvalues, statistic="pvalue") co censored.fit(pvalues, cutoff=co, statistic="pvalue") } \keyword{htest} fdrtool/man/dcor0.Rd0000644000176200001440000000525012235226461014001 0ustar liggesusers\name{dcor0} \alias{dcor0} \alias{pcor0} \alias{rcor0} \alias{qcor0} \title{Distribution of the Vanishing Correlation Coefficient (rho=0) and Related Functions} \usage{ dcor0(x, kappa, log=FALSE) pcor0(q, kappa, lower.tail=TRUE, log.p=FALSE) qcor0(p, kappa, lower.tail=TRUE, log.p=FALSE) rcor0(n, kappa) } \arguments{ \item{x,q}{vector of sample correlations} \item{p}{vector of probabilities} \item{kappa}{the degree of freedom of the distribution (= inverse variance)} \item{n}{number of values to generate. If n is a vector, length(n) values will be generated} \item{log, log.p}{logical vector; if TRUE, probabilities p are given as log(p)} \item{lower.tail}{logical vector; if TRUE (default), probabilities are \eqn{P[R <= r]}, otherwise, \eqn{P[R > r]}} } \description{ The above functions describe the distribution of the Pearson correlation coefficient \code{r} assuming that there is no correlation present (\code{rho = 0}). Note that the distribution has only a single parameter: the degree of freedom \code{kappa}, which is equal to the inverse of the variance of the distribution. The theoretical value of \code{kappa} depends both on the sample size \code{n} and the number \code{p} of considered variables. If a simple correlation coefficient between two variables (\code{p=2}) is considered the degree of freedom equals \code{kappa = n-1}. However, if a partial correlation coefficient is considered (conditioned on \code{p-2} remaining variables) the degree of freedom is \code{kappa = n-1-(p-2) = n-p+1}. } \details{ For density and distribution functions as well as a corresponding random number generator of the correlation coefficient for arbitrary non-vanishing correlation \code{rho} please refer to the \code{SuppDists} package by Bob Wheeler \email{bwheeler@echip.com} (available on CRAN). Note that the parameter \code{N} in his \code{dPearson} function corresponds to \code{N=kappa+1}. } \value{ \code{dcor0} gives the density, \code{pcor0} gives the distribution function, \code{qcor0} gives the quantile function, and \code{rcor0} generates random deviates. } \seealso{\code{\link{cor}}.} \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). } \examples{ # load fdrtool library library("fdrtool") # distribution of r for various degrees of freedom x = seq(-1,1,0.01) y1 = dcor0(x, kappa=7) y2 = dcor0(x, kappa=15) plot(x,y2,type="l", xlab="r", ylab="pdf", xlim=c(-1,1), ylim=c(0,2)) lines(x,y1) # simulated data r = rcor0(1000, kappa=7) hist(r, freq=FALSE, xlim=c(-1,1), ylim=c(0,5)) lines(x,y1,type="l") # distribution function pcor0(-0.2, kappa=15) } \keyword{distribution} fdrtool/man/fdrtool.Rd0000644000176200001440000001057112235226461014445 0ustar liggesusers\name{fdrtool} \alias{fdrtool} \title{Estimate (Local) False Discovery Rates For Diverse Test Statistics} \usage{ fdrtool(x, statistic=c("normal", "correlation", "pvalue"), plot=TRUE, color.figure=TRUE, verbose=TRUE, cutoff.method=c("fndr", "pct0", "locfdr"), pct0=0.75) } \description{ \code{fdrtool} takes a vector of z-scores (or of correlations, p-values, or t-statistics), and estimates for each case both the tail area-based Fdr as well as the density-based fdr (=q-value resp. local false discovery rate). The parameters of the null distribution are estimated adaptively from the data (except for the case of p-values where this is not necessary). } \arguments{ \item{x}{vector of the observed test statistics.} \item{statistic}{one of "normal" (default), "correlation", "pvalue". This species the null model.} \item{plot}{plot a figure with estimated densities, distribution functions, and (local) false discovery rates.} \item{verbose}{print out status messages.} \item{cutoff.method}{one of "fndr" (default), "pct0", "locfdr".} \item{pct0}{fraction of data used for fitting null model - only if \code{cutoff.method}="pct0"} \item{color.figure}{determines whether a color figure or a black and white figure is produced (defaults to "TRUE", i.e. to color figure).} } \details{ The algorithm implemented in this function proceeds as follows: \enumerate{ \item A suitable cutoff point is determined. If \code{cutoff.method} is "fndr" then first an approximate null model is fitted and subsequently a cutoff point is sought with false nondiscovery rate as small as possible (see \code{\link{fndr.cutoff}}). If \code{cutoff.method} is "pct0" then a specified quantile (default value: 0.75) of the data is used as the cutoff point. If \code{cutoff.method} equals "locfdr" then the heuristic of the "locfdr" package (version 1.1-6) is employed to find the cutoff (z-scores and correlations only). \item The parameters of the null model are estimated from the data using \code{\link{censored.fit}}. This results in estimates for scale parameters und and proportion of null values (\code{eta0}). \item Subsequently the corresponding p-values are computed, and a modified \code{\link{grenander}} algorithm is employed to obtain the overall density and distribution function (note that this respects the estimated \code{eta0}). \item Finally, q-values and local fdr values are computed for each case. } The assumed null models all have (except for p-values) one free scale parameter. Note that the z-scores and the correlations are assumed to have zero mean. } \value{ A list with the following components: \item{pval}{a vector with p-values for each case.} \item{qval}{a vector with q-values (Fdr) for each case.} \item{lfdr}{a vector with local fdr values for each case.} \item{statistic}{the specified type of null model.} \item{param}{a vector containing the estimated parameters (the null proportion \code{eta0} and the free parameter of the null model).} } \author{ Korbinian Strimmer (\url{http://strimmerlab.org}). } \references{ Strimmer, K. (2008a). A unified approach to false discovery rate estimation. BMC Bioinformatics 9: 303. Available from \url{http://www.biomedcentral.com/1471-2105/9/303/}. Strimmer, K. (2008b). fdrtool: a versatile R package for estimating local and tail area- based false discovery rates. Bioinformatics 24: 1461-1462. Available from \url{http://bioinformatics.oxfordjournals.org/cgi/content/abstract/24/12/1461}. } \seealso{\code{\link{pval.estimate.eta0}}, \code{\link{censored.fit}}.} \examples{ # load "fdrtool" library and p-values library("fdrtool") data(pvalues) # estimate fdr and Fdr from p-values data(pvalues) fdr = fdrtool(pvalues, statistic="pvalue") fdr$qval # estimated Fdr values fdr$lfdr # estimated local fdr # the same but with black and white figure fdr = fdrtool(pvalues, statistic="pvalue", color.figure=FALSE) # estimate fdr and Fdr from z-scores sd.true = 2.232 n = 500 z = rnorm(n, sd=sd.true) z = c(z, runif(30, 5, 10)) # add some contamination fdr = fdrtool(z) # you may change some parameters of the underlying functions fdr = fdrtool(z, cutoff.method="pct0", pct0=0.9) } \keyword{htest}