acepack/0000755000176000001440000000000012140735252011672 5ustar ripleyusersacepack/MD50000644000176000001440000000122612140735252012203 0ustar ripleyusers7813187c18b20511f88b6b3650057d73 *CHANGES f885d8265176379b5189d845e98eae92 *DESCRIPTION e649ea57e718ff01cbf8f550215b65e4 *LICENSE 9fdfeb11f7ddba6f3aab9aaa6b1ac5dd *NAMESPACE 442dd0d76458d0eb9fac93d79a71aa08 *R/acepack.R f6b7e0fa54360a97e4f82e25a271facc *R/zzz.R c40beeade0631086674a30c40ef0db4c *README 720a673beec675a340036a36cd6b16af *README.ace 4ba587580ff02aef8ea942c9b80c64ca *README.avas 473d3304ffc1fec03893b0284959bd44 *ace.doc 7c381591c0506ef0c4516fb9790a81bb *man/ace.Rd 5458d8ccd26dc095ab490a39ef952ed3 *man/avas.Rd 78c4e2fb1f92842c33124a530c995b99 *src/ace.f 93c0d1ce31e7293e4c233f0d409742d8 *src/avas.f ff626e4f6a4754a383ce9598ebcced09 *src/rlsmo.f acepack/src/0000755000176000001440000000000012134444614012463 5ustar ripleyusersacepack/src/rlsmo.f0000644000176000001440000005451112140735053013771 0ustar ripleyusersC MORTRAN 2.79 (RESERVED KEYWORD MACROS OF 09/28/81) SUBROUTINE RLSMO(X,Y,W,SPAN,DOF,N,SMO,RSS,SCRAT) 22 double precision X(N),Y(N),W(N),SMO(N),SCRAT(N) 23 DOUBLE PRECISION CVRSS(6),CVSPAN(6),CVMIN, SPAN, RSS 24 INTEGER IDMIN 25 integer cross 26 DATA CVSPAN/0.3,0.4,0.5,0.6,0.7,1.0/ 27 cross=0 28 IF(span.eq.0) cross=1 29 PENAL=0.01 30 CVMIN=1E15 31 IDMIN=1 33 IF(CROSS .NE. 1)GOTO 10021 37 K=1 37 GOTO 10033 37 10031 K=K+1 37 10033 IF((K).GT.(6))GOTO 10032 37 CALL SMTH(X,Y,W,CVSPAN(K), DOF,N,1,SMO,S0,CVRSS(K),SCRAT) 39 IF(CVRSS(K) .GT. CVMIN)GOTO 10051 40 CVMIN=CVRSS(K) 41 IDMIN=K 42 10051 CONTINUE 43 GOTO 10031 44 10032 CONTINUE 44 SPAN=CVSPAN(IDMIN) 45 IF(PENAL .LE. 0.)GOTO 10071 46 CVMIN=(1.+PENAL)*CVMIN 48 K=6 48 GOTO 10083 48 10081 K=K+(-1) 48 10083 IF((-1)*((K)-(1)).GT.0)GOTO 10082 48 IF(CVRSS(K) .GT. CVMIN)GOTO 10101 48 GOTO 10082 48 10101 CONTINUE 49 GOTO 10081 50 10082 CONTINUE 50 SPAN=CVSPAN(K) 51 10071 CONTINUE 52 10021 CONTINUE 53 CALL SMTH(X,Y,W,SPAN,DOF,N,0,SMO,S0,RSS,SCRAT) 54 DO 10111 i=1,n 54 smo(i)=smo(i)+s0 54 10111 CONTINUE 55 10112 CONTINUE 55 RETURN 56 END 57 SUBROUTINE SMTH(X,Y,W,SPAN,DOF,N,CROSS,SMO,S0,RSS,SCRAT) 58 double precision X(N),Y(N),W(N),SMO(N),SCRAT(N),RSS,SPAN 59 DOUBLE PRECISION SUMW,XBAR,YBAR,COV,VAR 60 INTEGER FIXEDS,CROSS,LINE 70 LINE=1 83 FIXEDS=1 84 IF(SPAN .GE. 1.0)GOTO 10131 84 LINE=0 84 10131 CONTINUE 86 XBAR=X(1) 86 YBAR=Y(1) 86 COV=0. 86 VAR=0. 86 SUMW=W(1) 88 IF(LINE .NE. 1)GOTO 10151 91 DO 10161 I=2,N 91 XIN=X(I) 91 YIN=Y(I) 91 WIN=W(I) 91 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 91 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 91 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 91 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 91 SUMW=SUMW+WIN 91 10161 CONTINUE 92 10162 CONTINUE 92 I=1 94 GOTO 10173 94 10171 I=I+1 94 10173 IF((I).GT.(N))GOTO 10172 94 IF(.NOT.(CROSS.eq.1))GOTO 10191 94 XOUT=X(I) 94 YOUT=Y(I) 94 WIN=W(I) 94 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 94 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 94 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 94 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 94 SUMW=SUMW-WIN 94 10191 CONTINUE 95 IF(VAR .LE. 0.)GOTO 10211 97 SMO(I)=COV*(X(I)-XBAR)/VAR 98 GOTO 10221 99 10211 CONTINUE 99 SMO(I)=0 99 10221 CONTINUE 100 10201 CONTINUE 100 IF(.NOT.(CROSS.eq.1))GOTO 10241 100 XIN=X(I) 100 YIN=Y(I) 100 WIN=W(I) 100 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 100 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 100 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 100 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 100 SUMW=SUMW+WIN 100 10241 CONTINUE 101 GOTO 10171 102 10172 CONTINUE 102 S0=YBAR 103 SCRAT(1)=COV/VAR 104 DOF=1.0 105 GOTO 10251 107 10151 CONTINUE 111 ITOLD=1 111 IBOLD=1 111 DOF=-1.0 115 DO 10261 I=1,N 115 SCRAT(I)=Y(I) 115 10261 CONTINUE 116 10262 CONTINUE 116 IF(.NOT.(cross.eq.0))GOTO 10281 117 I=0 118 10291 IF(I.GE.N-1) GOTO 10292 118 I=I+1 119 M0=I 120 10301 IF(X(I+1).GT.X(I)) GOTO 10302 120 I=I+1 120 IF(I .LT. N)GOTO 10301 120 10302 CONTINUE 121 IF(I.EQ.M0)GOTO 10291 122 NTIE=I-M0+1 123 R=0. 123 WT=0. 123 DO 10311 JJ=M0,I 123 J=JJ 124 R=R+Y(J)*W(J) 124 WT=WT+W(J) 124 10311 CONTINUE 124 10312 CONTINUE 124 R=R/WT 125 DO 10321 J=M0,I 125 Y(J)=R 125 10321 CONTINUE 126 10322 CONTINUE 126 GOTO 10291 127 10292 CONTINUE 127 10281 CONTINUE 128 ISPAN=N*SPAN 129 IF(.NOT.(FIXEDS.eq.1))GOTO 10341 129 IS2=ISPAN/2 129 IF(IS2 .GE. 1)GOTO 10361 129 IS2=1 129 10361 CONTINUE 129 10341 CONTINUE 135 DO 10371 I=1,N 136 ITNEW=MIN(I+IS2,N) 136 IBNEW=MAX(I-IS2,1) 137 10381 IF(ITOLD .GE. ITNEW) GOTO 10382 137 ITOLD=ITOLD+1 137 XIN=X(ITOLD) 137 YIN=Y(ITOLD) 137 WIN=W(ITOLD) 137 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 137 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 137 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 137 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 137 SUMW=SUMW+WIN 137 GOTO 10381 138 10382 CONTINUE 138 10391 IF(IBOLD .LE. IBNEW) GOTO 10392 138 IBOLD=IBOLD-1 138 XIN=X(IBOLD) 138 YIN=Y(IBOLD) 138 WIN=W(IBOLD) 138 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 138 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 138 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 138 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 138 SUMW=SUMW+WIN 138 GOTO 10391 139 10392 CONTINUE 139 10401 IF(ITOLD .LE. ITNEW) GOTO 10402 139 XOUT=X(ITOLD) 139 YOUT=Y(ITOLD) 139 WIN=W(ITOLD) 139 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 139 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 139 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 139 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 139 SUMW=SUMW-WIN 139 ITOLD=ITOLD-1 139 GOTO 10401 140 10402 CONTINUE 140 10411 IF(IBOLD .GE. IBNEW) GOTO 10412 140 XOUT=X(IBOLD) 140 YOUT=Y(IBOLD) 140 WIN=W(IBOLD) 140 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 140 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 140 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 140 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 140 SUMW=SUMW-WIN 140 IBOLD=IBOLD+1 140 GOTO 10411 142 10412 CONTINUE 142 IF(.NOT.(CROSS.eq.1))GOTO 10431 142 XOUT=X(I) 142 YOUT=Y(I) 142 WIN=W(I) 142 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 142 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 142 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 142 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 142 SUMW=SUMW-WIN 142 10431 CONTINUE 143 IF(VAR .LE. 0.)GOTO 10451 145 SMO(I)=YBAR+COV*(X(I)-XBAR)/VAR 146 DOF=DOF+W(I)/SUMW+ (W(I)*(X(I)-XBAR)**2)/VAR 148 GOTO 10461 149 10451 CONTINUE 149 SMO(I)=YBAR 149 DOF=DOF+W(I)/SUMW 149 10461 CONTINUE 150 10441 CONTINUE 150 IF(.NOT.(CROSS.eq.1))GOTO 10481 150 XIN=X(I) 150 YIN=Y(I) 150 WIN=W(I) 150 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 150 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 150 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 150 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 150 SUMW=SUMW+WIN 150 10481 CONTINUE 151 10371 CONTINUE 155 10372 CONTINUE 155 DO 10491 I=1,N 155 Y(I)=SCRAT(I) 155 10491 CONTINUE 156 10492 CONTINUE 156 IF(CROSS .NE. 0)GOTO 10511 157 I=0 158 10521 IF(I.GE.N-1) GOTO 10522 158 I=I+1 159 M0=I 160 10531 IF(X(I+1).GT.X(I)) GOTO 10532 160 I=I+1 160 IF(I .LT. N)GOTO 10531 160 10532 CONTINUE 161 IF(I.EQ.M0)GOTO 10521 162 NTIE=I-M0+1 163 R=0. 163 WT=0. 163 DO 10541 JJ=M0,I 163 J=JJ 164 R=R+SMO(J)*W(J) 164 WT=WT+W(J) 164 10541 CONTINUE 164 10542 CONTINUE 164 R=R/WT 165 DO 10551 J=M0,I 165 SMO(J)=R 165 10551 CONTINUE 166 10552 CONTINUE 166 GOTO 10521 167 10522 CONTINUE 167 10511 CONTINUE 168 YBAR=0.0 168 SUMW=0.0 169 DO 10561 I=1,N 169 YBAR=YBAR+W(I)*Y(I) 169 SUMW=SUMW+W(I) 169 10561 CONTINUE 170 10562 CONTINUE 170 YBAR=YBAR/SUMW 171 DO 10571 I=1,N 171 SMO(I)=SMO(I)-YBAR 171 10571 CONTINUE 172 10572 CONTINUE 172 S0=YBAR 173 10251 CONTINUE 174 10141 CONTINUE 174 RSS=0.0 175 DO 10581 I=1,N 175 RSS=RSS+(W(I)/SUMW)*(Y(I)-S0-SMO(I))**2 175 10581 CONTINUE 178 10582 CONTINUE 178 RETURN 178 END 178 acepack/src/avas.f0000644000176000001440000004240512140735053013566 0ustar ripleyusers subroutine avas(p,n,x,y,w,l,delrsq,tx,ty,rsq,ierr,m,z,yspan,iter, 1 iters) integer p,pp1,pp2,m(n,*),l(*) double precision y(n),x(n,p),w(n),ty(n),tx(n,p),z(n,17),ct(10) double precision iters(100,2), delrsq, rsq, yspan, rss common /parms/ itape,maxit,nterm,span,alpha double precision sm,sv,sw,svx ierr = 0 pp1 = p+1 pp2 = p + 2 sm = 0.0 sv = sm sw = sv np = 0 do 23000 i = 1,p if(.not.(l(i).gt.0))goto 23002 np = np+1 23002 continue 23000 continue do 23004 j = 1,n sm = sm+w(j)*y(j) sv = sv+w(j)*y(j)**2 sw = sw+w(j) m(j,pp1) = j z(j,2) = y(j) 23004 continue sm = sm/sw sv = sv/sw-sm**2 sv = 1.0/dsqrt(sv) do 23006 j = 1,n z(j,1) = (y(j)-sm)*sv 23006 continue call sort(z(1,2),m(1,pp1),1,n) do 23008 i = 1,p if(.not.(l(i) .gt. 0))goto 23010 sm=0 do 23012 j=1,n sm=sm+w(j)*x(j,i) 23012 continue sm=sm/sw do 23014 j = 1,n m(j,i) = j z(j,2) = x(j,i) 23014 continue call sort(z(1,2),m(1,i),1,n) 23010 continue 23008 continue rsq = 0.0 iter = 0 nterm = min0(nterm,10) nt = 0 do 23016 i = 1,nterm ct(i) = 100.0 23016 continue do 23018 j=1,n ty(j)=z(j,1) 23018 continue do 23020 j = 1,n z(j,9)=ty(j) 23020 continue call bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=0 23022 continue iter=iter +1 if(.not.(l(pp1).eq.4))goto 23025 go to 992 23025 continue call calcmu(n,p,l,z,tx) do 23027 j=1,n tres=(ty(j)-z(j,10)) if(.not.(abs(tres).lt.1e-10))goto 23029 tres=1e-10 23029 continue z(j,2)=log(sqrt(tres**2)) m(j,pp2)=j 23027 continue call sort(z(1,10),m(1,pp2),1,n) do 23031 j=1,n k=m(j,pp2) z(j,4)=z(k,2) z(j,5)=w(k) 23031 continue c NB: rss is double precision, dof is not. call rlsmo(z(1,10),z(1,4),z(1,5),yspan,dof,n,z(1,6),rss,z(1,7)) do 23033 j=1,n k=m(j,pp2) z(j,7)=exp(-z(j,6)) sumlog=sumlog+n*(w(j)/sw)*2*z(j,6) z(j,8)=ty(k) 23033 continue call ctsub(n,z(1,10),z(1,7),z(1,8),z(1,9)) sm=0 do 23035 j=1,n sm=sm+w(j)*z(j,9) 23035 continue do 23037 j=1,n k=m(j,pp2) ty(k)=z(j,9)-sm/sw 23037 continue sv=0 svx=0 do 23039 j=1,n sv=sv+(w(j)/sw)*ty(j)*ty(j) svx=svx+(w(j)/sw)*z(j,10)*z(j,10) 23039 continue do 23041 j=1,n ty(j)=ty(j)/dsqrt(sv) do 23043 i=1,p if(.not.( l(i) .gt. 0))goto 23045 tx(j,i)=tx(j,i)/dsqrt(svx) 23045 continue 23043 continue 23041 continue 992 continue do 23047 j = 1,n z(j,9)=ty(j) 23047 continue call bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=sumlog+n*dlog(sv) rr=0 call calcmu(n,p,l,z,tx) do 23049 j=1,n rr=rr+(w(j)/sw)*(ty(j)-z(j,10))**2 23049 continue rsq=1-rr rnew=sumlog+rr iters(iter,1)=iter iters(iter,2)=rsq nt = mod(nt,nterm)+1 ct(nt) = rsq cmn = 100.0 cmx = -100.0 do 23051 i = 1,nterm cmn = min(cmn,ct(i)) cmx = max(cmx,ct(i)) 23051 continue if(.not.(cmx-cmn.le.delrsq.or.iter.ge.maxit.or.l(pp1).eq.4)) 1 goto 23053 return 23053 continue 23023 goto 23022 return end subroutine calcmu(n,p,l,z,tx) integer p, l(*) double precision z(n,17),tx(n,p) do 23055 j=1,n z(j,10)=0 do 23057 i=1,p if(.not.(l(i) .gt. 0))goto 23059 z(j,10)=z(j,10)+tx(j,i) 23059 continue 23057 continue 23055 continue return end subroutine bakfit(iter,delrsq,rsq,sw,l,z,m,x,ty,tx,w,n,p,np) integer l(*),m(n,*),p double precision z(n,17),ty(n),tx(n,p),x(n,p),w(n) double precision sm,sv,sw, delrsq, rsq common /parms/ itape,maxit,nterm,span,alpha call calcmu(n,p,l,z,tx) do 23061 j=1,n ty(j)=ty(j)-z(j,10) 23061 continue nit=0 23063 continue rsqi = rsq nit = nit+1 do 23066 i = 1,p if(.not.(l(i).gt.0))goto 23068 do 23070 j = 1,n k = m(j,i) z(j,1) = ty(k)+tx(k,i) z(j,2) = x(k,i) z(j,7) = w(k) 23070 continue call smothr(l(i),n,z(1,2),z,z(1,7),z(1,6),z(1,11)) sm = 0.0 do 23072 j = 1,n sm = sm+z(j,7)*z(j,6) 23072 continue sm = sm/sw do 23074 j = 1,n z(j,6) = z(j,6)-sm 23074 continue sv = 0.0 do 23076 j = 1,n sv = sv+z(j,7)*(z(j,1)-z(j,6))**2 23076 continue sv = 1.0-sv/sw rsq = sv do 23078 j = 1,n k = m(j,i) tx(k,i) = z(j,6) ty(k) = z(j,1)-z(j,6) 23078 continue 23068 continue 23066 continue 23064 if(.not.(np.eq.1.or.abs(rsq-rsqi).le.delrsq.or.nit.ge.maxit)) 1 goto 23063 if(.not.(rsq.eq.0.0.and.iter.eq.0))goto 23080 do 23082 i = 1,p if(.not.(l(i).gt.0))goto 23084 do 23086 j = 1,n tx(j,i) = x(j,i) 23086 continue 23084 continue 23082 continue 23080 continue return end subroutine ctsub(n,u,v,y,ty) double precision u(*),v(*),y(*),ty(*) i=1 23088 if(.not.(i.le.n))goto 23090 if(.not.(y(i).le.u(1)))goto 23091 ty(i)=(y(i)-u(1))*v(1) goto 23092 23091 continue j=1 ty(i)=0 23093 if(.not.((j.le.n) .and. (y(i).gt.u(j)) ))goto 23094 if(.not.(j .gt. 1))goto 23095 ty(i)=ty(i)+(u(j)-u(j-1))*(v(j)+v(j-1))/2 23095 continue j=j+1 goto 23093 23094 continue if(.not.(y(i).le.u(n)))goto 23097 ty(i)=ty(i)+.5*(y(i)-u(j-1))*(2*v(j-1)+(y(i)-u(j-1))*(v(j)-v(j-1)) 1 /(u(j)-u(j-1))) goto 23098 23097 continue ty(i)=ty(i)+(y(i)-u(n))*v(n) 23098 continue 23092 continue i=i+1 goto 23088 23090 continue return end block data avasdata common /parms/ itape,maxit,nterm,span,alpha common /spans/ spans(3) /consts/ big,sml,eps c------------------------------------------------------------------ c c these procedure parameters can be changed in the calling routine c by defining the above labeled common and resetting the values with c executable statements. c c itape : fortran file number for printer output. c (itape.le.0 => no printer output.) c maxit : maximum number of iterations. c nterm : number of consecutive iterations for which c rsq must change less than delcor for convergence. c span, alpha : super smoother parameters. c (see - friedman and stuetzle, reference above.) c c------------------------------------------------------------------ data itape,maxit,nterm,span,alpha /-6,20,3,0.0,5.0/ c--------------------------------------------------------------- c c this sets the compile time (default) values for various c internal parameters : c c spans : span values for the three running linear smoothers. c spans(1) : tweeter span. c spans(2) : midrange span. c spans(3) : woofer span. c (these span values should be changed only with care.) c big : a large representable floating point number. c sml : a small number. should be set so that (sml)**(10.0) does c not cause floating point underflow. c eps : used to numerically stabilize slope calculations for c running linear fits. c c these parameter values can be changed by declaring the c relevant labeled common in the main program and resetting c them with executable statements. c c----------------------------------------------------------------- data spans,big,sml,eps /0.05,0.2,0.5,1.0e20,1.0e-4,1.0e-3/ end subroutine smothr (l,n,x,y,w,smo,scr) double precision x(n),y(n),w(n),smo(n),scr(n,7) common /parms/ itape,maxit,nterm,span,alpha double precision sm,sw,a,b,d if (l.lt.5) go to 50 j=1 10 j0=j sm=w(j)*y(j) sw=w(j) if (j.ge.n) go to 30 20 if (x(j+1).gt.x(j)) go to 30 j=j+1 sm=sm+w(j)*y(j) sw=sw+w(j) if (j.ge.n) go to 30 go to 20 30 sm=sm/sw do 40 i=j0,j smo(i)=sm 40 continue j=j+1 if (j.gt.n) go to 250 go to 10 50 if (l.ne.4) go to 80 sm=0.0 sw=sm b=sw d=b do 60 j=1,n sm=sm+w(j)*x(j)*y(j) sw=sw+w(j)*x(j)**2 b=b+w(j)*x(j) d=d+w(j) 60 continue a=sm/(sw-(b**2)/d) b=b/d do 70 j=1,n smo(j)=a*(x(j)-b) 70 continue go to 250 80 call supsmu (n,x,y,w,l,span,alpha,smo,scr) if (l.ne.3) go to 250 do 90 j=1,n scr(j,1)=smo(j) scr(n-j+1,2)=scr(j,1) 90 continue call montne (scr,n) call montne (scr(1,2),n) sm=0.0 sw=sm do 100 j=1,n sm=sm+(smo(j)-scr(j,1))**2 sw=sw+(smo(j)-scr(n-j+1,2))**2 100 continue if (sm.ge.sw) go to 120 do 110 j=1,n smo(j)=scr(j,1) 110 continue go to 140 120 do 130 j=1,n smo(j)=scr(n-j+1,2) 130 continue 140 j=1 150 j0=j if (j.ge.n) go to 170 160 if (smo(j+1).ne.smo(j)) go to 170 j=j+1 if (j.ge.n) go to 170 go to 160 170 if (j.le.j0) go to 190 a=0.0 if (j0.gt.1) a=0.5*(smo(j0)-smo(j0-1)) b=0.0 if (j.lt.n) b=0.5*(smo(j+1)-smo(j)) d=(a+b)/(j-j0) if (a.eq.0.0.or.b.eq.0.0) d=2.0*d if (a.eq.0.0) a=b do 180 i=j0,j smo(i)=smo(i)-a+d*(i-j0) 180 continue 190 j=j+1 if (j.gt.n) go to 200 go to 150 200 j=1 210 j0=j sm=smo(j) if (j.ge.n) go to 230 220 if (x(j+1).gt.x(j)) go to 230 j=j+1 sm=sm+smo(j) if (j.ge.n) go to 230 go to 220 230 sm=sm/(j-j0+1) do 240 i=j0,j smo(i)=sm 240 continue j=j+1 if (j.gt.n) go to 250 go to 210 250 return end subroutine montne (x,n) double precision x(n) integer bb,eb,br,er,bl,el bb=0 eb=bb 10 if (eb.ge.n) go to 110 bb=eb+1 eb=bb 20 if (eb.ge.n) go to 30 if (x(bb).ne.x(eb+1)) go to 30 eb=eb+1 go to 20 30 if (eb.ge.n) go to 70 if (x(eb).le.x(eb+1)) go to 70 br=eb+1 er=br 40 if (er.ge.n) go to 50 if (x(er+1).ne.x(br)) go to 50 er=er+1 go to 40 50 pmn=(x(bb)*(eb-bb+1)+x(br)*(er-br+1))/(er-bb+1) eb=er do 60 i=bb,eb x(i)=pmn 60 continue 70 if (bb.le.1) go to 10 if (x(bb-1).le.x(bb)) go to 10 bl=bb-1 el=bl 80 if (bl.le.1) go to 90 if (x(bl-1).ne.x(el)) go to 90 bl=bl-1 go to 80 90 pmn=(x(bb)*(eb-bb+1)+x(bl)*(el-bl+1))/(eb-bl+1) bb=bl do 100 i=bb,eb x(i)=pmn 100 continue go to 30 110 return end subroutine sort (v,a,ii,jj) c c puts into a the permutation vector which sorts v into c increasing order. only elements from ii to jj are considered. c arrays iu(k) and il(k) permit sorting up to 2**(k+1)-1 elements c c this is a modification of cacm algorithm #347 by r. c. singleton, c which is a modified hoare quicksort. c dimension a(jj),v(*) integer iu(20),il(20) integer t,tt integer a double precision v m=1 i=ii j=jj 10 if (i.ge.j) go to 80 20 k=i ij=(j+i)/2 t=a(ij) vt=v(ij) if (v(i).le.vt) go to 30 a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) 30 l=j if (v(j).ge.vt) go to 50 a(ij)=a(j) a(j)=t t=a(ij) v(ij)=v(j) v(j)=vt vt=v(ij) if (v(i).le.vt) go to 50 a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) go to 50 40 a(l)=a(k) a(k)=tt v(l)=v(k) v(k)=vtt 50 l=l-1 if (v(l).gt.vt) go to 50 tt=a(l) vtt=v(l) 60 k=k+1 if (v(k).lt.vt) go to 60 if (k.le.l) go to 40 if (l-i.le.j-k) go to 70 il(m)=i iu(m)=l i=k m=m+1 go to 90 70 il(m)=k iu(m)=j j=l m=m+1 go to 90 80 m=m-1 if (m.eq.0) return i=il(m) j=iu(m) 90 if (j-i.gt.10) go to 20 if (i.eq.ii) go to 10 i=i-1 100 i=i+1 if (i.eq.j) go to 80 t=a(i+1) vt=v(i+1) if (v(i).le.vt) go to 100 k=i 110 a(k+1)=a(k) v(k+1)=v(k) k=k-1 if (vt.lt.v(k)) go to 110 a(k+1)=t v(k+1)=vt go to 100 end subroutine supsmu (n,x,y,w,iper,span,alpha,smo,sc) c------------------------------------------------------------------ c c super smoother (friedman and stuetzle, 1984). c c version 3/10/84 c c coded by: j. h. friedman c department of statistics and c stanford linear accelerator center c stanford university c stanford ca. 94305 c c input: c n : number of observations (x,y - pairs). c x(n) : ordered abscissa values. c y(n) : corresponding ordinate (response) values. c w(n) : weight for each (x,y) observation. c iper : periodic variable flag. c iper=1 => x is ordered interval variable. c iper=2 => x is a periodic variable with values c in the range (0.0,1.0) and peroid 1.0. c span : smoother span (fraction of observations in window). c span=0.0 => automatic (variable) span selection. c alpha : controles high frequency (small span) penality c used with automatic span selection (base tone control). c (alpha.le.0.0 or alpha.gt.10.0 => no effect.) c output: c smo(n) : smoothed ordinate (response) values. c scratch: c sc(n,7) : internal working storage. c c note: c for small samples (n < 40) or if there are substantial serial c correlations between obserations close in x - value, then c a prespecified fixed span smoother (span > 0) should be c used. reasonable span values are 0.3 to 0.5. c c------------------------------------------------------------------ double precision x(n),y(n),w(n),smo(n),sc(n,7) common /spans/ spans(3) /consts/ big,sml,eps double precision h(1) if (x(n).gt.x(1)) go to 30 sy=0.0 sw=sy do 10 j=1,n sy=sy+w(j)*y(j) sw=sw+w(j) 10 continue a=sy/sw do 20 j=1,n smo(j)=a 20 continue return 30 i=n/4 j=3*i scale=x(j)-x(i) 40 if (scale.gt.0.0) go to 50 if (j.lt.n) j=j+1 if (i.gt.1) i=i-1 scale=x(j)-x(i) go to 40 50 vsmlsq=(eps*scale)**2 jper=iper if (iper.eq.2.and.(x(1).lt.0.0.or.x(n).gt.1.0)) jper=1 if (jper.lt.1.or.jper.gt.2) jper=1 if (span.le.0.0) go to 60 call smooth (n,x,y,w,span,jper,vsmlsq,smo,sc) return 60 do 70 i=1,3 call smooth (n,x,y,w,spans(i),jper,vsmlsq,sc(1,2*i-1),sc(1,7)) call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2*i),h) 70 continue do 90 j=1,n resmin=big do 80 i=1,3 if (sc(j,2*i).ge.resmin) go to 80 resmin=sc(j,2*i) sc(j,7)=spans(i) 80 continue if (alpha.gt.0.0.and.alpha.le.10.0.and.resmin.lt.sc(j,6)) sc(j,7)= 1sc(j,7)+(spans(3)-sc(j,7))*max(sml,resmin/sc(j,6))**(10.0-alpha) 90 continue call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2),h) do 110 j=1,n if (sc(j,2).le.spans(1)) sc(j,2)=spans(1) if (sc(j,2).ge.spans(3)) sc(j,2)=spans(3) f=sc(j,2)-spans(2) if (f.ge.0.0) go to 100 f=-f/(spans(2)-spans(1)) sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,1) go to 110 100 f=f/(spans(3)-spans(2)) sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,5) 110 continue call smooth (n,x,sc(1,4),w,spans(1),-jper,vsmlsq,smo,h) return end subroutine smooth (n,x,y,w,span,iper,vsmlsq,smo,acvr) double precision x(n),y(n),w(n),smo(n),acvr(n) integer in,out xm=0.0 ym=xm var=ym cvar=var fbw=cvar jper=iabs(iper) ibw=0.5*span*n+0.5 if (ibw.lt.2) ibw=2 it=2*ibw+1 do 20 i=1,it j=i if (jper.eq.2) j=i-ibw-1 xti=x(j) if (j.ge.1) go to 10 j=n+j xti=x(j)-1.0 10 wt=w(j) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(j))/fbw tmp=0.0 if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(j)-ym) 20 continue do 70 j=1,n out=j-ibw-1 in=j+ibw if ((jper.ne.2).and.(out.lt.1.or.in.gt.n)) go to 60 if (out.ge.1) go to 30 out=n+out xto=x(out)-1.0 xti=x(in) go to 50 30 if (in.le.n) go to 40 in=in-n xti=x(in)+1.0 xto=x(out) go to 50 40 xto=x(out) xti=x(in) 50 wt=w(out) fbo=fbw fbw=fbw-wt tmp=0.0 if (fbw.gt.0.0) tmp=fbo*wt*(xto-xm)/fbw var=var-tmp*(xto-xm) cvar=cvar-tmp*(y(out)-ym) xm=(fbo*xm-wt*xto)/fbw ym=(fbo*ym-wt*y(out))/fbw wt=w(in) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(in))/fbw tmp=0.0 if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(in)-ym) 60 a=0.0 if (var.gt.vsmlsq) a=cvar/var smo(j)=a*(x(j)-xm)+ym if (iper.le.0) go to 70 h=1.0/fbw if (var.gt.vsmlsq) h=h+(x(j)-xm)**2/var acvr(j)=abs(y(j)-smo(j))/(1.0-w(j)*h) 70 continue j=1 80 j0=j sy=smo(j)*w(j) fbw=w(j) if (j.ge.n) go to 100 90 if (x(j+1).gt.x(j)) go to 100 j=j+1 sy=sy+w(j)*smo(j) fbw=fbw+w(j) if (j.ge.n) go to 100 go to 90 100 if (j.le.j0) go to 120 sy=sy/fbw do 110 i=j0,j smo(i)=sy 110 continue 120 j=j+1 if (j.gt.n) go to 130 go to 80 130 return end acepack/src/ace.f0000644000176000001440000003753212140735053013371 0ustar ripleyusersC real -> double precision conversion for R use C c mortran 2.0 (version of 6/24/75) subroutine mace (p,n,x,y,w,l,delrsq,ns,tx,ty,rsq,ierr,m,z) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c c subroutine mace(p,n,x,y,w,l,delrsq,ns,tx,ty,rsq,ierr,m,z) c------------------------------------------------------------------ c c estimate multiple optimal transformations for regression and c correlation by alternating conditional expectation estimates. c c version 3/28/85. c c breiman and friedman, journal of the american statistical c association (september, 1985) c c coded and copywrite (c) 1985 by: c c jerome h. friedman c department of statistics c and c stanford linear accelerator center c stanford university c c all rights reserved. c c c input: c c n : number of observations. c p : number of predictor variables for each observation. c x(p,n) : predictor data matrix. c y(n) : response values for the observations. c missing values are signified by a value (response or c predictor) greater than or equal to big. c (see below - default, big = 1.0e20) c w(n) : weights for the observations. c l(p+1) : flag for each variable. c l(1) through l(p) : predictor variables. c l(p+1) : response variable. c l(i)=0 => ith variable not to be used. c l(i)=1 => ith variable assumes orderable values. c l(i)=2 => ith variable assumes circular (periodic) values c in the range (0.0,1.0) with period 1.0. c l(i)=3 => ith variable transformation is to be monotone. c l(i)=4 => ith variable transformation is to be linear. c l(i)=5 => ith variable assumes categorical (unorderable) values. c delrsq : termination threshold. iteration stops when c rsq changes less than delrsq in nterm c consecutive iterations (see below - default, nterm=3). c ns : number of eigensolutions (sets of transformations). c c output: c c tx(n,p,ns) : predictor transformations. c tx(j,i,k) = transformed value of ith predictor for jth obs c for kth eigensolution. c ty(n,ns) = response transformations. c ty(j,k) = transformed response value for jth observation c for kth eigensolution. c rsq(ns) = fraction of variance(ty) c p c explained by sum tx(i) for each eigensolution. c i=1 c ierr : error flag. c ierr = 0 : no errors detected. c ierr > 0 : error detected - see format statements below. c c scratch: c c m(n,p+1), z(n,12) : internal working storage. c c note: mace uses an iterative procedure for solving the optimization c problem. default starting transformations are ty(j,k)=y(j), c tx(j,i,k)=x(i,j) : j=1,n, i=1,p, k=1,ns. other starting transformat c can be specified (if desired) for either the response and/or any of c the predictor variables. this is signaled by negating the c corresponding l(i) value and storing the starting transformed c values in the corresponding array (ty(j,k), tx(j,i,k)) before c calling mace. c c------------------------------------------------------------------ c integer p,pp1,m(n,p+1),l(p+1) double precision y(n),x(p,n),w(n),ty(n,ns),tx(n,p,ns) double precision z(n,12),ct(10),rsq(ns) double precision delrsq common /prams/ alpha,big,span,itape,maxit,nterm double precision sm,sv,sw,sw1 ierr=0 pp1=p+1 sm=0.0 sv=sm sw=sv sw1=sw do 10 i=1,pp1 if (l(i).ge.-5.and.l(i).le.5) go to 10 ierr=6 c if (itape.gt.0) write (itape,670) i,l(i) 10 continue if (ierr.ne.0) return if (l(pp1).ne.0) go to 20 ierr=4 c if (itape.gt.0) write (itape,650) pp1 return 20 np=0 do 30 i=1,p if (l(i).ne.0) np=np+1 30 continue if (np.gt.0) go to 40 ierr=5 c if (itape.gt.0) write (itape,660) p return 40 do 50 j=1,n sw=sw+w(j) 50 continue if (sw.gt.0.0) go to 60 ierr=1 c if (itape.gt.0) write (itape,620) return 60 do 580 is=1,ns c if (itape.gt.0) write (itape,590) is do 70 j=1,n if (l(pp1).gt.0) ty(j,is)=y(j) 70 continue do 170 i=1,p if (l(i).ne.0) go to 90 do 80 j=1,n tx(j,i,is)=0.0 80 continue go to 170 90 if (l(i).le.0) go to 110 do 100 j=1,n tx(j,i,is)=x(i,j) 100 continue 110 do 120 j=1,n if (tx(j,i,is).ge.big) go to 120 sm=sm+w(j)*tx(j,i,is) sw1=sw1+w(j) 120 continue if (sw1.gt.0.0) go to 140 do 130 j=1,n tx(j,i,is)=0.0 130 continue sm=0.0 sw1=sm go to 170 140 sm=sm/sw1 do 160 j=1,n if (tx(j,i,is).ge.big) go to 150 tx(j,i,is)=tx(j,i,is)-sm go to 160 150 tx(j,i,is)=0.0 160 continue sm=0.0 sw1=sm 170 continue do 180 j=1,n if (ty(j,is).ge.big) go to 180 sm=sm+w(j)*ty(j,is) sw1=sw1+w(j) 180 continue if (sw1.gt.0.0) go to 190 ierr=1 c if (itape.gt.0) write (itape,620) return 190 sm=sm/sw1 do 210 j=1,n if (ty(j,is).ge.big) go to 200 ty(j,is)=ty(j,is)-sm go to 210 200 ty(j,is)=0.0 210 continue do 220 j=1,n sv=sv+w(j)*ty(j,is)**2 220 continue sv=sv/sw if (sv.le.0.0) go to 230 sv=1.0/dsqrt(sv) go to 260 230 if (l(pp1).le.0) go to 240 ierr=2 c if (itape.gt.0) write (itape,630) go to 250 240 ierr=3 c if (itape.gt.0) write (itape,640) is 250 return 260 do 270 j=1,n ty(j,is)=ty(j,is)*sv 270 continue if (is.ne.1) go to 310 do 280 j=1,n m(j,pp1)=j z(j,2)=y(j) 280 continue call sort (z(1,2),m(1,pp1),1,n) do 300 i=1,p if (l(i).eq.0) go to 300 do 290 j=1,n m(j,i)=j z(j,2)=x(i,j) 290 continue call sort (z(1,2),m(1,i),1,n) 300 continue 310 call scail (p,n,w,sw,ty(1,is),tx(1,1,is),delrsq,p,z(1,5),z(1,6)) rsq(is)=0.0 iter=0 nterm=min0(nterm,10) nt=0 do 320 i=1,nterm ct(i)=100.0 320 continue 330 iter=iter+1 nit=0 340 rsqi=rsq(is) nit=nit+1 do 360 j=1,n z(j,5)=ty(j,is) do 350 i=1,p if (l(i).ne.0) z(j,5)=z(j,5)-tx(j,i,is) 350 continue 360 continue do 420 i=1,p if (l(i).eq.0) go to 420 do 370 j=1,n k=m(j,i) z(j,1)=z(k,5)+tx(k,i,is) z(j,2)=x(i,k) z(j,4)=w(k) 370 continue call smothr (iabs(l(i)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) sm=0.0 do 380 j=1,n sm=sm+z(j,4)*z(j,3) 380 continue sm=sm/sw do 390 j=1,n z(j,3)=z(j,3)-sm 390 continue sv=0.0 do 400 j=1,n sv=sv+z(j,4)*(z(j,1)-z(j,3))**2 400 continue sv=1.0-sv/sw if (sv.le.rsq(is)) go to 420 rsq(is)=sv do 410 j=1,n k=m(j,i) tx(k,i,is)=z(j,3) z(k,5)=z(j,1)-z(j,3) 410 continue 420 continue if (np.eq.1.or.rsq(is)-rsqi.le.delrsq.or.nit.ge.maxit) go to 430 go to 340 430 do 450 j=1,n k=m(j,pp1) z(j,2)=y(k) z(j,4)=w(k) z(j,1)=0.0 do 440 i=1,p if (l(i).ne.0) z(j,1)=z(j,1)+tx(k,i,is) 440 continue 450 continue call smothr (iabs(l(pp1)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) if (is.le.1) go to 490 ism1=is-1 do 480 js=1,ism1 sm=0.0 do 460 j=1,n k=m(j,pp1) sm=sm+w(k)*z(j,3)*ty(k,js) 460 continue sm=sm/sw do 470 j=1,n k=m(j,pp1) z(j,3)=z(j,3)-sm*ty(k,js) 470 continue 480 continue 490 sm=0.0 sv=sm do 500 j=1,n k=m(j,pp1) sm=sm+w(k)*z(j,3) z(k,2)=z(j,1) 500 continue sm=sm/sw do 510 j=1,n z(j,3)=z(j,3)-sm sv=sv+z(j,4)*z(j,3)**2 510 continue sv=sv/sw if (sv.le.0.0) go to 520 sv=1.0/dsqrt(sv) go to 530 520 ierr=3 c if (itape.gt.0) write (itape,640) is return 530 do 540 j=1,n k=m(j,pp1) ty(k,is)=z(j,3)*sv 540 continue sv=0.0 do 550 j=1,n sv=sv+w(j)*(ty(j,is)-z(j,2))**2 550 continue rsq(is)=1.0-sv/sw c if (itape.gt.0) write (itape,610) iter,rsq(is) nt=mod(nt,nterm)+1 ct(nt)=rsq(is) cmn=100.0 cmx=-100.0 do 560 i=1,nterm cmn=min(cmn,ct(i)) cmx=max(cmx,ct(i)) 560 continue if (cmx-cmn.le.delrsq.or.iter.ge.maxit) go to 570 go to 330 c 570 if (itape.gt.0) write (itape,600) is,rsq(is) 570 continue 580 continue return 590 format('0eigensolution ',i2, ':') 600 format(' eigensolution ',i2, 'h r**2 = 1 - e**2 =',g12.4) 610 format(' iteration ',i2, 'h r**2 = 1 - e**2 =',g12.4) 620 format(' ierr=1: sum of weights (w) not positive.') 630 format(' ierr=2: y has zero variance.') 640 format(' ierr=3: ty(.',i2,') has zero variance.') 650 format(' ierr=4: l(',i2, ') must be nonzero.') 660 format(' ierr=5: at least one l(1)-l(',i2,') must be nonzero.') 670 format(' ierr=6: l(',i2, ') =',g12.4, 1 ' must be in the range (-5, 5).') end subroutine model (p,n,y,w,l,tx,ty,f,t,m,z) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c c subroutine model(p,n,y,w,l,tx,ty,f,t,m,z) c-------------------------------------------------------------------- c c computes response predictive function f for the model yhat = f(t), c where c p c f(t) = e(y : t), t = sum tx ( x ) c i=1 c using the x transformations tx constructed by subroutine ace. c if y is a categorical variable (classification) then c -1 c f(t) = ty (t). c input: c c p,n,y,w,l : same input as for subroutine ace. c tx,ty,m,z : output from subroutine ace. c c output: c c f(n),t(n) : input for subroutine acemod. c c note: this subroutine must be called before subroutine acemod. c c------------------------------------------------------------------- c integer p,pp1,m(n,1),l(1) double precision y(n),w(n),tx(n,p),ty(n),f(n),t(n),z(n,12) common /prams/ alpha,big,span,itape,maxit,nterm pp1=p+1 if (iabs(l(pp1)).ne.5) go to 20 do 10 j=1,n t(j)=ty(j) m(j,pp1)=j 10 continue go to 50 20 do 40 j=1,n s=0.0 do 30 i=1,p s=s+tx(j,i) 30 continue t(j)=s m(j,pp1)=j 40 continue 50 call sort (t,m(1,pp1),1,n) do 140 j=1,n k=m(j,pp1) z(j,2)=w(k) if (y(k).ge.big) go to 60 z(j,1)=y(k) go to 140 60 j1=j j2=j1 70 if (y(m(j1,pp1)).lt.big) go to 80 j1=j1-1 if (j1.lt.1) go to 80 go to 70 80 if (y(m(j2,pp1)).lt.big) go to 90 j2=j2+1 if (j2.gt.n) go to 90 go to 80 90 if (j1.ge.1) go to 100 k=j2 go to 130 100 if (j2.le.n) go to 110 k=j1 go to 130 110 if (t(j)-t(j1).ge.t(j2)-t(j)) go to 120 k=j1 go to 130 120 k=j2 130 z(j,1)=y(m(k,pp1)) t(j)=t(k) 140 continue if (iabs(l(pp1)).ne.5) go to 160 do 150 j=1,n f(j)=z(j,1) 150 continue go to 170 160 call smothr (1,n,t,z,z(1,2),f,z(1,6)) 170 return end subroutine acemod (v,p,n,x,l,tx,f,t,m,yhat) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c subroutine acemod(v,p,n,x,l,tx,f,t,m,yhat) c-------------------------------------------------------------------- c c computes response y estimates from the model c c yhat = f ( t( v ) ) c c using the x transformations tx constructed by subroutine ace and c the predictor function (f,t) constructed by subroutine model. c c input: c c v(p) : vector of predictor values. c p,n,x,l : same input as for subroutine ace. c tx,m : output from subroutine ace. c f,t : output from subroutine model. c c output: c c yhat : estimated response value for v. c c note: this subroutine must not be called before subroutine model. c c------------------------------------------------------------------- c integer p,m(n,1),l(1),low,high,place double precision v(p),x(p,n),f(n),t(n),tx(n,p), yhat common /prams/ alpha,big,span,itape,maxit,nterm th=0.0 do 90 i=1,p if (l(i).eq.0) go to 90 vi=v(i) if (vi.lt.big) go to 10 if (x(i,m(n,i)).ge.big) th=th+tx(m(n,i),i) go to 90 10 if (vi.gt.x(i,m(1,i))) go to 20 place=1 go to 80 20 if (vi.lt.x(i,m(n,i))) go to 30 place=n go to 80 30 low=0 high=n+1 40 if (low+1.ge.high) go to 60 place=(low+high)/2 xt=x(i,m(place,i)) if (vi.eq.xt) go to 80 if (vi.ge.xt) go to 50 high=place go to 40 50 low=place go to 40 60 if (iabs(l(i)).eq.5) go to 90 jl=m(low,i) jh=m(high,i) if (x(i,jh).lt.big) go to 70 th=th+tx(jl,i) go to 90 70 th=th+tx(jl,i)+(tx(jh,i)-tx(jl,i))*(vi-x(i,jl))/(x(i,jh)-x(i,jl)) go to 90 80 th=th+tx(m(place,i),i) 90 continue if (th.gt.t(1)) go to 100 yhat=f(1) return 100 if (th.lt.t(n)) go to 110 yhat=f(n) return 110 low=0 high=n+1 120 if (low+1.ge.high) go to 150 place=(low+high)/2 xt=t(place) if (th.ne.xt) go to 130 yhat=f(place) return 130 if (th.ge.xt) go to 140 high=place go to 120 140 low=place go to 120 150 if (iabs(l(p+1)).ne.5) go to 170 if (th-t(low).gt.t(high)-th) go to 160 yhat=f(low) go to 180 160 yhat=f(high) go to 180 170 yhat=f(low)+(f(high)-f(low))*(th-t(low))/(t(high)-t(low)) 180 return end block data acedata IMPLICIT DOUBLE PRECISION (A-H,O-Z) common /prams/ alpha,big,span,itape,maxit,nterm c c block data c common /prams/ itape,maxit,nterm,span,alpha,big c c------------------------------------------------------------------ c c these procedure parameters can be changed in the calling routine c by defining the above labeled common and resetting the values with c executable statements. c c itape : fortran file number for printer output. c (itape.le.0 => no printer output.) c maxit : maximum number of iterations. c nterm : number of consecutive iterations for which c rsq must change less than delcor for convergence. c span, alpha : super smoother parameters (see below). c big : a large representable floating point number. c c------------------------------------------------------------------ c data itape,maxit,nterm,span,alpha,big /-6,20,3,0.0,0.0,1.0e20/ end subroutine scail (p,n,w,sw,ty,tx,eps,maxit,r,sc) IMPLICIT DOUBLE PRECISION (A-H,O-Z) integer p double precision w(n),ty(n),tx(n,p),r(n),sc(p,5) double precision s,h,t,u,gama,delta,sw, eps do 10 i=1,p sc(i,1)=0.0 10 continue nit=0 20 nit=nit+1 do 30 i=1,p sc(i,5)=sc(i,1) 30 continue do 160 iter=1,p do 50 j=1,n s=0.0 do 40 i=1,p s=s+sc(i,1)*tx(j,i) 40 continue r(j)=(ty(j)-s)*w(j) 50 continue do 70 i=1,p s=0.0 do 60 j=1,n s=s+r(j)*tx(j,i) 60 continue sc(i,2)=-2.0*s/sw 70 continue s=0.0 do 80 i=1,p s=s+sc(i,2)**2 80 continue if (s.le.0.0) go to 170 if (iter.ne.1) go to 100 do 90 i=1,p sc(i,3)=-sc(i,2) 90 continue h=s go to 120 100 gama=s/h h=s do 110 i=1,p sc(i,3)=-sc(i,2)+gama*sc(i,4) 110 continue 120 s=0.0 t=s do 140 j=1,n u=0.0 do 130 i=1,p u=u+sc(i,3)*tx(j,i) 130 continue s=s+u*r(j) t=t+w(j)*u**2 140 continue delta=s/t do 150 i=1,p sc(i,1)=sc(i,1)+delta*sc(i,3) sc(i,4)=sc(i,3) 150 continue 160 continue 170 v=0.0 do 180 i=1,p v=max(v,abs(sc(i,1)-sc(i,5))) 180 continue if (v.lt.eps.or.nit.ge.maxit) go to 190 go to 20 190 do 210 i=1,p do 200 j=1,n tx(j,i)=sc(i,1)*tx(j,i) 200 continue 210 continue return end acepack/man/0000755000176000001440000000000011414167021012441 5ustar ripleyusersacepack/man/avas.Rd0000644000176000001440000000742311414167001013666 0ustar ripleyusers\name{avas} \alias{avas} \alias{avas.formula} \title{Additivity and variance stabilization for regression} \usage{ avas(x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0) } \description{Estimate transformations of \code{x} and \code{y} such that the regression of \code{y} on \code{x} is approximately linear with constant variance} \arguments{ \item{x}{a matrix containing the independent variables.} \item{y}{a vector containing the response variable.} \item{wt}{an optional vector of weights.} \item{cat}{an optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified as categorical.} \item{mon}{an optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{an optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{an integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{termination threshold. Iteration stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} \item{yspan}{Optional window size parameter for smoothing the variance. Range is \eqn{[0,1]}. Default is 0 (cross validated choice). .5 is a reasonable alternative to try.} } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} \item{m}{not used in this version of avas} \item{yspan}{span used for smoothing the variance} \item{iters}{iteration number and rsq for that iteration} \item{niters}{number of iterations used} } \references{ Rob Tibshirani (1987), ``Estimating optimal transformations for regression''. \emph{Journal of the American Statistical Association} \bold{83}, 394ff. } \examples{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- avas(x,y) par(mfrow=c(3,1)) plot(a$y,a$ty) # view the response transformation plot(a$x,a$tx) # view the carrier transformation plot(a$tx,a$ty) # examine the linearity of the fitted model # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258, adapted for avas. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 a1 <- avas(cbind(X1,X2,X3,X4),Y) par(mfrow=c(2,1)) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } \keyword{models} acepack/man/ace.Rd0000644000176000001440000000703111414167016013465 0ustar ripleyusers\name{ace} \alias{ace} \title{Alternating Conditional Expectations} \usage{ ace(x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01) } \arguments{ \item{x}{a matrix containing the independent variables.} \item{y}{a vector containing the response variable.} \item{wt}{an optional vector of weights.} \item{cat}{an optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified as categorical.} \item{mon}{an optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{an optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{an integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{termination threshold. Iteration stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} } \description{ Uses the alternating conditional expectations algorithm to find the transformations of y and x that maximise the proportion of variation in y explained by x. } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} \item{m}{not used in this version of ace} } \references{ Breiman and Friedman, Journal of the American Statistical Association (September, 1985). The R code is adapted from S code for avas() by Tibshirani, in the Statlib S archive; the FORTRAN is a double-precision version of FORTRAN code by Friedman and Spector in the Statlib general archive. } \examples{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- ace(x,y) par(mfrow=c(3,1)) plot(a$y,a$ty) # view the response transformation plot(a$x,a$tx) # view the carrier transformation plot(a$tx,a$ty) # examine the linearity of the fitted model # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(100)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 a1 <- ace(cbind(X1,X2,X3,X4),Y) par(mfrow=c(2,1)) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } \keyword{models} acepack/ace.doc0000644000176000001440000026400011414164070013110 0ustar ripleyusersacepack/CHANGES0000664000076400007640000000103611414162341012433 0ustar baronbaron7-4-2010 Fixed options circ, cat, and mon, in both ace and avas, so that they now can apply to the dependent variable, as specified previously in both the help page and the fortran code. Colin McCullogh did most of the work. Frank Harrell also reported this bug. Fixed the checks on the options so that they apply to the correct dimension. Previously circ and mon were not working as described. Thanks to Frank Harrell. Expanded the help pages to make them clearer and provide more examples. Jon Baron acepack/DESCRIPTION0000644000076400007640000000065511414163620013153 0ustar baronbaronPackage: acepack Maintainer: Jonathan Baron Version: 1.3-3.0 Author: Phil Spector, Jerome Friedman, Robert Tibshirani, Thomas Lumley Description: ACE and AVAS methods for choosing regression transformations. Title: ace() and avas() for selecting regression transformations License: MIT + file LICENSE Packaged: 2010-01-19 16:05:44 UTC; baron Repository: CRAN Date/Publication: 2010-01-19 16:35:08 acepack/INDEX0000644000076400007640000000024207472475501012244 0ustar baronbaronace Alternating Conditional Expectations avas Additivity and variance stabilization for regression acepack/LICENSE0000644000076400007640000001216711325135724012460 0ustar baronbaronFor the AVAS license, see README.avas. The following, concerning ACE, written by Tom "spot" Callaway, is from the Fedora R-acepack RPM. ######################## The copyright on the ace implementation was clear, but its licensing terms were not. I was able to clarify the terms with the copyright holder: Copyright 2007 Jerome H. Friedman Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. ========================================================================= To remove any hint of impropriety, here are copies of my email communications with the copyright holder. From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:05:10 -0800 Tom, >> > We would like to include it in Fedora, but we need to know the >> > licensing >> > terms for that code. >> >> Sorry for my ignorance, but what is Fedora? > > Fedora is a very popular distribution of Linux. Our previous name was > "Red Hat Linux". Right. I should have remembered that. You hereby have my permission to distribute my ACE code in Fedora. Cheers, Jerry. From tcallawa@redhat.com Wed Oct 31 15:10:12 2007 Subject: Re: license for ace() From: "Tom \"spot\" Callaway" To: "Jerome H. Friedman" Date: Wed, 31 Oct 2007 15:10:12 -0400 On Wed, 2007-10-31 at 11:05 -0800, Jerome H. Friedman wrote: > Tom, > > >> > We would like to include it in Fedora, but we need to know the > >> > licensing > >> > terms for that code. > >> > >> Sorry for my ignorance, but what is Fedora? > > > > Fedora is a very popular distribution of Linux. Our previous name was > > "Red Hat Linux". > > Right. I should have remembered that. > > You hereby have my permission to distribute my ACE code in Fedora. Great! Now, I just need to know under what licensing terms we can distribute it under. :) Here are several common licenses: MIT ==== Copyright 19XX John Doe Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. BSD ==== Copyright (c) , All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. GPLv2 ====== http://www.gnu.org/licenses/old-licenses/gpl-2.0.html If none of those licenses seems correct to you, let me know, and I will show you some others. Thanks, ~Tom From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:43:34 -0800 Tom, > MIT > ==== > Copyright 19XX John Doe > > Permission to use, copy, modify, distribute, and sell this software and > its documentation for any purpose is hereby granted without fee, > provided that the above copyright notice appear in all copies and that > both that copyright notice and this permission notice appear in > supporting documentation. No representations are made about the > suitability of this software for any purpose. It is provided "as is" > without express or implied warranty. I think this is good enough. Jerry. acepack/man/0000755000076400007640000000000011414162125012211 5ustar baronbaronacepack/man/avas.Rd0000644000076400007640000000752711414162101013437 0ustar baronbaron\name{avas} \alias{avas} \alias{avas.formula} \title{Additivity and variance stabilization for regression} \usage{ avas(x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0) } \description{Estimate transformations of \code{x} and \code{y} such that the regression of \code{y} on \code{x} is approximately linear with constant variance} \arguments{ \item{x}{a matrix containing the independent variables.} \item{y}{a vector containing the response variable.} \item{wt}{an optional vector of weights.} \item{cat}{an optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified as categorical.} \item{mon}{an optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{an optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{an integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{termination threshold. Iteration stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} \item{yspan}{Optional window size parameter for smoothing the variance. Range is \eqn{[0,1]}. Default is 0 (cross validated choice). .5 is a reasonable alternative to try.} } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} \item{m}{not used in this version of avas} \item{yspan}{span used for smoothing the variance} \item{iters}{iteration number and rsq for that iteration} \item{niters}{number of iterations used} } \references{ Rob Tibshirani (1987), ``Estimating optimal transformations for regression''. \emph{Journal of the American Statistical Association} \bold{83}, 394ff. } \examples{ \example{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- avas(x,y) par(mfrow=c(3,1)) plot(a$y,a$ty) # view the response transformation plot(a$x,a$tx) # view the carrier transformation plot(a$tx,a$ty) # examine the linearity of the fitted model } \example{ # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258, adapted for avas. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(200)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 + rnorm(100) a1 <- avas(cbind(X1,X2,X3,X4),Y) par(mfrow=c(2,1)) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) \dontrun{ plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } par(mfrow=c(1,1)) } } \keyword{models} acepack/man/ace.Rd0000644000076400007640000000721411414161771013242 0ustar baronbaron\name{ace} \alias{ace} \title{Alternating Conditional Expectations} \usage{ ace(x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = null, delrsq = 0.01) } \arguments{ \item{x}{a matrix containing the independent variables.} \item{y}{a vector containing the response variable.} \item{wt}{an optional vector of weights.} \item{cat}{an optional integer vector specifying which variables assume categorical values. Positive values in \code{cat} refer to columns of the \code{x} matrix and zero to the response variable. Variables must be numeric, so a character variable should first be transformed with as.numeric() and then specified as categorical.} \item{mon}{an optional integer vector specifying which variables are to be transformed by monotone transformations. Positive values in \code{mon} refer to columns of the \code{x} matrix and zero to the response variable.} \item{lin}{an optional integer vector specifying which variables are to be transformed by linear transformations. Positive values in \code{lin} refer to columns of the \code{x} matrix and zero to the response variable.} \item{circ}{an integer vector specifying which variables assume circular (periodic) values. Positive values in \code{circ} refer to columns of the \code{x} matrix and zero to the response variable.} \item{delrsq}{termination threshold. Iteration stops when R-squared changes by less than \code{delrsq} in 3 consecutive iterations (default 0.01).} } \description{ Uses the alternating conditional expectations algorithm to find the transformations of y and x that maximise the proportion of variation in y explained by x. } \value{ A structure with the following components: \item{x}{the input x matrix.} \item{y}{the input y vector.} \item{tx}{the transformed x values.} \item{ty}{the transformed y values.} \item{rsq}{the multiple R-squared value for the transformed values.} \item{l}{the codes for cat, mon, ...} \item{m}{not used in this version of ace} } \references{ Breiman and Friedman, Journal of the American Statistical Association (September, 1985). The R code is adapted from S code for avas() by Tibshirani, in the Statlib S archive; the FORTRAN is a double-precision version of FORTRAN code by Friedman and Spector in the Statlib general archive. } \examples{ \example{ TWOPI <- 8*atan(1) x <- runif(200,0,TWOPI) y <- exp(sin(x)+rnorm(200)/2) a <- ace(x,y) par(mfrow=c(3,1)) plot(a$y,a$ty) # view the response transformation plot(a$x,a$tx) # view the carrier transformation plot(a$tx,a$ty) # examine the linearity of the fitted model par(mfrow=c(1,1)) # reset display to default } \example{ # From D. Wang and M. Murphy (2005), Identifying nonlinear relationships # regression using the ACE algorithm. Journal of Applied Statistics, # 32, 243-258. X1 <- runif(100)*2-1 X2 <- runif(100)*2-1 X3 <- runif(100)*2-1 X4 <- runif(100)*2-1 # Original equation of Y: Y <- log(4 + sin(3*X1) + abs(X2) + X3^2 + X4 + .1*rnorm(200)) # Transformed version so that Y, after transformation, is a # linear function of transforms of the X variables: # exp(Y) = 4 + sin(3*X1) + abs(X2) + X3^2 + X4 + rnorm(100) a1 <- ace(cbind(X1,X2,X3,X4),Y) par(mfrow=c(2,1)) # For each variable, show its transform as a function of # the original variable and the of the transform that created it, # showing that the transform is recovered. plot(X1,a1$tx[,1]) plot(sin(3*X1),a1$tx[,1]) \dontrun{ plot(X2,a1$tx[,2]) plot(abs(X2),a1$tx[,2]) plot(X3,a1$tx[,3]) plot(X3^2,a1$tx[,3]) plot(X4,a1$tx[,4]) plot(X4,a1$tx[,4]) plot(Y,a1$ty) plot(exp(Y),a1$ty) } par(mfrow=c(1,1)) } } \keyword{models} acepack/R/0000755000076400007640000000000011414163511011637 5ustar baronbaronacepack/R/acepack.R0000600000076400007640000001434211414163170013346 0ustar baronbaronace <- function (x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01) { x <- as.matrix(x) if (delrsq <= 0) { cat("delrsq must be positive") return() } iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if (!is.null(circ)) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) { cat("bad circ= specification") return() } if (circ[i] == 0) { nncol <- iy } else { nncol <- circ[i] } if (l[nncol] != 2 & l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 2 } } if (length(mon)) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) { cat("bad mon= specification") return() } if (mon[i] == 0) { nncol <- iy } else { nncol <- mon[i] } if (l[nncol] != 3 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 3 } } if (length(lin)) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) { cat("bad lin= specification") return() } if (lin[i] == 0) { nncol <- iy } else { nncol <- lin[i] } if (l[nncol] != 4 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) { cat("bad cat= specification") return() } if (cat[i] == 0) { nncol <- iy } else { nncol <- cat[i] } if (l[nncol] != 5 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = iy) z <- matrix(0, nrow = nrow(x), ncol = 12) z <- as.matrix(z) ns <- 1 mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(delrsq) <- "double" mode(z) <- "double" junk <- .Fortran("mace", p = as.integer(ncol(x)), n = as.integer(nrow(x)), x = t(x), y = y, w = as.double(wt), l = as.integer(l), delrsq = delrsq, ns = as.integer(ns), tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m = as.integer(m), z = z, PACKAGE = "acepack") return(junk) } avas <- function (x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0) { x <- as.matrix(x); print(dim(x)) if (delrsq <= 0) { cat("delrsq must be positive") return() } iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if (length(circ)) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) { cat("bad circ= specification") return() } if (circ[i] == 0) { nncol <- iy } else { nncol <- circ[i] } if (l[nncol] != 2 & l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 2 } } if (length(mon)) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) { cat("bad mon= specification") return() } if (mon[i] == 0) { nncol <- iy } else { nncol <- mon[i] } if (l[nncol] != 3 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 3 } } if (length(lin)) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) { cat("bad lin= specification") return() } if (lin[i] == 0) { nncol <- iy } else { nncol <- lin[i] } if (l[nncol] != 4 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) { cat("bad cat= specification") return() } if (cat[i] == 0) { nncol <- iy } else { nncol <- cat[i] } if (l[nncol] != 5 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = ncol(x) + 2) z <- matrix(0, nrow = nrow(x), ncol = 17) z <- as.matrix(z) iters <- matrix(0, nrow = 100, ncol = 2) mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(m) <- "integer" mode(l) <- "integer" mode(delrsq) <- "double" mode(z) <- "double" mode(yspan) <- "double" mode(iters) <- "double" junk <- .Fortran("avas", as.integer(ncol(x)), as.integer(nrow(x)), x, y, wt, l, delrsq, tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m, z, yspan = yspan, niter = integer(1), iters = iters, PACKAGE = "acepack") junk$iters <- junk$iters[1:junk$niter, ] return(list(x = t(x), y = y, tx = junk$tx, ty = junk$ty, rsq = junk$rsq, l=l, m, yspan = junk$yspan, iters = junk$iters, niters = junk$niter)) } acepack/R/zzz.R0000644000076400007640000000011210037157472012622 0ustar baronbaron.First.lib <- function(lib, pkg) { library.dynam("acepack", pkg, lib) } acepack/README0000644000076400007640000000053406506276017012334 0ustar baronbaronThis package is based on public domain S and FORTRAN code for AVAS by Tibshirani, and on FORTRAN code for ACE from Statlib, written by Spector and Friedman. The FORTRAN code has been edited to use double precision, for compatibility with R, and the R code and documentation for ace() have been added by Thomas Lumley, based on that for avas(). acepack/README.ace0000644000076400007640000000114606330736742013064 0ustar baronbaronThe ace distribution consists of the following files: 1. mace.f ace subroutine 2. sort.f sort routine for use by ace 3. supsmu.f supersmoother routine for use by ace 4. ace.doc header files from the above routines, providing documentation for their use 5. README this file If you have any questions or problems, please contact: Phil Spector Statistical Computing Facility Department of Statistics 367 Evans Hall UC Berkeley Berkeley, CA 94720 email: spector@stat.berkeley.edu phone: (415) - 642 - 9056 acepack/README.avas0000644000076400007640000000072406330737116013263 0ustar baronbaronThis archive contains new S code for avas (additivity and variance stabilization). It is used to estimate transformations for regression. It is officially a public domain product. To use it you need to be able to dynamically load fortran code. To get it going: -compile rlsmo.f and avas.r -source the file avas.s in S - type help(avas) to see how to use it This is not thoroughly tested code and I'd appreciate feedback. Rob Tibshirani tibs@utstat.toronto.edu acepack/src/0000755000076400007640000000000011325354130012225 5ustar baronbaronacepack/src/avas.f0000644000076400007640000004232210277042221013331 0ustar baronbaron subroutine avas(p,n,x,y,w,l,delrsq,tx,ty,rsq,ierr,m,z,yspan,iter, 1 iters) integer p,pp1,pp2,m(n,1),l(1) double precision y(n),x(n,p),w(n),ty(n),tx(n,p),z(n,17),ct(10) double precision iters(100,2), delrsq, rsq, yspan common /parms/ itape,maxit,nterm,span,alpha double precision sm,sv,sw,svx ierr = 0 pp1 = p+1 pp2 = p + 2 sm = 0.0 sv = sm sw = sv np = 0 do 23000 i = 1,p if(.not.(l(i).gt.0))goto 23002 np = np+1 23002 continue 23000 continue do 23004 j = 1,n sm = sm+w(j)*y(j) sv = sv+w(j)*y(j)**2 sw = sw+w(j) m(j,pp1) = j z(j,2) = y(j) 23004 continue sm = sm/sw sv = sv/sw-sm**2 sv = 1.0/dsqrt(sv) do 23006 j = 1,n z(j,1) = (y(j)-sm)*sv 23006 continue call sort(z(1,2),m(1,pp1),1,n) do 23008 i = 1,p if(.not.(l(i) .gt. 0))goto 23010 sm=0 do 23012 j=1,n sm=sm+w(j)*x(j,i) 23012 continue sm=sm/sw do 23014 j = 1,n m(j,i) = j z(j,2) = x(j,i) 23014 continue call sort(z(1,2),m(1,i),1,n) 23010 continue 23008 continue rsq = 0.0 iter = 0 nterm = min0(nterm,10) nt = 0 do 23016 i = 1,nterm ct(i) = 100.0 23016 continue do 23018 j=1,n ty(j)=z(j,1) 23018 continue do 23020 j = 1,n z(j,9)=ty(j) 23020 continue call bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=0 23022 continue iter=iter +1 if(.not.(l(pp1).eq.4))goto 23025 go to 992 23025 continue call calcmu(n,p,l,z,tx) do 23027 j=1,n tres=(ty(j)-z(j,10)) if(.not.(abs(tres).lt.1e-10))goto 23029 tres=1e-10 23029 continue z(j,2)=log(sqrt(tres**2)) m(j,pp2)=j 23027 continue call sort(z(1,10),m(1,pp2),1,n) do 23031 j=1,n k=m(j,pp2) z(j,4)=z(k,2) z(j,5)=w(k) 23031 continue call rlsmo(z(1,10),z(1,4),z(1,5),yspan,dof,n,z(1,6),rss,z(1,7)) do 23033 j=1,n k=m(j,pp2) z(j,7)=exp(-z(j,6)) sumlog=sumlog+n*(w(j)/sw)*2*z(j,6) z(j,8)=ty(k) 23033 continue call ctsub(n,z(1,10),z(1,7),z(1,8),z(1,9)) sm=0 do 23035 j=1,n sm=sm+w(j)*z(j,9) 23035 continue do 23037 j=1,n k=m(j,pp2) ty(k)=z(j,9)-sm/sw 23037 continue sv=0 svx=0 do 23039 j=1,n sv=sv+(w(j)/sw)*ty(j)*ty(j) svx=svx+(w(j)/sw)*z(j,10)*z(j,10) 23039 continue do 23041 j=1,n ty(j)=ty(j)/dsqrt(sv) do 23043 i=1,p if(.not.( l(i) .gt. 0))goto 23045 tx(j,i)=tx(j,i)/dsqrt(svx) 23045 continue 23043 continue 23041 continue 992 continue do 23047 j = 1,n z(j,9)=ty(j) 23047 continue call bakfit(iter,delrsq,rsq,sw,l,z,m,x,z(1,9),tx,w,n,p,np) sumlog=sumlog+n*dlog(sv) rr=0 call calcmu(n,p,l,z,tx) do 23049 j=1,n rr=rr+(w(j)/sw)*(ty(j)-z(j,10))**2 23049 continue rsq=1-rr rnew=sumlog+rr iters(iter,1)=iter iters(iter,2)=rsq nt = mod(nt,nterm)+1 ct(nt) = rsq cmn = 100.0 cmx = -100.0 do 23051 i = 1,nterm cmn = min(cmn,ct(i)) cmx = max(cmx,ct(i)) 23051 continue if(.not.(cmx-cmn.le.delrsq.or.iter.ge.maxit.or.l(pp1).eq.4)) 1 goto 23053 return 23053 continue 23023 goto 23022 return end subroutine calcmu(n,p,l,z,tx) integer p, l(1) double precision z(n,17),tx(n,p) do 23055 j=1,n z(j,10)=0 do 23057 i=1,p if(.not.(l(i) .gt. 0))goto 23059 z(j,10)=z(j,10)+tx(j,i) 23059 continue 23057 continue 23055 continue return end subroutine bakfit(iter,delrsq,rsq,sw,l,z,m,x,ty,tx,w,n,p,np) integer l(1),m(n,1),p double precision z(n,17),ty(n),tx(n,p),x(n,p),w(n) double precision sm,sv,sw, delrsq, rsq common /parms/ itape,maxit,nterm,span,alpha call calcmu(n,p,l,z,tx) do 23061 j=1,n ty(j)=ty(j)-z(j,10) 23061 continue nit=0 23063 continue rsqi = rsq nit = nit+1 do 23066 i = 1,p if(.not.(l(i).gt.0))goto 23068 do 23070 j = 1,n k = m(j,i) z(j,1) = ty(k)+tx(k,i) z(j,2) = x(k,i) z(j,7) = w(k) 23070 continue call smothr(l(i),n,z(1,2),z,z(1,7),z(1,6),z(1,11)) sm = 0.0 do 23072 j = 1,n sm = sm+z(j,7)*z(j,6) 23072 continue sm = sm/sw do 23074 j = 1,n z(j,6) = z(j,6)-sm 23074 continue sv = 0.0 do 23076 j = 1,n sv = sv+z(j,7)*(z(j,1)-z(j,6))**2 23076 continue sv = 1.0-sv/sw rsq = sv do 23078 j = 1,n k = m(j,i) tx(k,i) = z(j,6) ty(k) = z(j,1)-z(j,6) 23078 continue 23068 continue 23066 continue 23064 if(.not.(np.eq.1.or.abs(rsq-rsqi).le.delrsq.or.nit.ge.maxit)) 1 goto 23063 if(.not.(rsq.eq.0.0.and.iter.eq.0))goto 23080 do 23082 i = 1,p if(.not.(l(i).gt.0))goto 23084 do 23086 j = 1,n tx(j,i) = x(j,i) 23086 continue 23084 continue 23082 continue 23080 continue return end subroutine ctsub(n,u,v,y,ty) double precision u(1),v(1),y(1),ty(1) i=1 23088 if(.not.(i.le.n))goto 23090 if(.not.(y(i).le.u(1)))goto 23091 ty(i)=(y(i)-u(1))*v(1) goto 23092 23091 continue j=1 ty(i)=0 23093 if(.not.((j.le.n) .and. (y(i).gt.u(j)) ))goto 23094 if(.not.(j .gt. 1))goto 23095 ty(i)=ty(i)+(u(j)-u(j-1))*(v(j)+v(j-1))/2 23095 continue j=j+1 goto 23093 23094 continue if(.not.(y(i).le.u(n)))goto 23097 ty(i)=ty(i)+.5*(y(i)-u(j-1))*(2*v(j-1)+(y(i)-u(j-1))*(v(j)-v(j-1)) 1 /(u(j)-u(j-1))) goto 23098 23097 continue ty(i)=ty(i)+(y(i)-u(n))*v(n) 23098 continue 23092 continue i=i+1 goto 23088 23090 continue return end block data avasdata common /parms/ itape,maxit,nterm,span,alpha common /spans/ spans(3) /consts/ big,sml,eps c------------------------------------------------------------------ c c these procedure parameters can be changed in the calling routine c by defining the above labeled common and resetting the values with c executable statements. c c itape : fortran file number for printer output. c (itape.le.0 => no printer output.) c maxit : maximum number of iterations. c nterm : number of consecutive iterations for which c rsq must change less than delcor for convergence. c span, alpha : super smoother parameters. c (see - friedman and stuetzle, reference above.) c c------------------------------------------------------------------ data itape,maxit,nterm,span,alpha /-6,20,3,0.0,5.0/ c--------------------------------------------------------------- c c this sets the compile time (default) values for various c internal parameters : c c spans : span values for the three running linear smoothers. c spans(1) : tweeter span. c spans(2) : midrange span. c spans(3) : woofer span. c (these span values should be changed only with care.) c big : a large representable floating point number. c sml : a small number. should be set so that (sml)**(10.0) does c not cause floating point underflow. c eps : used to numerically stabilize slope calculations for c running linear fits. c c these parameter values can be changed by declaring the c relevant labeled common in the main program and resetting c them with executable statements. c c----------------------------------------------------------------- data spans,big,sml,eps /0.05,0.2,0.5,1.0e20,1.0e-4,1.0e-3/ end subroutine smothr (l,n,x,y,w,smo,scr) double precision x(n),y(n),w(n),smo(n),scr(n,7) common /parms/ itape,maxit,nterm,span,alpha double precision sm,sw,a,b,d if (l.lt.5) go to 50 j=1 10 j0=j sm=w(j)*y(j) sw=w(j) if (j.ge.n) go to 30 20 if (x(j+1).gt.x(j)) go to 30 j=j+1 sm=sm+w(j)*y(j) sw=sw+w(j) if (j.ge.n) go to 30 go to 20 30 sm=sm/sw do 40 i=j0,j smo(i)=sm 40 continue j=j+1 if (j.gt.n) go to 250 go to 10 50 if (l.ne.4) go to 80 sm=0.0 sw=sm b=sw d=b do 60 j=1,n sm=sm+w(j)*x(j)*y(j) sw=sw+w(j)*x(j)**2 b=b+w(j)*x(j) d=d+w(j) 60 continue a=sm/(sw-(b**2)/d) b=b/d do 70 j=1,n smo(j)=a*(x(j)-b) 70 continue go to 250 80 call supsmu (n,x,y,w,l,span,alpha,smo,scr) if (l.ne.3) go to 250 do 90 j=1,n scr(j,1)=smo(j) scr(n-j+1,2)=scr(j,1) 90 continue call montne (scr,n) call montne (scr(1,2),n) sm=0.0 sw=sm do 100 j=1,n sm=sm+(smo(j)-scr(j,1))**2 sw=sw+(smo(j)-scr(n-j+1,2))**2 100 continue if (sm.ge.sw) go to 120 do 110 j=1,n smo(j)=scr(j,1) 110 continue go to 140 120 do 130 j=1,n smo(j)=scr(n-j+1,2) 130 continue 140 j=1 150 j0=j if (j.ge.n) go to 170 160 if (smo(j+1).ne.smo(j)) go to 170 j=j+1 if (j.ge.n) go to 170 go to 160 170 if (j.le.j0) go to 190 a=0.0 if (j0.gt.1) a=0.5*(smo(j0)-smo(j0-1)) b=0.0 if (j.lt.n) b=0.5*(smo(j+1)-smo(j)) d=(a+b)/(j-j0) if (a.eq.0.0.or.b.eq.0.0) d=2.0*d if (a.eq.0.0) a=b do 180 i=j0,j smo(i)=smo(i)-a+d*(i-j0) 180 continue 190 j=j+1 if (j.gt.n) go to 200 go to 150 200 j=1 210 j0=j sm=smo(j) if (j.ge.n) go to 230 220 if (x(j+1).gt.x(j)) go to 230 j=j+1 sm=sm+smo(j) if (j.ge.n) go to 230 go to 220 230 sm=sm/(j-j0+1) do 240 i=j0,j smo(i)=sm 240 continue j=j+1 if (j.gt.n) go to 250 go to 210 250 return end subroutine montne (x,n) double precision x(n) integer bb,eb,br,er,bl,el bb=0 eb=bb 10 if (eb.ge.n) go to 110 bb=eb+1 eb=bb 20 if (eb.ge.n) go to 30 if (x(bb).ne.x(eb+1)) go to 30 eb=eb+1 go to 20 30 if (eb.ge.n) go to 70 if (x(eb).le.x(eb+1)) go to 70 br=eb+1 er=br 40 if (er.ge.n) go to 50 if (x(er+1).ne.x(br)) go to 50 er=er+1 go to 40 50 pmn=(x(bb)*(eb-bb+1)+x(br)*(er-br+1))/(er-bb+1) eb=er do 60 i=bb,eb x(i)=pmn 60 continue 70 if (bb.le.1) go to 10 if (x(bb-1).le.x(bb)) go to 10 bl=bb-1 el=bl 80 if (bl.le.1) go to 90 if (x(bl-1).ne.x(el)) go to 90 bl=bl-1 go to 80 90 pmn=(x(bb)*(eb-bb+1)+x(bl)*(el-bl+1))/(eb-bl+1) bb=bl do 100 i=bb,eb x(i)=pmn 100 continue go to 30 110 return end subroutine sort (v,a,ii,jj) c c puts into a the permutation vector which sorts v into c increasing order. only elements from ii to jj are considered. c arrays iu(k) and il(k) permit sorting up to 2**(k+1)-1 elements c c this is a modification of cacm algorithm #347 by r. c. singleton, c which is a modified hoare quicksort. c dimension a(jj),v(1) integer iu(20),il(20) integer t,tt integer a double precision v m=1 i=ii j=jj 10 if (i.ge.j) go to 80 20 k=i ij=(j+i)/2 t=a(ij) vt=v(ij) if (v(i).le.vt) go to 30 a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) 30 l=j if (v(j).ge.vt) go to 50 a(ij)=a(j) a(j)=t t=a(ij) v(ij)=v(j) v(j)=vt vt=v(ij) if (v(i).le.vt) go to 50 a(ij)=a(i) a(i)=t t=a(ij) v(ij)=v(i) v(i)=vt vt=v(ij) go to 50 40 a(l)=a(k) a(k)=tt v(l)=v(k) v(k)=vtt 50 l=l-1 if (v(l).gt.vt) go to 50 tt=a(l) vtt=v(l) 60 k=k+1 if (v(k).lt.vt) go to 60 if (k.le.l) go to 40 if (l-i.le.j-k) go to 70 il(m)=i iu(m)=l i=k m=m+1 go to 90 70 il(m)=k iu(m)=j j=l m=m+1 go to 90 80 m=m-1 if (m.eq.0) return i=il(m) j=iu(m) 90 if (j-i.gt.10) go to 20 if (i.eq.ii) go to 10 i=i-1 100 i=i+1 if (i.eq.j) go to 80 t=a(i+1) vt=v(i+1) if (v(i).le.vt) go to 100 k=i 110 a(k+1)=a(k) v(k+1)=v(k) k=k-1 if (vt.lt.v(k)) go to 110 a(k+1)=t v(k+1)=vt go to 100 end subroutine supsmu (n,x,y,w,iper,span,alpha,smo,sc) c------------------------------------------------------------------ c c super smoother (friedman and stuetzle, 1984). c c version 3/10/84 c c coded by: j. h. friedman c department of statistics and c stanford linear accelerator center c stanford university c stanford ca. 94305 c c input: c n : number of observations (x,y - pairs). c x(n) : ordered abscissa values. c y(n) : corresponding ordinate (response) values. c w(n) : weight for each (x,y) observation. c iper : periodic variable flag. c iper=1 => x is ordered interval variable. c iper=2 => x is a periodic variable with values c in the range (0.0,1.0) and peroid 1.0. c span : smoother span (fraction of observations in window). c span=0.0 => automatic (variable) span selection. c alpha : controles high frequency (small span) penality c used with automatic span selection (base tone control). c (alpha.le.0.0 or alpha.gt.10.0 => no effect.) c output: c smo(n) : smoothed ordinate (response) values. c scratch: c sc(n,7) : internal working storage. c c note: c for small samples (n < 40) or if there are substantial serial c correlations between obserations close in x - value, then c a prespecified fixed span smoother (span > 0) should be c used. reasonable span values are 0.3 to 0.5. c c------------------------------------------------------------------ double precision x(n),y(n),w(n),smo(n),sc(n,7) common /spans/ spans(3) /consts/ big,sml,eps double precision h if (x(n).gt.x(1)) go to 30 sy=0.0 sw=sy do 10 j=1,n sy=sy+w(j)*y(j) sw=sw+w(j) 10 continue a=sy/sw do 20 j=1,n smo(j)=a 20 continue return 30 i=n/4 j=3*i scale=x(j)-x(i) 40 if (scale.gt.0.0) go to 50 if (j.lt.n) j=j+1 if (i.gt.1) i=i-1 scale=x(j)-x(i) go to 40 50 vsmlsq=(eps*scale)**2 jper=iper if (iper.eq.2.and.(x(1).lt.0.0.or.x(n).gt.1.0)) jper=1 if (jper.lt.1.or.jper.gt.2) jper=1 if (span.le.0.0) go to 60 call smooth (n,x,y,w,span,jper,vsmlsq,smo,sc) return 60 do 70 i=1,3 call smooth (n,x,y,w,spans(i),jper,vsmlsq,sc(1,2*i-1),sc(1,7)) call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2*i),h) 70 continue do 90 j=1,n resmin=big do 80 i=1,3 if (sc(j,2*i).ge.resmin) go to 80 resmin=sc(j,2*i) sc(j,7)=spans(i) 80 continue if (alpha.gt.0.0.and.alpha.le.10.0.and.resmin.lt.sc(j,6)) sc(j,7)= 1sc(j,7)+(spans(3)-sc(j,7))*max(sml,resmin/sc(j,6))**(10.0-alpha) 90 continue call smooth (n,x,sc(1,7),w,spans(2),-jper,vsmlsq,sc(1,2),h) do 110 j=1,n if (sc(j,2).le.spans(1)) sc(j,2)=spans(1) if (sc(j,2).ge.spans(3)) sc(j,2)=spans(3) f=sc(j,2)-spans(2) if (f.ge.0.0) go to 100 f=-f/(spans(2)-spans(1)) sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,1) go to 110 100 f=f/(spans(3)-spans(2)) sc(j,4)=(1.0-f)*sc(j,3)+f*sc(j,5) 110 continue call smooth (n,x,sc(1,4),w,spans(1),-jper,vsmlsq,smo,h) return end subroutine smooth (n,x,y,w,span,iper,vsmlsq,smo,acvr) double precision x(n),y(n),w(n),smo(n),acvr(n) integer in,out xm=0.0 ym=xm var=ym cvar=var fbw=cvar jper=iabs(iper) ibw=0.5*span*n+0.5 if (ibw.lt.2) ibw=2 it=2*ibw+1 do 20 i=1,it j=i if (jper.eq.2) j=i-ibw-1 xti=x(j) if (j.ge.1) go to 10 j=n+j xti=x(j)-1.0 10 wt=w(j) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(j))/fbw tmp=0.0 if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(j)-ym) 20 continue do 70 j=1,n out=j-ibw-1 in=j+ibw if ((jper.ne.2).and.(out.lt.1.or.in.gt.n)) go to 60 if (out.ge.1) go to 30 out=n+out xto=x(out)-1.0 xti=x(in) go to 50 30 if (in.le.n) go to 40 in=in-n xti=x(in)+1.0 xto=x(out) go to 50 40 xto=x(out) xti=x(in) 50 wt=w(out) fbo=fbw fbw=fbw-wt tmp=0.0 if (fbw.gt.0.0) tmp=fbo*wt*(xto-xm)/fbw var=var-tmp*(xto-xm) cvar=cvar-tmp*(y(out)-ym) xm=(fbo*xm-wt*xto)/fbw ym=(fbo*ym-wt*y(out))/fbw wt=w(in) fbo=fbw fbw=fbw+wt xm=(fbo*xm+wt*xti)/fbw ym=(fbo*ym+wt*y(in))/fbw tmp=0.0 if (fbo.gt.0.0) tmp=fbw*wt*(xti-xm)/fbo var=var+tmp*(xti-xm) cvar=cvar+tmp*(y(in)-ym) 60 a=0.0 if (var.gt.vsmlsq) a=cvar/var smo(j)=a*(x(j)-xm)+ym if (iper.le.0) go to 70 h=1.0/fbw if (var.gt.vsmlsq) h=h+(x(j)-xm)**2/var acvr(j)=abs(y(j)-smo(j))/(1.0-w(j)*h) 70 continue j=1 80 j0=j sy=smo(j)*w(j) fbw=w(j) if (j.ge.n) go to 100 90 if (x(j+1).gt.x(j)) go to 100 j=j+1 sy=sy+w(j)*smo(j) fbw=fbw+w(j) if (j.ge.n) go to 100 go to 90 100 if (j.le.j0) go to 120 sy=sy/fbw do 110 i=j0,j smo(i)=sy 110 continue 120 j=j+1 if (j.gt.n) go to 130 go to 80 130 return end acepack/src/rlsmo.f0000644000076400007640000005451110277042337013546 0ustar baronbaronC MORTRAN 2.79 (RESERVED KEYWORD MACROS OF 09/28/81) SUBROUTINE RLSMO(X,Y,W,SPAN,DOF,N,SMO,RSS,SCRAT) 22 double precision X(N),Y(N),W(N),SMO(N),SCRAT(N) 23 DOUBLE PRECISION CVRSS(6),CVSPAN(6),CVMIN, SPAN, RSS 24 INTEGER IDMIN 25 integer cross 26 DATA CVSPAN/0.3,0.4,0.5,0.6,0.7,1.0/ 27 cross=0 28 IF(span.eq.0) cross=1 29 PENAL=0.01 30 CVMIN=1E15 31 IDMIN=1 33 IF(CROSS .NE. 1)GOTO 10021 37 K=1 37 GOTO 10033 37 10031 K=K+1 37 10033 IF((K).GT.(6))GOTO 10032 37 CALL SMTH(X,Y,W,CVSPAN(K), DOF,N,1,SMO,S0,CVRSS(K),SCRAT) 39 IF(CVRSS(K) .GT. CVMIN)GOTO 10051 40 CVMIN=CVRSS(K) 41 IDMIN=K 42 10051 CONTINUE 43 GOTO 10031 44 10032 CONTINUE 44 SPAN=CVSPAN(IDMIN) 45 IF(PENAL .LE. 0.)GOTO 10071 46 CVMIN=(1.+PENAL)*CVMIN 48 K=6 48 GOTO 10083 48 10081 K=K+(-1) 48 10083 IF((-1)*((K)-(1)).GT.0)GOTO 10082 48 IF(CVRSS(K) .GT. CVMIN)GOTO 10101 48 GOTO 10082 48 10101 CONTINUE 49 GOTO 10081 50 10082 CONTINUE 50 SPAN=CVSPAN(K) 51 10071 CONTINUE 52 10021 CONTINUE 53 CALL SMTH(X,Y,W,SPAN,DOF,N,0,SMO,S0,RSS,SCRAT) 54 DO 10111 i=1,n 54 smo(i)=smo(i)+s0 54 10111 CONTINUE 55 10112 CONTINUE 55 RETURN 56 END 57 SUBROUTINE SMTH(X,Y,W,SPAN,DOF,N,CROSS,SMO,S0,RSS,SCRAT) 58 double precision X(N),Y(N),W(N),SMO(N),SCRAT(N),RSS,SPAN 59 DOUBLE PRECISION SUMW,XBAR,YBAR,COV,VAR 60 INTEGER FIXEDS,CROSS,LINE 70 LINE=1 83 FIXEDS=1 84 IF(SPAN .GE. 1.0)GOTO 10131 84 LINE=0 84 10131 CONTINUE 86 XBAR=X(1) 86 YBAR=Y(1) 86 COV=0. 86 VAR=0. 86 SUMW=W(1) 88 IF(LINE .NE. 1)GOTO 10151 91 DO 10161 I=2,N 91 XIN=X(I) 91 YIN=Y(I) 91 WIN=W(I) 91 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 91 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 91 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 91 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 91 SUMW=SUMW+WIN 91 10161 CONTINUE 92 10162 CONTINUE 92 I=1 94 GOTO 10173 94 10171 I=I+1 94 10173 IF((I).GT.(N))GOTO 10172 94 IF(.NOT.(CROSS.eq.1))GOTO 10191 94 XOUT=X(I) 94 YOUT=Y(I) 94 WIN=W(I) 94 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 94 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 94 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 94 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 94 SUMW=SUMW-WIN 94 10191 CONTINUE 95 IF(VAR .LE. 0.)GOTO 10211 97 SMO(I)=COV*(X(I)-XBAR)/VAR 98 GOTO 10221 99 10211 CONTINUE 99 SMO(I)=0 99 10221 CONTINUE 100 10201 CONTINUE 100 IF(.NOT.(CROSS.eq.1))GOTO 10241 100 XIN=X(I) 100 YIN=Y(I) 100 WIN=W(I) 100 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 100 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 100 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 100 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 100 SUMW=SUMW+WIN 100 10241 CONTINUE 101 GOTO 10171 102 10172 CONTINUE 102 S0=YBAR 103 SCRAT(1)=COV/VAR 104 DOF=1.0 105 GOTO 10251 107 10151 CONTINUE 111 ITOLD=1 111 IBOLD=1 111 DOF=-1.0 115 DO 10261 I=1,N 115 SCRAT(I)=Y(I) 115 10261 CONTINUE 116 10262 CONTINUE 116 IF(.NOT.(cross.eq.0))GOTO 10281 117 I=0 118 10291 IF(I.GE.N-1) GOTO 10292 118 I=I+1 119 M0=I 120 10301 IF(X(I+1).GT.X(I)) GOTO 10302 120 I=I+1 120 IF(I .LT. N)GOTO 10301 120 10302 CONTINUE 121 IF(I.EQ.M0)GOTO 10291 122 NTIE=I-M0+1 123 R=0. 123 WT=0. 123 DO 10311 JJ=M0,I 123 J=JJ 124 R=R+Y(J)*W(J) 124 WT=WT+W(J) 124 10311 CONTINUE 124 10312 CONTINUE 124 R=R/WT 125 DO 10321 J=M0,I 125 Y(J)=R 125 10321 CONTINUE 126 10322 CONTINUE 126 GOTO 10291 127 10292 CONTINUE 127 10281 CONTINUE 128 ISPAN=N*SPAN 129 IF(.NOT.(FIXEDS.eq.1))GOTO 10341 129 IS2=ISPAN/2 129 IF(IS2 .GE. 1)GOTO 10361 129 IS2=1 129 10361 CONTINUE 129 10341 CONTINUE 135 DO 10371 I=1,N 136 ITNEW=MIN(I+IS2,N) 136 IBNEW=MAX(I-IS2,1) 137 10381 IF(ITOLD .GE. ITNEW) GOTO 10382 137 ITOLD=ITOLD+1 137 XIN=X(ITOLD) 137 YIN=Y(ITOLD) 137 WIN=W(ITOLD) 137 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 137 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 137 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 137 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 137 SUMW=SUMW+WIN 137 GOTO 10381 138 10382 CONTINUE 138 10391 IF(IBOLD .LE. IBNEW) GOTO 10392 138 IBOLD=IBOLD-1 138 XIN=X(IBOLD) 138 YIN=Y(IBOLD) 138 WIN=W(IBOLD) 138 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 138 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 138 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 138 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 138 SUMW=SUMW+WIN 138 GOTO 10391 139 10392 CONTINUE 139 10401 IF(ITOLD .LE. ITNEW) GOTO 10402 139 XOUT=X(ITOLD) 139 YOUT=Y(ITOLD) 139 WIN=W(ITOLD) 139 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 139 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 139 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 139 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 139 SUMW=SUMW-WIN 139 ITOLD=ITOLD-1 139 GOTO 10401 140 10402 CONTINUE 140 10411 IF(IBOLD .GE. IBNEW) GOTO 10412 140 XOUT=X(IBOLD) 140 YOUT=Y(IBOLD) 140 WIN=W(IBOLD) 140 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 140 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 140 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 140 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 140 SUMW=SUMW-WIN 140 IBOLD=IBOLD+1 140 GOTO 10411 142 10412 CONTINUE 142 IF(.NOT.(CROSS.eq.1))GOTO 10431 142 XOUT=X(I) 142 YOUT=Y(I) 142 WIN=W(I) 142 COV=COV-WIN*(XOUT-XBAR)*(YOUT-YBAR)*SUMW/(SUMW-WIN) 142 VAR=VAR-WIN*(XOUT-XBAR)**2*SUMW/(SUMW-WIN) 142 XBAR=(SUMW*XBAR-WIN*XOUT)/(SUMW-WIN) 142 YBAR=(SUMW*YBAR-WIN*YOUT)/(SUMW-WIN) 142 SUMW=SUMW-WIN 142 10431 CONTINUE 143 IF(VAR .LE. 0.)GOTO 10451 145 SMO(I)=YBAR+COV*(X(I)-XBAR)/VAR 146 DOF=DOF+W(I)/SUMW+ (W(I)*(X(I)-XBAR)**2)/VAR 148 GOTO 10461 149 10451 CONTINUE 149 SMO(I)=YBAR 149 DOF=DOF+W(I)/SUMW 149 10461 CONTINUE 150 10441 CONTINUE 150 IF(.NOT.(CROSS.eq.1))GOTO 10481 150 XIN=X(I) 150 YIN=Y(I) 150 WIN=W(I) 150 XBAR=(SUMW*XBAR+XIN*WIN)/(SUMW+WIN) 150 YBAR=(SUMW*YBAR+YIN*WIN)/(SUMW+WIN) 150 COV=COV+WIN*(XIN-XBAR)*(YIN-YBAR)*(SUMW+WIN)/SUMW 150 VAR=VAR+WIN*(XIN-XBAR)**2*(SUMW+WIN)/SUMW 150 SUMW=SUMW+WIN 150 10481 CONTINUE 151 10371 CONTINUE 155 10372 CONTINUE 155 DO 10491 I=1,N 155 Y(I)=SCRAT(I) 155 10491 CONTINUE 156 10492 CONTINUE 156 IF(CROSS .NE. 0)GOTO 10511 157 I=0 158 10521 IF(I.GE.N-1) GOTO 10522 158 I=I+1 159 M0=I 160 10531 IF(X(I+1).GT.X(I)) GOTO 10532 160 I=I+1 160 IF(I .LT. N)GOTO 10531 160 10532 CONTINUE 161 IF(I.EQ.M0)GOTO 10521 162 NTIE=I-M0+1 163 R=0. 163 WT=0. 163 DO 10541 JJ=M0,I 163 J=JJ 164 R=R+SMO(J)*W(J) 164 WT=WT+W(J) 164 10541 CONTINUE 164 10542 CONTINUE 164 R=R/WT 165 DO 10551 J=M0,I 165 SMO(J)=R 165 10551 CONTINUE 166 10552 CONTINUE 166 GOTO 10521 167 10522 CONTINUE 167 10511 CONTINUE 168 YBAR=0.0 168 SUMW=0.0 169 DO 10561 I=1,N 169 YBAR=YBAR+W(I)*Y(I) 169 SUMW=SUMW+W(I) 169 10561 CONTINUE 170 10562 CONTINUE 170 YBAR=YBAR/SUMW 171 DO 10571 I=1,N 171 SMO(I)=SMO(I)-YBAR 171 10571 CONTINUE 172 10572 CONTINUE 172 S0=YBAR 173 10251 CONTINUE 174 10141 CONTINUE 174 RSS=0.0 175 DO 10581 I=1,N 175 RSS=RSS+(W(I)/SUMW)*(Y(I)-S0-SMO(I))**2 175 10581 CONTINUE 178 10582 CONTINUE 178 RETURN 178 END 178 acepack/src/ace.f0000644000076400007640000003750110277042212013132 0ustar baronbaronC real -> double precision conversion for R use C c mortran 2.0 (version of 6/24/75) subroutine mace (p,n,x,y,w,l,delrsq,ns,tx,ty,rsq,ierr,m,z) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c c subroutine mace(p,n,x,y,w,l,delrsq,ns,tx,ty,rsq,ierr,m,z) c------------------------------------------------------------------ c c estimate multiple optimal transformations for regression and c correlation by alternating conditional expectation estimates. c c version 3/28/85. c c breiman and friedman, journal of the american statistical c association (september, 1985) c c coded and copywrite (c) 1985 by: c c jerome h. friedman c department of statistics c and c stanford linear accelerator center c stanford university c c all rights reserved. c c c input: c c n : number of observations. c p : number of predictor variables for each observation. c x(p,n) : predictor data matrix. c y(n) : response values for the observations. c missing values are signified by a value (response or c predictor) greater than or equal to big. c (see below - default, big = 1.0e20) c w(n) : weights for the observations. c l(p+1) : flag for each variable. c l(1) through l(p) : predictor variables. c l(p+1) : response variable. c l(i)=0 => ith variable not to be used. c l(i)=1 => ith variable assumes orderable values. c l(i)=2 => ith variable assumes circular (periodic) values c in the range (0.0,1.0) with period 1.0. c l(i)=3 => ith variable transformation is to be monotone. c l(i)=4 => ith variable transformation is to be linear. c l(i)=5 => ith variable assumes categorical (unorderable) values. c delrsq : termination threshold. iteration stops when c rsq changes less than delrsq in nterm c consecutive iterations (see below - default, nterm=3). c ns : number of eigensolutions (sets of transformations). c c output: c c tx(n,p,ns) : predictor transformations. c tx(j,i,k) = transformed value of ith predictor for jth obs c for kth eigensolution. c ty(n,ns) = response transformations. c ty(j,k) = transformed response value for jth observation c for kth eigensolution. c rsq(ns) = fraction of variance(ty) c p c explained by sum tx(i) for each eigensolution. c i=1 c ierr : error flag. c ierr = 0 : no errors detected. c ierr > 0 : error detected - see format statements below. c c scratch: c c m(n,p+1), z(n,12) : internal working storage. c c note: mace uses an iterative procedure for solving the optimization c problem. default starting transformations are ty(j,k)=y(j), c tx(j,i,k)=x(i,j) : j=1,n, i=1,p, k=1,ns. other starting transformat c can be specified (if desired) for either the response and/or any of c the predictor variables. this is signaled by negating the c corresponding l(i) value and storing the starting transformed c values in the corresponding array (ty(j,k), tx(j,i,k)) before c calling mace. c c------------------------------------------------------------------ c integer p,pp1,m(n,p+1),l(p+1) double precision y(n),x(p,n),w(n),ty(n,ns),tx(n,p,ns) double precision z(n,12),ct(10),rsq(ns) double precision delrsq common /prams/ alpha,big,span,itape,maxit,nterm double precision sm,sv,sw,sw1 ierr=0 pp1=p+1 sm=0.0 sv=sm sw=sv sw1=sw do 10 i=1,pp1 if (l(i).ge.-5.and.l(i).le.5) go to 10 ierr=6 if (itape.gt.0) write (itape,670) i,l(i) 10 continue if (ierr.ne.0) return if (l(pp1).ne.0) go to 20 ierr=4 if (itape.gt.0) write (itape,650) pp1 return 20 np=0 do 30 i=1,p if (l(i).ne.0) np=np+1 30 continue if (np.gt.0) go to 40 ierr=5 if (itape.gt.0) write (itape,660) p return 40 do 50 j=1,n sw=sw+w(j) 50 continue if (sw.gt.0.0) go to 60 ierr=1 if (itape.gt.0) write (itape,620) return 60 do 580 is=1,ns if (itape.gt.0) write (itape,590) is do 70 j=1,n if (l(pp1).gt.0) ty(j,is)=y(j) 70 continue do 170 i=1,p if (l(i).ne.0) go to 90 do 80 j=1,n tx(j,i,is)=0.0 80 continue go to 170 90 if (l(i).le.0) go to 110 do 100 j=1,n tx(j,i,is)=x(i,j) 100 continue 110 do 120 j=1,n if (tx(j,i,is).ge.big) go to 120 sm=sm+w(j)*tx(j,i,is) sw1=sw1+w(j) 120 continue if (sw1.gt.0.0) go to 140 do 130 j=1,n tx(j,i,is)=0.0 130 continue sm=0.0 sw1=sm go to 170 140 sm=sm/sw1 do 160 j=1,n if (tx(j,i,is).ge.big) go to 150 tx(j,i,is)=tx(j,i,is)-sm go to 160 150 tx(j,i,is)=0.0 160 continue sm=0.0 sw1=sm 170 continue do 180 j=1,n if (ty(j,is).ge.big) go to 180 sm=sm+w(j)*ty(j,is) sw1=sw1+w(j) 180 continue if (sw1.gt.0.0) go to 190 ierr=1 if (itape.gt.0) write (itape,620) return 190 sm=sm/sw1 do 210 j=1,n if (ty(j,is).ge.big) go to 200 ty(j,is)=ty(j,is)-sm go to 210 200 ty(j,is)=0.0 210 continue do 220 j=1,n sv=sv+w(j)*ty(j,is)**2 220 continue sv=sv/sw if (sv.le.0.0) go to 230 sv=1.0/dsqrt(sv) go to 260 230 if (l(pp1).le.0) go to 240 ierr=2 if (itape.gt.0) write (itape,630) go to 250 240 ierr=3 if (itape.gt.0) write (itape,640) is 250 return 260 do 270 j=1,n ty(j,is)=ty(j,is)*sv 270 continue if (is.ne.1) go to 310 do 280 j=1,n m(j,pp1)=j z(j,2)=y(j) 280 continue call sort (z(1,2),m(1,pp1),1,n) do 300 i=1,p if (l(i).eq.0) go to 300 do 290 j=1,n m(j,i)=j z(j,2)=x(i,j) 290 continue call sort (z(1,2),m(1,i),1,n) 300 continue 310 call scail (p,n,w,sw,ty(1,is),tx(1,1,is),delrsq,p,z(1,5),z(1,6)) rsq(is)=0.0 iter=0 nterm=min0(nterm,10) nt=0 do 320 i=1,nterm ct(i)=100.0 320 continue 330 iter=iter+1 nit=0 340 rsqi=rsq(is) nit=nit+1 do 360 j=1,n z(j,5)=ty(j,is) do 350 i=1,p if (l(i).ne.0) z(j,5)=z(j,5)-tx(j,i,is) 350 continue 360 continue do 420 i=1,p if (l(i).eq.0) go to 420 do 370 j=1,n k=m(j,i) z(j,1)=z(k,5)+tx(k,i,is) z(j,2)=x(i,k) z(j,4)=w(k) 370 continue call smothr (iabs(l(i)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) sm=0.0 do 380 j=1,n sm=sm+z(j,4)*z(j,3) 380 continue sm=sm/sw do 390 j=1,n z(j,3)=z(j,3)-sm 390 continue sv=0.0 do 400 j=1,n sv=sv+z(j,4)*(z(j,1)-z(j,3))**2 400 continue sv=1.0-sv/sw if (sv.le.rsq(is)) go to 420 rsq(is)=sv do 410 j=1,n k=m(j,i) tx(k,i,is)=z(j,3) z(k,5)=z(j,1)-z(j,3) 410 continue 420 continue if (np.eq.1.or.rsq(is)-rsqi.le.delrsq.or.nit.ge.maxit) go to 430 go to 340 430 do 450 j=1,n k=m(j,pp1) z(j,2)=y(k) z(j,4)=w(k) z(j,1)=0.0 do 440 i=1,p if (l(i).ne.0) z(j,1)=z(j,1)+tx(k,i,is) 440 continue 450 continue call smothr (iabs(l(pp1)),n,z(1,2),z,z(1,4),z(1,3),z(1,6)) if (is.le.1) go to 490 ism1=is-1 do 480 js=1,ism1 sm=0.0 do 460 j=1,n k=m(j,pp1) sm=sm+w(k)*z(j,3)*ty(k,js) 460 continue sm=sm/sw do 470 j=1,n k=m(j,pp1) z(j,3)=z(j,3)-sm*ty(k,js) 470 continue 480 continue 490 sm=0.0 sv=sm do 500 j=1,n k=m(j,pp1) sm=sm+w(k)*z(j,3) z(k,2)=z(j,1) 500 continue sm=sm/sw do 510 j=1,n z(j,3)=z(j,3)-sm sv=sv+z(j,4)*z(j,3)**2 510 continue sv=sv/sw if (sv.le.0.0) go to 520 sv=1.0/dsqrt(sv) go to 530 520 ierr=3 if (itape.gt.0) write (itape,640) is return 530 do 540 j=1,n k=m(j,pp1) ty(k,is)=z(j,3)*sv 540 continue sv=0.0 do 550 j=1,n sv=sv+w(j)*(ty(j,is)-z(j,2))**2 550 continue rsq(is)=1.0-sv/sw if (itape.gt.0) write (itape,610) iter,rsq(is) nt=mod(nt,nterm)+1 ct(nt)=rsq(is) cmn=100.0 cmx=-100.0 do 560 i=1,nterm cmn=min(cmn,ct(i)) cmx=max(cmx,ct(i)) 560 continue if (cmx-cmn.le.delrsq.or.iter.ge.maxit) go to 570 go to 330 570 if (itape.gt.0) write (itape,600) is,rsq(is) 580 continue return 590 format('0eigensolution ',i2, ':') 600 format(' eigensolution ',i2, 'h r**2 = 1 - e**2 =',g12.4) 610 format(' iteration ',i2, 'h r**2 = 1 - e**2 =',g12.4) 620 format(' ierr=1: sum of weights (w) not positive.') 630 format(' ierr=2: y has zero variance.') 640 format(' ierr=3: ty(.',i2,') has zero variance.') 650 format(' ierr=4: l(',i2, ') must be nonzero.') 660 format(' ierr=5: at least one l(1)-l(',i2,') must be nonzero.') 670 format(' ierr=6: l(',i2, ') =',g12.4, 1 ' must be in the range (-5, 5).') end subroutine model (p,n,y,w,l,tx,ty,f,t,m,z) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c c subroutine model(p,n,y,w,l,tx,ty,f,t,m,z) c-------------------------------------------------------------------- c c computes response predictive function f for the model yhat = f(t), c where c p c f(t) = e(y : t), t = sum tx ( x ) c i=1 c using the x transformations tx constructed by subroutine ace. c if y is a categorical variable (classification) then c -1 c f(t) = ty (t). c input: c c p,n,y,w,l : same input as for subroutine ace. c tx,ty,m,z : output from subroutine ace. c c output: c c f(n),t(n) : input for subroutine acemod. c c note: this subroutine must be called before subroutine acemod. c c------------------------------------------------------------------- c integer p,pp1,m(n,1),l(1) double precision y(n),w(n),tx(n,p),ty(n),f(n),t(n),z(n,12) common /prams/ alpha,big,span,itape,maxit,nterm pp1=p+1 if (iabs(l(pp1)).ne.5) go to 20 do 10 j=1,n t(j)=ty(j) m(j,pp1)=j 10 continue go to 50 20 do 40 j=1,n s=0.0 do 30 i=1,p s=s+tx(j,i) 30 continue t(j)=s m(j,pp1)=j 40 continue 50 call sort (t,m(1,pp1),1,n) do 140 j=1,n k=m(j,pp1) z(j,2)=w(k) if (y(k).ge.big) go to 60 z(j,1)=y(k) go to 140 60 j1=j j2=j1 70 if (y(m(j1,pp1)).lt.big) go to 80 j1=j1-1 if (j1.lt.1) go to 80 go to 70 80 if (y(m(j2,pp1)).lt.big) go to 90 j2=j2+1 if (j2.gt.n) go to 90 go to 80 90 if (j1.ge.1) go to 100 k=j2 go to 130 100 if (j2.le.n) go to 110 k=j1 go to 130 110 if (t(j)-t(j1).ge.t(j2)-t(j)) go to 120 k=j1 go to 130 120 k=j2 130 z(j,1)=y(m(k,pp1)) t(j)=t(k) 140 continue if (iabs(l(pp1)).ne.5) go to 160 do 150 j=1,n f(j)=z(j,1) 150 continue go to 170 160 call smothr (1,n,t,z,z(1,2),f,z(1,6)) 170 return end subroutine acemod (v,p,n,x,l,tx,f,t,m,yhat) IMPLICIT DOUBLE PRECISION (A-H,O-Z) c subroutine acemod(v,p,n,x,l,tx,f,t,m,yhat) c-------------------------------------------------------------------- c c computes response y estimates from the model c c yhat = f ( t( v ) ) c c using the x transformations tx constructed by subroutine ace and c the predictor function (f,t) constructed by subroutine model. c c input: c c v(p) : vector of predictor values. c p,n,x,l : same input as for subroutine ace. c tx,m : output from subroutine ace. c f,t : output from subroutine model. c c output: c c yhat : estimated response value for v. c c note: this subroutine must not be called before subroutine model. c c------------------------------------------------------------------- c integer p,m(n,1),l(1),low,high,place double precision v(p),x(p,n),f(n),t(n),tx(n,p), yhat common /prams/ alpha,big,span,itape,maxit,nterm th=0.0 do 90 i=1,p if (l(i).eq.0) go to 90 vi=v(i) if (vi.lt.big) go to 10 if (x(i,m(n,i)).ge.big) th=th+tx(m(n,i),i) go to 90 10 if (vi.gt.x(i,m(1,i))) go to 20 place=1 go to 80 20 if (vi.lt.x(i,m(n,i))) go to 30 place=n go to 80 30 low=0 high=n+1 40 if (low+1.ge.high) go to 60 place=(low+high)/2 xt=x(i,m(place,i)) if (vi.eq.xt) go to 80 if (vi.ge.xt) go to 50 high=place go to 40 50 low=place go to 40 60 if (iabs(l(i)).eq.5) go to 90 jl=m(low,i) jh=m(high,i) if (x(i,jh).lt.big) go to 70 th=th+tx(jl,i) go to 90 70 th=th+tx(jl,i)+(tx(jh,i)-tx(jl,i))*(vi-x(i,jl))/(x(i,jh)-x(i,jl)) go to 90 80 th=th+tx(m(place,i),i) 90 continue if (th.gt.t(1)) go to 100 yhat=f(1) return 100 if (th.lt.t(n)) go to 110 yhat=f(n) return 110 low=0 high=n+1 120 if (low+1.ge.high) go to 150 place=(low+high)/2 xt=t(place) if (th.ne.xt) go to 130 yhat=f(place) return 130 if (th.ge.xt) go to 140 high=place go to 120 140 low=place go to 120 150 if (iabs(l(p+1)).ne.5) go to 170 if (th-t(low).gt.t(high)-th) go to 160 yhat=f(low) go to 180 160 yhat=f(high) go to 180 170 yhat=f(low)+(f(high)-f(low))*(th-t(low))/(t(high)-t(low)) 180 return end block data acedata IMPLICIT DOUBLE PRECISION (A-H,O-Z) common /prams/ alpha,big,span,itape,maxit,nterm c c block data c common /prams/ itape,maxit,nterm,span,alpha,big c c------------------------------------------------------------------ c c these procedure parameters can be changed in the calling routine c by defining the above labeled common and resetting the values with c executable statements. c c itape : fortran file number for printer output. c (itape.le.0 => no printer output.) c maxit : maximum number of iterations. c nterm : number of consecutive iterations for which c rsq must change less than delcor for convergence. c span, alpha : super smoother parameters (see below). c big : a large representable floating point number. c c------------------------------------------------------------------ c data itape,maxit,nterm,span,alpha,big /-6,20,3,0.0,0.0,1.0e20/ end subroutine scail (p,n,w,sw,ty,tx,eps,maxit,r,sc) IMPLICIT DOUBLE PRECISION (A-H,O-Z) integer p double precision w(n),ty(n),tx(n,p),r(n),sc(p,5) double precision s,h,t,u,gama,delta,sw, eps do 10 i=1,p sc(i,1)=0.0 10 continue nit=0 20 nit=nit+1 do 30 i=1,p sc(i,5)=sc(i,1) 30 continue do 160 iter=1,p do 50 j=1,n s=0.0 do 40 i=1,p s=s+sc(i,1)*tx(j,i) 40 continue r(j)=(ty(j)-s)*w(j) 50 continue do 70 i=1,p s=0.0 do 60 j=1,n s=s+r(j)*tx(j,i) 60 continue sc(i,2)=-2.0*s/sw 70 continue s=0.0 do 80 i=1,p s=s+sc(i,2)**2 80 continue if (s.le.0.0) go to 170 if (iter.ne.1) go to 100 do 90 i=1,p sc(i,3)=-sc(i,2) 90 continue h=s go to 120 100 gama=s/h h=s do 110 i=1,p sc(i,3)=-sc(i,2)+gama*sc(i,4) 110 continue 120 s=0.0 t=s do 140 j=1,n u=0.0 do 130 i=1,p u=u+sc(i,3)*tx(j,i) 130 continue s=s+u*r(j) t=t+w(j)*u**2 140 continue delta=s/t do 150 i=1,p sc(i,1)=sc(i,1)+delta*sc(i,3) sc(i,4)=sc(i,3) 150 continue 160 continue 170 v=0.0 do 180 i=1,p v=max(v,abs(sc(i,1)-sc(i,5))) 180 continue if (v.lt.eps.or.nit.ge.maxit) go to 190 go to 20 190 do 210 i=1,p do 200 j=1,n tx(j,i)=sc(i,1)*tx(j,i) 200 continue 210 continue return end acepack/README.avas0000644000176000001440000000072406330737116013513 0ustar ripleyusersThis archive contains new S code for avas (additivity and variance stabilization). It is used to estimate transformations for regression. It is officially a public domain product. To use it you need to be able to dynamically load fortran code. To get it going: -compile rlsmo.f and avas.r -source the file avas.s in S - type help(avas) to see how to use it This is not thoroughly tested code and I'd appreciate feedback. Rob Tibshirani tibs@utstat.toronto.edu acepack/README.ace0000644000176000001440000000114606330736742013314 0ustar ripleyusersThe ace distribution consists of the following files: 1. mace.f ace subroutine 2. sort.f sort routine for use by ace 3. supsmu.f supersmoother routine for use by ace 4. ace.doc header files from the above routines, providing documentation for their use 5. README this file If you have any questions or problems, please contact: Phil Spector Statistical Computing Facility Department of Statistics 367 Evans Hall UC Berkeley Berkeley, CA 94720 email: spector@stat.berkeley.edu phone: (415) - 642 - 9056 acepack/README0000644000176000001440000000053406506276017012564 0ustar ripleyusersThis package is based on public domain S and FORTRAN code for AVAS by Tibshirani, and on FORTRAN code for ACE from Statlib, written by Spector and Friedman. The FORTRAN code has been edited to use double precision, for compatibility with R, and the R code and documentation for ace() have been added by Thomas Lumley, based on that for avas(). acepack/R/0000755000176000001440000000000012044030623012064 5ustar ripleyusersacepack/R/zzz.R0000644000176000001440000000010712044030505013041 0ustar ripleyusers.onLoad <- function(lib, pkg) { library.dynam("acepack", pkg, lib) } acepack/R/acepack.R0000644000176000001440000001432311737272070013615 0ustar ripleyusersace <- function (x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01) { x <- as.matrix(x) if (delrsq <= 0) { cat("delrsq must be positive") return() } iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if (!is.null(circ)) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) { cat("bad circ= specification") return() } if (circ[i] == 0) { nncol <- iy } else { nncol <- circ[i] } if (l[nncol] != 2 & l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 2 } } if (length(mon)) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) { cat("bad mon= specification") return() } if (mon[i] == 0) { nncol <- iy } else { nncol <- mon[i] } if (l[nncol] != 3 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 3 } } if (length(lin)) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) { cat("bad lin= specification") return() } if (lin[i] == 0) { nncol <- iy } else { nncol <- lin[i] } if (l[nncol] != 4 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) { cat("bad cat= specification") return() } if (cat[i] == 0) { nncol <- iy } else { nncol <- cat[i] } if (l[nncol] != 5 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = iy) z <- matrix(0, nrow = nrow(x), ncol = 12) z <- as.matrix(z) ns <- 1 mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(delrsq) <- "double" mode(z) <- "double" junk <- .Fortran("mace", p = as.integer(ncol(x)), n = as.integer(nrow(x)), x = t(x), y = y, w = as.double(wt), l = as.integer(l), delrsq = delrsq, ns = as.integer(ns), tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m = as.integer(m), z = z, PACKAGE = "acepack") return(junk) } avas <- function (x, y, wt = rep(1, nrow(x)), cat = NULL, mon = NULL, lin = NULL, circ = NULL, delrsq = 0.01, yspan = 0) { x <- as.matrix(x); if (delrsq <= 0) { cat("delrsq must be positive") return() } iy <- ncol(x) + 1 l <- matrix(1, ncol = iy) if (length(circ)) { for (i in 1:length(circ)) { if (circ[i] < 0 || circ[i] > ncol(x)) { cat("bad circ= specification") return() } if (circ[i] == 0) { nncol <- iy } else { nncol <- circ[i] } if (l[nncol] != 2 & l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 2 } } if (length(mon)) { for (i in 1:length(mon)) { if (mon[i] < 0 || mon[i] > ncol(x)) { cat("bad mon= specification") return() } if (mon[i] == 0) { nncol <- iy } else { nncol <- mon[i] } if (l[nncol] != 3 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 3 } } if (length(lin)) { for (i in 1:length(lin)) { if (lin[i] < 0 || lin[i] > ncol(x)) { cat("bad lin= specification") return() } if (lin[i] == 0) { nncol <- iy } else { nncol <- lin[i] } if (l[nncol] != 4 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 4 } } if (length(cat)) { for (i in 1:length(cat)) { if (cat[i] < 0 || cat[i] > ncol(x)) { cat("bad cat= specification") return() } if (cat[i] == 0) { nncol <- iy } else { nncol <- cat[i] } if (l[nncol] != 5 && l[nncol] != 1) { cat("conflicting transformation specifications") return() } l[nncol] <- 5 } } tx <- x ty <- y m <- matrix(0, nrow = nrow(x), ncol = ncol(x) + 2) z <- matrix(0, nrow = nrow(x), ncol = 17) z <- as.matrix(z) iters <- matrix(0, nrow = 100, ncol = 2) mode(x) <- "double" mode(y) <- "double" mode(tx) <- "double" mode(ty) <- "double" mode(wt) <- "double" mode(m) <- "integer" mode(l) <- "integer" mode(delrsq) <- "double" mode(z) <- "double" mode(yspan) <- "double" mode(iters) <- "double" junk <- .Fortran("avas", as.integer(ncol(x)), as.integer(nrow(x)), x, y, wt, l, delrsq, tx = tx, ty = ty, rsq = double(1), ierr = integer(1), m, z, yspan = yspan, niter = integer(1), iters = iters, PACKAGE = "acepack") junk$iters <- junk$iters[1:junk$niter, ] return(list(x = t(x), y = y, tx = junk$tx, ty = junk$ty, rsq = junk$rsq, l=l, m, yspan = junk$yspan, iters = junk$iters, niters = junk$niter)) } acepack/NAMESPACE0000644000176000001440000000017111737306007013113 0ustar ripleyusers# Default NAMESPACE created by R # Remove the previous line if you edit this file # Export all names exportPattern(".") acepack/LICENSE0000644000176000001440000001216711325135724012710 0ustar ripleyusersFor the AVAS license, see README.avas. The following, concerning ACE, written by Tom "spot" Callaway, is from the Fedora R-acepack RPM. ######################## The copyright on the ace implementation was clear, but its licensing terms were not. I was able to clarify the terms with the copyright holder: Copyright 2007 Jerome H. Friedman Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. ========================================================================= To remove any hint of impropriety, here are copies of my email communications with the copyright holder. From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:05:10 -0800 Tom, >> > We would like to include it in Fedora, but we need to know the >> > licensing >> > terms for that code. >> >> Sorry for my ignorance, but what is Fedora? > > Fedora is a very popular distribution of Linux. Our previous name was > "Red Hat Linux". Right. I should have remembered that. You hereby have my permission to distribute my ACE code in Fedora. Cheers, Jerry. From tcallawa@redhat.com Wed Oct 31 15:10:12 2007 Subject: Re: license for ace() From: "Tom \"spot\" Callaway" To: "Jerome H. Friedman" Date: Wed, 31 Oct 2007 15:10:12 -0400 On Wed, 2007-10-31 at 11:05 -0800, Jerome H. Friedman wrote: > Tom, > > >> > We would like to include it in Fedora, but we need to know the > >> > licensing > >> > terms for that code. > >> > >> Sorry for my ignorance, but what is Fedora? > > > > Fedora is a very popular distribution of Linux. Our previous name was > > "Red Hat Linux". > > Right. I should have remembered that. > > You hereby have my permission to distribute my ACE code in Fedora. Great! Now, I just need to know under what licensing terms we can distribute it under. :) Here are several common licenses: MIT ==== Copyright 19XX John Doe Permission to use, copy, modify, distribute, and sell this software and its documentation for any purpose is hereby granted without fee, provided that the above copyright notice appear in all copies and that both that copyright notice and this permission notice appear in supporting documentation. No representations are made about the suitability of this software for any purpose. It is provided "as is" without express or implied warranty. BSD ==== Copyright (c) , All rights reserved. Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met: * Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer. * Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution. * Neither the name of the nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission. THIS SOFTWARE IS PROVIDED BY THE REGENTS AND CONTRIBUTORS ``AS IS'' AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE REGENTS OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. GPLv2 ====== http://www.gnu.org/licenses/old-licenses/gpl-2.0.html If none of those licenses seems correct to you, let me know, and I will show you some others. Thanks, ~Tom From: "Jerome H. Friedman" To: "Tom \"spot\" Callaway" Subject: Re: license for ace() Date: Wed, 31 Oct 2007 11:43:34 -0800 Tom, > MIT > ==== > Copyright 19XX John Doe > > Permission to use, copy, modify, distribute, and sell this software and > its documentation for any purpose is hereby granted without fee, > provided that the above copyright notice appear in all copies and that > both that copyright notice and this permission notice appear in > supporting documentation. No representations are made about the > suitability of this software for any purpose. It is provided "as is" > without express or implied warranty. I think this is good enough. Jerry. acepack/DESCRIPTION0000644000176000001440000000070412140735252013401 0ustar ripleyusersPackage: acepack Maintainer: Jonathan Baron Version: 1.3-3.3 Author: Phil Spector, Jerome Friedman, Robert Tibshirani, Thomas Lumley Description: ACE and AVAS methods for choosing regression transformations. Title: ace() and avas() for selecting regression transformations License: MIT + file LICENSE Packaged: 2013-05-03 13:22:51 UTC; ripley Repository: CRAN Date/Publication: 2013-05-03 15:24:58 NeedsCompilation: yes acepack/CHANGES0000644000176000001440000000113511737305744012677 0ustar ripleyusers4-5-2012 Added namespace and removed stray print in avas. 7-4-2010 Fixed options circ, cat, and mon, in both ace and avas, so that they now can apply to the dependent variable, as specified previously in both the help page and the fortran code. Colin McCullogh did most of the work. Frank Harrell also reported this bug. Fixed the checks on the options so that they apply to the correct dimension. Previously circ and mon were not working as described. Thanks to Frank Harrell. Expanded the help pages to make them clearer and provide more examples. Jon Baron