add files for public distribution
based on internal repository 0a462b6 2017-11-22 14:41:39 +0100
This commit is contained in:
2
pmsco/loess/.gitignore
vendored
Normal file
2
pmsco/loess/.gitignore
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
loess.py
|
||||
loess_wrap.c
|
||||
115
pmsco/loess/README
Normal file
115
pmsco/loess/README
Normal file
@ -0,0 +1,115 @@
|
||||
Software for Locally-Weighted Regression 18 August 1992
|
||||
|
||||
William S. Cleveland
|
||||
Eric Grosse
|
||||
Ming-Jen Shyu
|
||||
|
||||
Locally-weighted regression, or loess, is a procedure for estimating a
|
||||
regression surface by a multivariate smoothing procedure: fitting a
|
||||
linear or quadratic function of the independent variables in a moving
|
||||
fashion that is analogous to how a moving average is computed for a
|
||||
time series. Compared to classical approaches - fitting global
|
||||
parametric functions - loess substantially increases the domain of
|
||||
surfaces that can be estimated without distortion. Also, a pleasant
|
||||
fact about loess is that analogues of the statistical procedures used
|
||||
in parametric function fitting - for example, ANOVA and t intervals -
|
||||
involve statistics whose distributions are well approximated by
|
||||
familiar distributions.
|
||||
|
||||
The follwing files are included in this distribution.
|
||||
README the instruction file you are reading now
|
||||
S.h header file
|
||||
air.c C source for air data example
|
||||
changes history of changes to loess
|
||||
depend.ps PostScript figure of how routines are related
|
||||
ethanol.c C source for ethanol data example
|
||||
galaxy.c C source for galaxy data example
|
||||
gas.c C source for gas data example
|
||||
loess.c C source (high-level loess routines)
|
||||
loess.h header file for loess_struct and predict_struct
|
||||
loess.m manual page for user-callable loess routines
|
||||
loessc.c C source (low-level loess routines)
|
||||
loessf.f FORTRAN source (low-level loess & predict routines)
|
||||
loessf.m documentation for FORTRAN source
|
||||
madeup.c C source for madeup data example
|
||||
makefile makefile to compile the example codes
|
||||
misc.c C source (anova, pointwise, and other support routines)
|
||||
predict.c C source (high-level predict routines)
|
||||
predict.m manual page for user-callable predict routines
|
||||
struct.m manual page for loess_struct, pred_struct
|
||||
supp.f supplemental Fortran loess drivers
|
||||
|
||||
After unpacking these files, just type "make" and if all goes well
|
||||
you should see output like:
|
||||
|
||||
loess(&gas):
|
||||
Number of Observations: 22
|
||||
Equivalent Number of Parameters: 5.5
|
||||
Residual Standard Error: 0.3404
|
||||
|
||||
loess(&gas_null):
|
||||
Number of Observations: 22
|
||||
Equivalent Number of Parameters: 3.5
|
||||
Residual Standard Error: 0.5197
|
||||
|
||||
predict(gas_fit_E, m, &gas, &gas_pred):
|
||||
1.19641 5.06875 0.523682
|
||||
|
||||
pointwise(&gas_pred, m, coverage, &gas_ci):
|
||||
1.98562 4.10981 5.48023 5.56651 3.52761 1.71062 1.47205
|
||||
1.19641 3.6795 5.05571 5.13526 3.14366 1.19693 0.523682
|
||||
0.407208 3.24919 4.63119 4.70401 2.7597 0.683247 -0.424684
|
||||
|
||||
anova(&gas_null, &gas, &gas_anova):
|
||||
2.5531 15.663 10.1397 0.000860102
|
||||
|
||||
To run other examples, simply type "make galaxy", or "make ethanol", etc.
|
||||
|
||||
If your loader complains about "-llinpack -lblas" in the makefile, change
|
||||
it to whatever your system prefers for accessing Linpack and the Blas.
|
||||
If necessary, these Fortran subroutines can be obtained by
|
||||
mail netlib@netlib.bell-labs.com
|
||||
send dnrm2 dsvdc dqrdc ddot dqrsl idamax from linpack core.
|
||||
|
||||
A 50 page user guide, in PostScript form, is available by anonymous ftp.
|
||||
ftp netlib.bell-labs.com
|
||||
login: anonymous
|
||||
password: <your email address>
|
||||
binary
|
||||
cd /netlib/a
|
||||
get cloess.ps.Z
|
||||
quit
|
||||
uncompress cloess.ps
|
||||
This guide describes crucial steps in the proper analysis of data using
|
||||
loess. Please read it.
|
||||
|
||||
Bug reports are appreciated. Send electronic mail to
|
||||
ehg@netlib.bell-labs.com
|
||||
including the words "this is not spam" in the Subject line
|
||||
or send paper mail to
|
||||
Eric Grosse
|
||||
Bell Labs 2T-502
|
||||
Murray Hill NJ 07974
|
||||
for problems with the Fortran inner core of the algorithm.
|
||||
The C drivers were written by Ming-Jen Shyu, who left Bell Labs. Eric will
|
||||
fix problems with them when he can.
|
||||
|
||||
Remember that this is experimental software distributed free of charge
|
||||
and comes with no warranty! Exercise professional caution.
|
||||
|
||||
Happy Smoothing!
|
||||
|
||||
/*
|
||||
* The authors of this software are Cleveland, Grosse, and Shyu.
|
||||
* Copyright (c) 1989, 1992 by AT&T.
|
||||
* Permission to use, copy, modify, and distribute this software for any
|
||||
* purpose without fee is hereby granted, provided that this entire notice
|
||||
* is included in all copies of any software which is or includes a copy
|
||||
* or modification of this software and in all copies of the supporting
|
||||
* documentation for such software.
|
||||
* THIS SOFTWARE IS BEING PROVIDED "AS IS", WITHOUT ANY EXPRESS OR IMPLIED
|
||||
* WARRANTY. IN PARTICULAR, NEITHER THE AUTHORS NOR AT&T MAKE ANY
|
||||
* REPRESENTATION OR WARRANTY OF ANY KIND CONCERNING THE MERCHANTABILITY
|
||||
* OF THIS SOFTWARE OR ITS FITNESS FOR ANY PARTICULAR PURPOSE.
|
||||
*/
|
||||
|
||||
31
pmsco/loess/S.h
Normal file
31
pmsco/loess/S.h
Normal file
@ -0,0 +1,31 @@
|
||||
#include <stdlib.h>
|
||||
#include <stdio.h>
|
||||
#include <math.h>
|
||||
#include <string.h>
|
||||
|
||||
#define Calloc(n,t) (t *)calloc((unsigned)(n),sizeof(t))
|
||||
#define Free(p) free((char *)(p))
|
||||
|
||||
/* the mapping from f77 to C intermediate code -- may be machine dependent
|
||||
* the first definition satisfies lint's narrowminded preprocessing & should
|
||||
* stay the same for all implementations. The __STDC__ definition is for
|
||||
* ANSI standard conforming C compilers. The #else definition should
|
||||
* generate the version of the fortran subroutine & common block names x
|
||||
* handed to the local loader; e.g., "x_" in system V, Berkeley & 9th edition
|
||||
*/
|
||||
|
||||
#ifdef lint
|
||||
#define F77_SUB(x) x
|
||||
#define F77_COM(x) x
|
||||
#else
|
||||
#ifdef __STDC__
|
||||
#define F77_SUB(x) x##_
|
||||
#define F77_COM(x) x##_
|
||||
#else
|
||||
#define F77_SUB(x) x/**/_
|
||||
#define F77_COM(x) x/**/_
|
||||
#endif
|
||||
#endif
|
||||
|
||||
#define NULL_ENTRY ((int *)NULL)
|
||||
|
||||
1
pmsco/loess/__init__.py
Normal file
1
pmsco/loess/__init__.py
Normal file
@ -0,0 +1 @@
|
||||
__author__ = 'matthias muntwiler'
|
||||
78
pmsco/loess/air.c
Normal file
78
pmsco/loess/air.c
Normal file
@ -0,0 +1,78 @@
|
||||
#include <stdio.h>
|
||||
#include "loess.h"
|
||||
|
||||
struct loess_struct air;
|
||||
double ozone[] = {3.44821724038273, 3.30192724889463, 2.28942848510666,
|
||||
2.6207413942089, 2.84386697985157, 2.66840164872194, 2,
|
||||
2.51984209978975, 2.22398009056931, 2.41014226417523,
|
||||
2.6207413942089, 2.41014226417523, 3.23961180127748,
|
||||
1.81712059283214, 3.10723250595386, 2.22398009056931, 1,
|
||||
2.22398009056931, 1.5874010519682, 3.1748021039364,
|
||||
2.84386697985157, 3.55689330449006, 4.86294413109428,
|
||||
3.33222185164595, 3.07231682568585, 4.14081774942285,
|
||||
3.39121144301417, 2.84386697985157, 2.75892417638112,
|
||||
3.33222185164595, 2.71441761659491, 2.28942848510666,
|
||||
2.35133468772076, 5.12992784003009, 3.65930571002297,
|
||||
3.1748021039364, 4, 3.41995189335339, 4.25432086511501,
|
||||
4.59470089220704, 4.59470089220704, 4.39682967215818,
|
||||
2.15443469003188, 3, 1.91293118277239, 3.63424118566428,
|
||||
3.27106631018859, 3.93649718310217, 4.29084042702621,
|
||||
3.97905720789639, 2.51984209978975, 4.30886938006377,
|
||||
4.7622031559046, 2.71441761659491, 3.73251115681725,
|
||||
4.34448148576861, 3.68403149864039, 4, 3.89299641587326,
|
||||
3.39121144301417, 2.0800838230519, 2.51984209978975,
|
||||
4.9596756638423, 4.46474509558454, 4.79141985706278,
|
||||
3.53034833532606, 3.03658897187566, 4.02072575858906,
|
||||
2.80203933065539, 3.89299641587326, 2.84386697985157,
|
||||
3.14138065239139, 3.53034833532606, 2.75892417638112,
|
||||
2.0800838230519, 3.55689330449006, 5.51784835276224,
|
||||
4.17933919638123, 4.23582358425489, 4.90486813152402,
|
||||
4.37951913988789, 4.39682967215818, 4.57885697021333,
|
||||
4.27265868169792, 4.17933919638123, 4.49794144527541,
|
||||
3.60882608013869, 3.1748021039364, 2.71441761659491,
|
||||
2.84386697985157, 2.75892417638112, 2.88449914061482,
|
||||
3.53034833532606, 2.75892417638112, 3.03658897187566,
|
||||
2.0800838230519, 2.35133468772076, 3.58304787101595,
|
||||
2.6207413942089, 2.35133468772076, 2.88449914061482,
|
||||
2.51984209978975, 2.35133468772076, 2.84386697985157,
|
||||
3.30192724889463, 1.91293118277239, 2.41014226417523,
|
||||
3.10723250595386, 2.41014226417523, 2.6207413942089,
|
||||
2.71441761659491};
|
||||
double rad_temp_wind[] = {190, 118, 149, 313, 299, 99, 19, 256, 290, 274, 65,
|
||||
334, 307, 78, 322, 44, 8, 320, 25, 92, 13, 252, 223, 279, 127,
|
||||
291, 323, 148, 191, 284, 37, 120, 137, 269, 248, 236, 175,
|
||||
314, 276, 267, 272, 175, 264, 175, 48, 260, 274, 285, 187,
|
||||
220, 7, 294, 223, 81, 82, 213, 275, 253, 254, 83, 24, 77, 255,
|
||||
229, 207, 192, 273, 157, 71, 51, 115, 244, 190, 259, 36, 212,
|
||||
238, 215, 203, 225, 237, 188, 167, 197, 183, 189, 95, 92, 252,
|
||||
220, 230, 259, 236, 259, 238, 24, 112, 237, 224, 27, 238, 201,
|
||||
238, 14, 139, 49, 20, 193, 191, 131, 223,
|
||||
67, 72, 74, 62, 65, 59, 61, 69, 66, 68, 58, 64, 66, 57, 68,
|
||||
62, 59, 73, 61, 61, 67, 81, 79, 76, 82, 90, 87, 82, 77, 72,
|
||||
65, 73, 76, 84, 85, 81, 83, 83, 88, 92, 92, 89, 73, 81, 80,
|
||||
81, 82, 84, 87, 85, 74, 86, 85, 82, 86, 88, 86, 83, 81, 81,
|
||||
81, 82, 89, 90, 90, 86, 82, 80, 77, 79, 76, 78, 78, 77, 72,
|
||||
79, 81, 86, 97, 94, 96, 94, 91, 92, 93, 93, 87, 84, 80, 78,
|
||||
75, 73, 81, 76, 77, 71, 71, 78, 67, 76, 68, 82, 64, 71, 81,
|
||||
69, 63, 70, 75, 76, 68,
|
||||
7.4, 8, 12.6, 11.5, 8.6, 13.8, 20.1, 9.7, 9.2, 10.9, 13.2,
|
||||
11.5, 12, 18.4, 11.5, 9.7, 9.7, 16.6, 9.7, 12, 12, 14.9, 5.7,
|
||||
7.4, 9.7, 13.8, 11.5, 8, 14.9, 20.7, 9.2, 11.5, 10.3, 4, 9.2,
|
||||
9.2, 4.6, 10.9, 5.1, 6.3, 5.7, 7.4, 14.3, 14.9, 14.3, 6.9,
|
||||
10.3, 6.3, 5.1, 11.5, 6.9, 8.6, 8, 8.6, 12, 7.4, 7.4, 7.4,
|
||||
9.2, 6.9, 13.8, 7.4, 4, 10.3, 8, 11.5, 11.5, 9.7, 10.3, 6.3,
|
||||
7.4, 10.9, 10.3, 15.5, 14.3, 9.7, 3.4, 8, 9.7, 2.3, 6.3, 6.3,
|
||||
6.9, 5.1, 2.8, 4.6, 7.4, 15.5, 10.9, 10.3, 10.9, 9.7, 14.9,
|
||||
15.5, 6.3, 10.9, 11.5, 6.9, 13.8, 10.3, 10.3, 8, 12.6, 9.2,
|
||||
10.3, 10.3, 16.6, 6.9, 14.3, 8, 11.5};
|
||||
long n = 111, p = 3;
|
||||
|
||||
main() {
|
||||
printf("\nloess(&air):\n");
|
||||
loess_setup(rad_temp_wind, ozone, n, p, &air);
|
||||
air.model.span = 0.8;
|
||||
loess(&air);
|
||||
loess_summary(&air);
|
||||
|
||||
loess_free_mem(&air);
|
||||
}
|
||||
168
pmsco/loess/changes
Normal file
168
pmsco/loess/changes
Normal file
@ -0,0 +1,168 @@
|
||||
CHANGES PLANNED SOMEDAY
|
||||
1) more vertices in k-d tree for dimension > 2, to get continuity.
|
||||
2) triangulation based method.
|
||||
----------------------
|
||||
|
||||
19 Nov 1987 workspace not big enough for degree=2
|
||||
|
||||
22 Jan 1988 switched from depth first to breadth first tree build
|
||||
|
||||
14 Mar 1988 lostt.3 extra space needed if (method mod 1000 = 0),
|
||||
not the documented (method/1000=0)
|
||||
|
||||
28 Apr 1988 l2tr.g vval2 needed to be initialized to 0
|
||||
|
||||
galaxy smooth needs double precision on vax
|
||||
|
||||
26 May 1988 bbox.g add 10% margin to allow limited extrapolation
|
||||
|
||||
6 June 1988 loess/lostt.f trL wasn't set if method/1000==0
|
||||
|
||||
10 June 1988 losave, loread
|
||||
|
||||
v(RCOND) 1 / max condition number
|
||||
|
||||
12 June 1988 lofort
|
||||
|
||||
21 June 1988 additional workspace for explicit L
|
||||
|
||||
27 June 1988 workspace checking in lowesf was slightly pessimistic
|
||||
|
||||
30 June 1988 Changed default fdiam to 0.
|
||||
Added warning messages for memory limits and pseudoinverse.
|
||||
|
||||
4 Aug 1988 bbox.g changed margin from 10% to 0.5%.
|
||||
|
||||
24 Aug 1988 loser documentation should have specified workspace
|
||||
of size ...+m*n, not ...+m**2.
|
||||
|
||||
Sep 1988
|
||||
loess-based approximations of delta1,2.
|
||||
pseudo-values, so statistics are available with robustness iterations.
|
||||
reorganize error messages to better fit into S.
|
||||
sample driver program.
|
||||
somewhat shorter code generated by ehg170.
|
||||
|
||||
20 Dec 1988
|
||||
workspace in loser
|
||||
|
||||
27 Jan 1989
|
||||
workspace checking in lostt was a bit pessimistic.
|
||||
|
||||
3 Feb 1989
|
||||
l2fit, l2tr: error message should contain sqrt(rho)
|
||||
|
||||
18 Dec 1989
|
||||
ehg141, ehg179-ehg181: new delta approximations
|
||||
|
||||
24 Jan 1990
|
||||
master copy moved from Sun3/180 to SGI 4D/240S
|
||||
(no intentional changes)
|
||||
|
||||
25 Jan 1990
|
||||
(many routines touched; ehg127 added) cleaned up computational
|
||||
kernel, added provision for only first dd<=d variables to enter
|
||||
the distance calculation ("conditionally parametric variables"),
|
||||
added independent bounds on total and componentwise degree for
|
||||
local polynomial model, made extrapolation warning message print
|
||||
a bit more detail.
|
||||
|
||||
14 Mar 1990
|
||||
added setLf argument to lowesd; added lowesr, lowesl for resmoothing.
|
||||
|
||||
-------------------------------------------------------
|
||||
Converting to the new version of loess
|
||||
5 April 1990
|
||||
|
||||
Over the past few months, a number of changes have been made to the
|
||||
loess package, to provide more control over the local model, to allow
|
||||
conditionally parametric variables, and to return exact statistical
|
||||
quantities for the blending method. Unlike earlier internal
|
||||
algorithmic improvements, this round of changes added some extra
|
||||
arguments in the Fortran calling sequences. The purpose of this note
|
||||
is to assist in converting programs that called the old version.
|
||||
|
||||
An explicit argument setLf has been added to lowesd(), since it affects
|
||||
the partitioning of the workspace. To help protect against inadvertent
|
||||
version mismatches, the version number that lowesd() checks has also
|
||||
been changed. The componentwise degree and the specification of
|
||||
conditionally nonparametric variables can be changed from the default
|
||||
by modifying iv(CDEG) and iv(NDIST).
|
||||
|
||||
The influence matrix L for blending is now explicitly available by
|
||||
calling a new subroutine lowesl(), but this loses the speed
|
||||
advantage of blending. A faster, sometimes equivalent method is
|
||||
to use the influence matrix that carries data values to coefficients
|
||||
at the vertices of the k-d tree. This information is saved in iv(iv(Lq))
|
||||
and v(iv(Lf)), for the afficionado.
|
||||
|
||||
The new subroutine lowesr() takes advantage of Lq and Lf to allow rapid
|
||||
resmoothing for applications when only y, not x, is subject to change.
|
||||
-------------------------------------------------------
|
||||
|
||||
7 May 1990
|
||||
new delta approximations.
|
||||
added prior weights to input format for sample driver.
|
||||
|
||||
29 May 1990
|
||||
loess,lostt,loser,pseudo moved from Fortran to S.
|
||||
|
||||
11 Jul 1990
|
||||
column equilibration, so pseudoinverse is needed less often.
|
||||
|
||||
27 May 1991
|
||||
lowesd version 105; increased nvmax,ncmax to max(200,n).
|
||||
l2fit added ihat=1 (diagL only).
|
||||
ehg133,lowese removed unused arguments dist,eta.
|
||||
ehg190,ehg141 changed name to lowesa, slight change to calling sequence.
|
||||
ehg144 changed name to lowesc
|
||||
m9rwt changed name to lowesw
|
||||
pseudo changed name to lowesp
|
||||
|
||||
22 Jul 1991 IMPORTANT BUG FIX!
|
||||
ehg131 vval2 should be dimensioned 0:d, not 0:8
|
||||
|
||||
26 Jul 1991
|
||||
lowesd change calling sequence to provide tighter memory allocation
|
||||
diff old/man/internal new/man/internal
|
||||
< lowesd(105,iv,liv,lv,v,d,n,f,tdeg,setLf) setup workspace
|
||||
> lowesd(106,iv,liv,lv,v,d,n,f,tdeg,nvmax,setLf) setup workspace
|
||||
< liv 50+(2^d+6)*max(200,n)
|
||||
< if setLf, add nf*max(200,n)
|
||||
< lv 50+(3*d+4)*max(200,n)+(tau+2)*nf
|
||||
< if setLf, add (d+1)*nf*max(200,n)
|
||||
> liv 50+(2^d+6)*nvmax
|
||||
> if setLf, add nf*nvmax
|
||||
> lv 50+(3*d+4)*nvmax+(tau+2)*nf
|
||||
> if setLf, add (d+1)*nf*nvmax
|
||||
> nvmax limit on number of vertices for kd-tree; e.g. max(200,n)
|
||||
|
||||
20 Sep 1991
|
||||
sample.f brought in sync with recent loess changes.
|
||||
|
||||
24 Dec 1991
|
||||
l2fit.f fixed comment in single precision version
|
||||
|
||||
10 Jan 1992
|
||||
ehg197.f new formula for approximating trL, valid for small f
|
||||
|
||||
15 May 1992
|
||||
netlib/a/dloess now includes C drivers (written by Ming-Jen Shyu,
|
||||
adapted from code used inside the S system)
|
||||
|
||||
22 Jun 1992
|
||||
ehg191.f Loop 11 ran too far, picking up one more value than necessary.
|
||||
The value was not used, so the loess computation itself is unaffected,
|
||||
but on some systems the old code could conceivably cause a reference
|
||||
to an invalid memory address and abort with a segmentation fault
|
||||
message.
|
||||
|
||||
23 Jun 1992
|
||||
S.h #include <math.h>, since loessc.c calls floor() and pow().
|
||||
|
||||
18 Aug 1992
|
||||
netlib/a/dloess A new release with bug fixes in all the C drivers, new
|
||||
example codes, and detail documentations.
|
||||
|
||||
25 Mar 1996
|
||||
predict.c fix enormous memory leak. update email address
|
||||
33320
pmsco/loess/cloess.ps
Normal file
33320
pmsco/loess/cloess.ps
Normal file
File diff suppressed because it is too large
Load Diff
117
pmsco/loess/depend.ps
Normal file
117
pmsco/loess/depend.ps
Normal file
@ -0,0 +1,117 @@
|
||||
%!
|
||||
/Courier-Bold findfont 10 scalefont setfont
|
||||
%draw a box
|
||||
%x y width height box
|
||||
/box { newpath
|
||||
/height exch def
|
||||
/width exch def
|
||||
/y exch def
|
||||
/x exch def
|
||||
x width 2 div sub
|
||||
y height 2 div sub moveto
|
||||
width 0 rlineto
|
||||
0 height rlineto
|
||||
width neg 0 rlineto
|
||||
closepath } def
|
||||
|
||||
%draw a circle
|
||||
%x y radius circle
|
||||
/circle { newpath 0 360 arc } def
|
||||
|
||||
%draw an ellipse
|
||||
%x y width height ellipse
|
||||
/ellipse { gsave
|
||||
/height exch def
|
||||
/width exch def
|
||||
1 height width div scale
|
||||
width height div mul
|
||||
width 2 div
|
||||
circle stroke
|
||||
grestore } def
|
||||
|
||||
%draw a centered label
|
||||
%x y str
|
||||
/label {
|
||||
/str exch def
|
||||
/y exch def
|
||||
/x exch def
|
||||
str stringwidth
|
||||
pop /width exch def
|
||||
x width 2 div sub
|
||||
y 10 3 div sub moveto str show
|
||||
} def
|
||||
|
||||
%draw a line
|
||||
%x1 y1 x2 y2 drawline
|
||||
/drawline { 4 -2 roll moveto lineto stroke } def
|
||||
|
||||
277 684 42 14 box stroke
|
||||
277 684 (lowesd) label
|
||||
349 630 42 14 box stroke
|
||||
349 630 (lowesf) label
|
||||
205 630 42 14 box stroke
|
||||
205 630 (lowesb) label
|
||||
155 565 42 14 box stroke
|
||||
155 565 (lowesr) label
|
||||
146 427 42 14 box stroke
|
||||
146 427 (lowese) label
|
||||
277 576 42 14 box stroke
|
||||
277 576 (lowesl) label
|
||||
203 464 42 14 box stroke
|
||||
203 464 (lofort) label
|
||||
81 576 42 14 box stroke
|
||||
81 576 (losave) label
|
||||
81 522 42 14 box stroke
|
||||
81 522 (lohead) label
|
||||
81 468 42 14 box stroke
|
||||
81 468 (loread) label
|
||||
405 540 42 14 box stroke
|
||||
405 540 (lowesa) label
|
||||
342 539 42 14 box stroke
|
||||
342 539 (lowesc) label
|
||||
92 461 134 434 drawline
|
||||
124.266363 435.502104 134.000000 434.000000 drawline
|
||||
134.000000 434.000000 128.592424 442.231532 drawline
|
||||
81 515 81 475 drawline
|
||||
77.000000 484.000000 81.000000 475.000000 drawline
|
||||
81.000000 475.000000 85.000000 484.000000 drawline
|
||||
81 569 81 529 drawline
|
||||
77.000000 538.000000 81.000000 529.000000 drawline
|
||||
81.000000 529.000000 85.000000 538.000000 drawline
|
||||
289 569 329 546 drawline
|
||||
319.203959 547.018615 329.000000 546.000000 drawline
|
||||
329.000000 546.000000 323.191728 553.953865 drawline
|
||||
154 558 146 434 drawline
|
||||
142.587739 443.238857 146.000000 434.000000 drawline
|
||||
146.000000 434.000000 150.571142 442.723799 drawline
|
||||
188 623 97 583 drawline
|
||||
103.629564 590.283466 97.000000 583.000000 drawline
|
||||
97.000000 583.000000 106.848776 582.959760 drawline
|
||||
204 623 203 471 drawline
|
||||
199.059296 480.026120 203.000000 471.000000 drawline
|
||||
203.000000 471.000000 207.059123 479.973490 drawline
|
||||
214 623 267 583 drawline
|
||||
257.406670 585.228906 267.000000 583.000000 drawline
|
||||
267.000000 583.000000 262.225925 591.614419 drawline
|
||||
199 623 160 572 drawline
|
||||
162.289620 581.579021 160.000000 572.000000 drawline
|
||||
160.000000 572.000000 168.644482 576.719420 drawline
|
||||
220 623 389 547 drawline
|
||||
379.151237 547.043173 389.000000 547.000000 drawline
|
||||
389.000000 547.000000 382.432359 554.339352 drawline
|
||||
202 623 148 434 drawline
|
||||
146.626394 443.752600 148.000000 434.000000 drawline
|
||||
148.000000 434.000000 154.318586 441.554831 drawline
|
||||
348 623 342 546 drawline
|
||||
338.711268 555.283547 342.000000 546.000000 drawline
|
||||
342.000000 546.000000 346.687091 554.662054 drawline
|
||||
353 623 400 547 drawline
|
||||
391.864262 552.550655 400.000000 547.000000 drawline
|
||||
400.000000 547.000000 398.668290 556.758409 drawline
|
||||
267 677 214 637 drawline
|
||||
218.774075 645.614419 214.000000 637.000000 drawline
|
||||
214.000000 637.000000 223.593330 639.228906 drawline
|
||||
286 677 339 637 drawline
|
||||
329.406670 639.228906 339.000000 637.000000 drawline
|
||||
339.000000 637.000000 334.225925 645.614419 drawline
|
||||
showpage
|
||||
274
pmsco/loess/dqrsl.f
Normal file
274
pmsco/loess/dqrsl.f
Normal file
@ -0,0 +1,274 @@
|
||||
subroutine dqrsl(x,ldx,n,k,qraux,y,qy,qty,b,rsd,xb,job,info)
|
||||
integer ldx,n,k,job,info
|
||||
double precision x(ldx,1),qraux(1),y(1),qy(1),qty(1),b(1),rsd(1),
|
||||
* xb(1)
|
||||
c
|
||||
c dqrsl applies the output of dqrdc to compute coordinate
|
||||
c transformations, projections, and least squares solutions.
|
||||
c for k .le. min(n,p), let xk be the matrix
|
||||
c
|
||||
c xk = (x(jpvt(1)),x(jpvt(2)), ... ,x(jpvt(k)))
|
||||
c
|
||||
c formed from columnns jpvt(1), ... ,jpvt(k) of the original
|
||||
c n x p matrix x that was input to dqrdc (if no pivoting was
|
||||
c done, xk consists of the first k columns of x in their
|
||||
c original order). dqrdc produces a factored orthogonal matrix q
|
||||
c and an upper triangular matrix r such that
|
||||
c
|
||||
c xk = q * (r)
|
||||
c (0)
|
||||
c
|
||||
c this information is contained in coded form in the arrays
|
||||
c x and qraux.
|
||||
c
|
||||
c on entry
|
||||
c
|
||||
c x double precision(ldx,p).
|
||||
c x contains the output of dqrdc.
|
||||
c
|
||||
c ldx integer.
|
||||
c ldx is the leading dimension of the array x.
|
||||
c
|
||||
c n integer.
|
||||
c n is the number of rows of the matrix xk. it must
|
||||
c have the same value as n in dqrdc.
|
||||
c
|
||||
c k integer.
|
||||
c k is the number of columns of the matrix xk. k
|
||||
c must nnot be greater than min(n,p), where p is the
|
||||
c same as in the calling sequence to dqrdc.
|
||||
c
|
||||
c qraux double precision(p).
|
||||
c qraux contains the auxiliary output from dqrdc.
|
||||
c
|
||||
c y double precision(n)
|
||||
c y contains an n-vector that is to be manipulated
|
||||
c by dqrsl.
|
||||
c
|
||||
c job integer.
|
||||
c job specifies what is to be computed. job has
|
||||
c the decimal expansion abcde, with the following
|
||||
c meaning.
|
||||
c
|
||||
c if a.ne.0, compute qy.
|
||||
c if b,c,d, or e .ne. 0, compute qty.
|
||||
c if c.ne.0, compute b.
|
||||
c if d.ne.0, compute rsd.
|
||||
c if e.ne.0, compute xb.
|
||||
c
|
||||
c note that a request to compute b, rsd, or xb
|
||||
c automatically triggers the computation of qty, for
|
||||
c which an array must be provided in the calling
|
||||
c sequence.
|
||||
c
|
||||
c on return
|
||||
c
|
||||
c qy double precision(n).
|
||||
c qy conntains q*y, if its computation has been
|
||||
c requested.
|
||||
c
|
||||
c qty double precision(n).
|
||||
c qty contains trans(q)*y, if its computation has
|
||||
c been requested. here trans(q) is the
|
||||
c transpose of the matrix q.
|
||||
c
|
||||
c b double precision(k)
|
||||
c b contains the solution of the least squares problem
|
||||
c
|
||||
c minimize norm2(y - xk*b),
|
||||
c
|
||||
c if its computation has been requested. (note that
|
||||
c if pivoting was requested in dqrdc, the j-th
|
||||
c component of b will be associated with column jpvt(j)
|
||||
c of the original matrix x that was input into dqrdc.)
|
||||
c
|
||||
c rsd double precision(n).
|
||||
c rsd contains the least squares residual y - xk*b,
|
||||
c if its computation has been requested. rsd is
|
||||
c also the orthogonal projection of y onto the
|
||||
c orthogonal complement of the column space of xk.
|
||||
c
|
||||
c xb double precision(n).
|
||||
c xb contains the least squares approximation xk*b,
|
||||
c if its computation has been requested. xb is also
|
||||
c the orthogonal projection of y onto the column space
|
||||
c of x.
|
||||
c
|
||||
c info integer.
|
||||
c info is zero unless the computation of b has
|
||||
c been requested and r is exactly singular. in
|
||||
c this case, info is the index of the first zero
|
||||
c diagonal element of r and b is left unaltered.
|
||||
c
|
||||
c the parameters qy, qty, b, rsd, and xb are not referenced
|
||||
c if their computation is not requested and in this case
|
||||
c can be replaced by dummy variables in the calling program.
|
||||
c to save storage, the user may in some cases use the same
|
||||
c array for different parameters in the calling sequence. a
|
||||
c frequently occuring example is when one wishes to compute
|
||||
c any of b, rsd, or xb and does not need y or qty. in this
|
||||
c case one may identify y, qty, and one of b, rsd, or xb, while
|
||||
c providing separate arrays for anything else that is to be
|
||||
c computed. thus the calling sequence
|
||||
c
|
||||
c call dqrsl(x,ldx,n,k,qraux,y,dum,y,b,y,dum,110,info)
|
||||
c
|
||||
c will result in the computation of b and rsd, with rsd
|
||||
c overwriting y. more generally, each item in the following
|
||||
c list contains groups of permissible identifications for
|
||||
c a single callinng sequence.
|
||||
c
|
||||
c 1. (y,qty,b) (rsd) (xb) (qy)
|
||||
c
|
||||
c 2. (y,qty,rsd) (b) (xb) (qy)
|
||||
c
|
||||
c 3. (y,qty,xb) (b) (rsd) (qy)
|
||||
c
|
||||
c 4. (y,qy) (qty,b) (rsd) (xb)
|
||||
c
|
||||
c 5. (y,qy) (qty,rsd) (b) (xb)
|
||||
c
|
||||
c 6. (y,qy) (qty,xb) (b) (rsd)
|
||||
c
|
||||
c in any group the value returned in the array allocated to
|
||||
c the group corresponds to the last member of the group.
|
||||
c
|
||||
c linpack. this version dated 08/14/78 .
|
||||
c g.w. stewart, university of maryland, argonne national lab.
|
||||
c
|
||||
c dqrsl uses the following functions and subprograms.
|
||||
c
|
||||
c blas daxpy,dcopy,ddot
|
||||
c fortran dabs,min0,mod
|
||||
c
|
||||
c internal variables
|
||||
c
|
||||
integer i,j,jj,ju,kp1
|
||||
double precision ddot,t,temp
|
||||
logical cb,cqy,cqty,cr,cxb
|
||||
c
|
||||
c
|
||||
c set info flag.
|
||||
c
|
||||
info = 0
|
||||
c
|
||||
c determine what is to be computed.
|
||||
c
|
||||
cqy = job/10000 .ne. 0
|
||||
cqty = mod(job,10000) .ne. 0
|
||||
cb = mod(job,1000)/100 .ne. 0
|
||||
cr = mod(job,100)/10 .ne. 0
|
||||
cxb = mod(job,10) .ne. 0
|
||||
ju = min0(k,n-1)
|
||||
c
|
||||
c special action when n=1.
|
||||
c
|
||||
if (ju .ne. 0) go to 40
|
||||
if (cqy) qy(1) = y(1)
|
||||
if (cqty) qty(1) = y(1)
|
||||
if (cxb) xb(1) = y(1)
|
||||
if (.not.cb) go to 30
|
||||
if (x(1,1) .ne. 0.0d0) go to 10
|
||||
info = 1
|
||||
go to 20
|
||||
10 continue
|
||||
b(1) = y(1)/x(1,1)
|
||||
20 continue
|
||||
30 continue
|
||||
if (cr) rsd(1) = 0.0d0
|
||||
go to 250
|
||||
40 continue
|
||||
c
|
||||
c set up to compute qy or qty.
|
||||
c
|
||||
if (cqy) call dcopy(n,y,1,qy,1)
|
||||
if (cqty) call dcopy(n,y,1,qty,1)
|
||||
if (.not.cqy) go to 70
|
||||
c
|
||||
c compute qy.
|
||||
c
|
||||
do 60 jj = 1, ju
|
||||
j = ju - jj + 1
|
||||
if (qraux(j) .eq. 0.0d0) go to 50
|
||||
temp = x(j,j)
|
||||
x(j,j) = qraux(j)
|
||||
t = -ddot(n-j+1,x(j,j),1,qy(j),1)/x(j,j)
|
||||
call daxpy(n-j+1,t,x(j,j),1,qy(j),1)
|
||||
x(j,j) = temp
|
||||
50 continue
|
||||
60 continue
|
||||
70 continue
|
||||
if (.not.cqty) go to 100
|
||||
c
|
||||
c compute trans(q)*y.
|
||||
c
|
||||
do 90 j = 1, ju
|
||||
if (qraux(j) .eq. 0.0d0) go to 80
|
||||
temp = x(j,j)
|
||||
x(j,j) = qraux(j)
|
||||
t = -ddot(n-j+1,x(j,j),1,qty(j),1)/x(j,j)
|
||||
call daxpy(n-j+1,t,x(j,j),1,qty(j),1)
|
||||
x(j,j) = temp
|
||||
80 continue
|
||||
90 continue
|
||||
100 continue
|
||||
c
|
||||
c set up to compute b, rsd, or xb.
|
||||
c
|
||||
if (cb) call dcopy(k,qty,1,b,1)
|
||||
kp1 = k + 1
|
||||
if (cxb) call dcopy(k,qty,1,xb,1)
|
||||
if (cr .and. k .lt. n) call dcopy(n-k,qty(kp1),1,rsd(kp1),1)
|
||||
if (.not.cxb .or. kp1 .gt. n) go to 120
|
||||
do 110 i = kp1, n
|
||||
xb(i) = 0.0d0
|
||||
110 continue
|
||||
120 continue
|
||||
if (.not.cr) go to 140
|
||||
do 130 i = 1, k
|
||||
rsd(i) = 0.0d0
|
||||
130 continue
|
||||
140 continue
|
||||
if (.not.cb) go to 190
|
||||
c
|
||||
c compute b.
|
||||
c
|
||||
do 170 jj = 1, k
|
||||
j = k - jj + 1
|
||||
if (x(j,j) .ne. 0.0d0) go to 150
|
||||
info = j
|
||||
c ......exit
|
||||
go to 180
|
||||
150 continue
|
||||
b(j) = b(j)/x(j,j)
|
||||
if (j .eq. 1) go to 160
|
||||
t = -b(j)
|
||||
call daxpy(j-1,t,x(1,j),1,b,1)
|
||||
160 continue
|
||||
170 continue
|
||||
180 continue
|
||||
190 continue
|
||||
if (.not.cr .and. .not.cxb) go to 240
|
||||
c
|
||||
c compute rsd or xb as required.
|
||||
c
|
||||
do 230 jj = 1, ju
|
||||
j = ju - jj + 1
|
||||
if (qraux(j) .eq. 0.0d0) go to 220
|
||||
temp = x(j,j)
|
||||
x(j,j) = qraux(j)
|
||||
if (.not.cr) go to 200
|
||||
t = -ddot(n-j+1,x(j,j),1,rsd(j),1)/x(j,j)
|
||||
call daxpy(n-j+1,t,x(j,j),1,rsd(j),1)
|
||||
200 continue
|
||||
if (.not.cxb) go to 210
|
||||
t = -ddot(n-j+1,x(j,j),1,xb(j),1)/x(j,j)
|
||||
call daxpy(n-j+1,t,x(j,j),1,xb(j),1)
|
||||
210 continue
|
||||
x(j,j) = temp
|
||||
220 continue
|
||||
230 continue
|
||||
240 continue
|
||||
250 continue
|
||||
return
|
||||
end
|
||||
481
pmsco/loess/dsvdc.f
Normal file
481
pmsco/loess/dsvdc.f
Normal file
@ -0,0 +1,481 @@
|
||||
subroutine dsvdc(x,ldx,n,p,s,e,u,ldu,v,ldv,work,job,info)
|
||||
integer ldx,n,p,ldu,ldv,job,info
|
||||
double precision x(ldx,1),s(1),e(1),u(ldu,1),v(ldv,1),work(1)
|
||||
c
|
||||
c
|
||||
c dsvdc is a subroutine to reduce a double precision nxp matrix x
|
||||
c by orthogonal transformations u and v to diagonal form. the
|
||||
c diagonal elements s(i) are the singular values of x. the
|
||||
c columns of u are the corresponding left singular vectors,
|
||||
c and the columns of v the right singular vectors.
|
||||
c
|
||||
c on entry
|
||||
c
|
||||
c x double precision(ldx,p), where ldx.ge.n.
|
||||
c x contains the matrix whose singular value
|
||||
c decomposition is to be computed. x is
|
||||
c destroyed by dsvdc.
|
||||
c
|
||||
c ldx integer.
|
||||
c ldx is the leading dimension of the array x.
|
||||
c
|
||||
c n integer.
|
||||
c n is the number of rows of the matrix x.
|
||||
c
|
||||
c p integer.
|
||||
c p is the number of columns of the matrix x.
|
||||
c
|
||||
c ldu integer.
|
||||
c ldu is the leading dimension of the array u.
|
||||
c (see below).
|
||||
c
|
||||
c ldv integer.
|
||||
c ldv is the leading dimension of the array v.
|
||||
c (see below).
|
||||
c
|
||||
c work double precision(n).
|
||||
c work is a scratch array.
|
||||
c
|
||||
c job integer.
|
||||
c job controls the computation of the singular
|
||||
c vectors. it has the decimal expansion ab
|
||||
c with the following meaning
|
||||
c
|
||||
c a.eq.0 do not compute the left singular
|
||||
c vectors.
|
||||
c a.eq.1 return the n left singular vectors
|
||||
c in u.
|
||||
c a.ge.2 return the first min(n,p) singular
|
||||
c vectors in u.
|
||||
c b.eq.0 do not compute the right singular
|
||||
c vectors.
|
||||
c b.eq.1 return the right singular vectors
|
||||
c in v.
|
||||
c
|
||||
c on return
|
||||
c
|
||||
c s double precision(mm), where mm=min(n+1,p).
|
||||
c the first min(n,p) entries of s contain the
|
||||
c singular values of x arranged in descending
|
||||
c order of magnitude.
|
||||
c
|
||||
c e double precision(p),
|
||||
c e ordinarily contains zeros. however see the
|
||||
c discussion of info for exceptions.
|
||||
c
|
||||
c u double precision(ldu,k), where ldu.ge.n. if
|
||||
c joba.eq.1 then k.eq.n, if joba.ge.2
|
||||
c then k.eq.min(n,p).
|
||||
c u contains the matrix of left singular vectors.
|
||||
c u is not referenced if joba.eq.0. if n.le.p
|
||||
c or if joba.eq.2, then u may be identified with x
|
||||
c in the subroutine call.
|
||||
c
|
||||
c v double precision(ldv,p), where ldv.ge.p.
|
||||
c v contains the matrix of right singular vectors.
|
||||
c v is not referenced if job.eq.0. if p.le.n,
|
||||
c then v may be identified with x in the
|
||||
c subroutine call.
|
||||
c
|
||||
c info integer.
|
||||
c the singular values (and their corresponding
|
||||
c singular vectors) s(info+1),s(info+2),...,s(m)
|
||||
c are correct (here m=min(n,p)). thus if
|
||||
c info.eq.0, all the singular values and their
|
||||
c vectors are correct. in any event, the matrix
|
||||
c b = trans(u)*x*v is the bidiagonal matrix
|
||||
c with the elements of s on its diagonal and the
|
||||
c elements of e on its super-diagonal (trans(u)
|
||||
c is the transpose of u). thus the singular
|
||||
c values of x and b are the same.
|
||||
c
|
||||
c linpack. this version dated 08/14/78 .
|
||||
c correction made to shift 2/84.
|
||||
c g.w. stewart, university of maryland, argonne national lab.
|
||||
c
|
||||
c dsvdc uses the following functions and subprograms.
|
||||
c
|
||||
c external drot
|
||||
c blas daxpy,ddot,dscal,dswap,dnrm2,drotg
|
||||
c fortran dabs,dmax1,max0,min0,mod,dsqrt
|
||||
c
|
||||
c internal variables
|
||||
c
|
||||
integer i,iter,j,jobu,k,kase,kk,l,ll,lls,lm1,lp1,ls,lu,m,maxit,
|
||||
* mm,mm1,mp1,nct,nctp1,ncu,nrt,nrtp1
|
||||
double precision ddot,t,r
|
||||
double precision b,c,cs,el,emm1,f,g,dnrm2,scale,shift,sl,sm,sn,
|
||||
* smm1,t1,test,ztest
|
||||
logical wantu,wantv
|
||||
c
|
||||
c
|
||||
c set the maximum number of iterations.
|
||||
c
|
||||
maxit = 30
|
||||
c
|
||||
c determine what is to be computed.
|
||||
c
|
||||
wantu = .false.
|
||||
wantv = .false.
|
||||
jobu = mod(job,100)/10
|
||||
ncu = n
|
||||
if (jobu .gt. 1) ncu = min0(n,p)
|
||||
if (jobu .ne. 0) wantu = .true.
|
||||
if (mod(job,10) .ne. 0) wantv = .true.
|
||||
c
|
||||
c reduce x to bidiagonal form, storing the diagonal elements
|
||||
c in s and the super-diagonal elements in e.
|
||||
c
|
||||
info = 0
|
||||
nct = min0(n-1,p)
|
||||
nrt = max0(0,min0(p-2,n))
|
||||
lu = max0(nct,nrt)
|
||||
if (lu .lt. 1) go to 170
|
||||
do 160 l = 1, lu
|
||||
lp1 = l + 1
|
||||
if (l .gt. nct) go to 20
|
||||
c
|
||||
c compute the transformation for the l-th column and
|
||||
c place the l-th diagonal in s(l).
|
||||
c
|
||||
s(l) = dnrm2(n-l+1,x(l,l),1)
|
||||
if (s(l) .eq. 0.0d0) go to 10
|
||||
if (x(l,l) .ne. 0.0d0) s(l) = dsign(s(l),x(l,l))
|
||||
call dscal(n-l+1,1.0d0/s(l),x(l,l),1)
|
||||
x(l,l) = 1.0d0 + x(l,l)
|
||||
10 continue
|
||||
s(l) = -s(l)
|
||||
20 continue
|
||||
if (p .lt. lp1) go to 50
|
||||
do 40 j = lp1, p
|
||||
if (l .gt. nct) go to 30
|
||||
if (s(l) .eq. 0.0d0) go to 30
|
||||
c
|
||||
c apply the transformation.
|
||||
c
|
||||
t = -ddot(n-l+1,x(l,l),1,x(l,j),1)/x(l,l)
|
||||
call daxpy(n-l+1,t,x(l,l),1,x(l,j),1)
|
||||
30 continue
|
||||
c
|
||||
c place the l-th row of x into e for the
|
||||
c subsequent calculation of the row transformation.
|
||||
c
|
||||
e(j) = x(l,j)
|
||||
40 continue
|
||||
50 continue
|
||||
if (.not.wantu .or. l .gt. nct) go to 70
|
||||
c
|
||||
c place the transformation in u for subsequent back
|
||||
c multiplication.
|
||||
c
|
||||
do 60 i = l, n
|
||||
u(i,l) = x(i,l)
|
||||
60 continue
|
||||
70 continue
|
||||
if (l .gt. nrt) go to 150
|
||||
c
|
||||
c compute the l-th row transformation and place the
|
||||
c l-th super-diagonal in e(l).
|
||||
c
|
||||
e(l) = dnrm2(p-l,e(lp1),1)
|
||||
if (e(l) .eq. 0.0d0) go to 80
|
||||
if (e(lp1) .ne. 0.0d0) e(l) = dsign(e(l),e(lp1))
|
||||
call dscal(p-l,1.0d0/e(l),e(lp1),1)
|
||||
e(lp1) = 1.0d0 + e(lp1)
|
||||
80 continue
|
||||
e(l) = -e(l)
|
||||
if (lp1 .gt. n .or. e(l) .eq. 0.0d0) go to 120
|
||||
c
|
||||
c apply the transformation.
|
||||
c
|
||||
do 90 i = lp1, n
|
||||
work(i) = 0.0d0
|
||||
90 continue
|
||||
do 100 j = lp1, p
|
||||
call daxpy(n-l,e(j),x(lp1,j),1,work(lp1),1)
|
||||
100 continue
|
||||
do 110 j = lp1, p
|
||||
call daxpy(n-l,-e(j)/e(lp1),work(lp1),1,x(lp1,j),1)
|
||||
110 continue
|
||||
120 continue
|
||||
if (.not.wantv) go to 140
|
||||
c
|
||||
c place the transformation in v for subsequent
|
||||
c back multiplication.
|
||||
c
|
||||
do 130 i = lp1, p
|
||||
v(i,l) = e(i)
|
||||
130 continue
|
||||
140 continue
|
||||
150 continue
|
||||
160 continue
|
||||
170 continue
|
||||
c
|
||||
c set up the final bidiagonal matrix or order m.
|
||||
c
|
||||
m = min0(p,n+1)
|
||||
nctp1 = nct + 1
|
||||
nrtp1 = nrt + 1
|
||||
if (nct .lt. p) s(nctp1) = x(nctp1,nctp1)
|
||||
if (n .lt. m) s(m) = 0.0d0
|
||||
if (nrtp1 .lt. m) e(nrtp1) = x(nrtp1,m)
|
||||
e(m) = 0.0d0
|
||||
c
|
||||
c if required, generate u.
|
||||
c
|
||||
if (.not.wantu) go to 300
|
||||
if (ncu .lt. nctp1) go to 200
|
||||
do 190 j = nctp1, ncu
|
||||
do 180 i = 1, n
|
||||
u(i,j) = 0.0d0
|
||||
180 continue
|
||||
u(j,j) = 1.0d0
|
||||
190 continue
|
||||
200 continue
|
||||
if (nct .lt. 1) go to 290
|
||||
do 280 ll = 1, nct
|
||||
l = nct - ll + 1
|
||||
if (s(l) .eq. 0.0d0) go to 250
|
||||
lp1 = l + 1
|
||||
if (ncu .lt. lp1) go to 220
|
||||
do 210 j = lp1, ncu
|
||||
t = -ddot(n-l+1,u(l,l),1,u(l,j),1)/u(l,l)
|
||||
call daxpy(n-l+1,t,u(l,l),1,u(l,j),1)
|
||||
210 continue
|
||||
220 continue
|
||||
call dscal(n-l+1,-1.0d0,u(l,l),1)
|
||||
u(l,l) = 1.0d0 + u(l,l)
|
||||
lm1 = l - 1
|
||||
if (lm1 .lt. 1) go to 240
|
||||
do 230 i = 1, lm1
|
||||
u(i,l) = 0.0d0
|
||||
230 continue
|
||||
240 continue
|
||||
go to 270
|
||||
250 continue
|
||||
do 260 i = 1, n
|
||||
u(i,l) = 0.0d0
|
||||
260 continue
|
||||
u(l,l) = 1.0d0
|
||||
270 continue
|
||||
280 continue
|
||||
290 continue
|
||||
300 continue
|
||||
c
|
||||
c if it is required, generate v.
|
||||
c
|
||||
if (.not.wantv) go to 350
|
||||
do 340 ll = 1, p
|
||||
l = p - ll + 1
|
||||
lp1 = l + 1
|
||||
if (l .gt. nrt) go to 320
|
||||
if (e(l) .eq. 0.0d0) go to 320
|
||||
do 310 j = lp1, p
|
||||
t = -ddot(p-l,v(lp1,l),1,v(lp1,j),1)/v(lp1,l)
|
||||
call daxpy(p-l,t,v(lp1,l),1,v(lp1,j),1)
|
||||
310 continue
|
||||
320 continue
|
||||
do 330 i = 1, p
|
||||
v(i,l) = 0.0d0
|
||||
330 continue
|
||||
v(l,l) = 1.0d0
|
||||
340 continue
|
||||
350 continue
|
||||
c
|
||||
c main iteration loop for the singular values.
|
||||
c
|
||||
mm = m
|
||||
iter = 0
|
||||
360 continue
|
||||
c
|
||||
c quit if all the singular values have been found.
|
||||
c
|
||||
c ...exit
|
||||
if (m .eq. 0) go to 620
|
||||
c
|
||||
c if too many iterations have been performed, set
|
||||
c flag and return.
|
||||
c
|
||||
if (iter .lt. maxit) go to 370
|
||||
info = m
|
||||
c ......exit
|
||||
go to 620
|
||||
370 continue
|
||||
c
|
||||
c this section of the program inspects for
|
||||
c negligible elements in the s and e arrays. on
|
||||
c completion the variables kase and l are set as follows.
|
||||
c
|
||||
c kase = 1 if s(m) and e(l-1) are negligible and l.lt.m
|
||||
c kase = 2 if s(l) is negligible and l.lt.m
|
||||
c kase = 3 if e(l-1) is negligible, l.lt.m, and
|
||||
c s(l), ..., s(m) are not negligible (qr step).
|
||||
c kase = 4 if e(m-1) is negligible (convergence).
|
||||
c
|
||||
do 390 ll = 1, m
|
||||
l = m - ll
|
||||
c ...exit
|
||||
if (l .eq. 0) go to 400
|
||||
test = dabs(s(l)) + dabs(s(l+1))
|
||||
ztest = test + dabs(e(l))
|
||||
if (ztest .ne. test) go to 380
|
||||
e(l) = 0.0d0
|
||||
c ......exit
|
||||
go to 400
|
||||
380 continue
|
||||
390 continue
|
||||
400 continue
|
||||
if (l .ne. m - 1) go to 410
|
||||
kase = 4
|
||||
go to 480
|
||||
410 continue
|
||||
lp1 = l + 1
|
||||
mp1 = m + 1
|
||||
do 430 lls = lp1, mp1
|
||||
ls = m - lls + lp1
|
||||
c ...exit
|
||||
if (ls .eq. l) go to 440
|
||||
test = 0.0d0
|
||||
if (ls .ne. m) test = test + dabs(e(ls))
|
||||
if (ls .ne. l + 1) test = test + dabs(e(ls-1))
|
||||
ztest = test + dabs(s(ls))
|
||||
if (ztest .ne. test) go to 420
|
||||
s(ls) = 0.0d0
|
||||
c ......exit
|
||||
go to 440
|
||||
420 continue
|
||||
430 continue
|
||||
440 continue
|
||||
if (ls .ne. l) go to 450
|
||||
kase = 3
|
||||
go to 470
|
||||
450 continue
|
||||
if (ls .ne. m) go to 460
|
||||
kase = 1
|
||||
go to 470
|
||||
460 continue
|
||||
kase = 2
|
||||
l = ls
|
||||
470 continue
|
||||
480 continue
|
||||
l = l + 1
|
||||
c
|
||||
c perform the task indicated by kase.
|
||||
c
|
||||
go to (490,520,540,570), kase
|
||||
c
|
||||
c deflate negligible s(m).
|
||||
c
|
||||
490 continue
|
||||
mm1 = m - 1
|
||||
f = e(m-1)
|
||||
e(m-1) = 0.0d0
|
||||
do 510 kk = l, mm1
|
||||
k = mm1 - kk + l
|
||||
t1 = s(k)
|
||||
call drotg(t1,f,cs,sn)
|
||||
s(k) = t1
|
||||
if (k .eq. l) go to 500
|
||||
f = -sn*e(k-1)
|
||||
e(k-1) = cs*e(k-1)
|
||||
500 continue
|
||||
if (wantv) call drot(p,v(1,k),1,v(1,m),1,cs,sn)
|
||||
510 continue
|
||||
go to 610
|
||||
c
|
||||
c split at negligible s(l).
|
||||
c
|
||||
520 continue
|
||||
f = e(l-1)
|
||||
e(l-1) = 0.0d0
|
||||
do 530 k = l, m
|
||||
t1 = s(k)
|
||||
call drotg(t1,f,cs,sn)
|
||||
s(k) = t1
|
||||
f = -sn*e(k)
|
||||
e(k) = cs*e(k)
|
||||
if (wantu) call drot(n,u(1,k),1,u(1,l-1),1,cs,sn)
|
||||
530 continue
|
||||
go to 610
|
||||
c
|
||||
c perform one qr step.
|
||||
c
|
||||
540 continue
|
||||
c
|
||||
c calculate the shift.
|
||||
c
|
||||
scale = dmax1(dabs(s(m)),dabs(s(m-1)),dabs(e(m-1)),
|
||||
* dabs(s(l)),dabs(e(l)))
|
||||
sm = s(m)/scale
|
||||
smm1 = s(m-1)/scale
|
||||
emm1 = e(m-1)/scale
|
||||
sl = s(l)/scale
|
||||
el = e(l)/scale
|
||||
b = ((smm1 + sm)*(smm1 - sm) + emm1**2)/2.0d0
|
||||
c = (sm*emm1)**2
|
||||
shift = 0.0d0
|
||||
if (b .eq. 0.0d0 .and. c .eq. 0.0d0) go to 550
|
||||
shift = dsqrt(b**2+c)
|
||||
if (b .lt. 0.0d0) shift = -shift
|
||||
shift = c/(b + shift)
|
||||
550 continue
|
||||
f = (sl + sm)*(sl - sm) + shift
|
||||
g = sl*el
|
||||
c
|
||||
c chase zeros.
|
||||
c
|
||||
mm1 = m - 1
|
||||
do 560 k = l, mm1
|
||||
call drotg(f,g,cs,sn)
|
||||
if (k .ne. l) e(k-1) = f
|
||||
f = cs*s(k) + sn*e(k)
|
||||
e(k) = cs*e(k) - sn*s(k)
|
||||
g = sn*s(k+1)
|
||||
s(k+1) = cs*s(k+1)
|
||||
if (wantv) call drot(p,v(1,k),1,v(1,k+1),1,cs,sn)
|
||||
call drotg(f,g,cs,sn)
|
||||
s(k) = f
|
||||
f = cs*e(k) + sn*s(k+1)
|
||||
s(k+1) = -sn*e(k) + cs*s(k+1)
|
||||
g = sn*e(k+1)
|
||||
e(k+1) = cs*e(k+1)
|
||||
if (wantu .and. k .lt. n)
|
||||
* call drot(n,u(1,k),1,u(1,k+1),1,cs,sn)
|
||||
560 continue
|
||||
e(m-1) = f
|
||||
iter = iter + 1
|
||||
go to 610
|
||||
c
|
||||
c convergence.
|
||||
c
|
||||
570 continue
|
||||
c
|
||||
c make the singular value positive.
|
||||
c
|
||||
if (s(l) .ge. 0.0d0) go to 580
|
||||
s(l) = -s(l)
|
||||
if (wantv) call dscal(p,-1.0d0,v(1,l),1)
|
||||
580 continue
|
||||
c
|
||||
c order the singular value.
|
||||
c
|
||||
590 if (l .eq. mm) go to 600
|
||||
c ...exit
|
||||
if (s(l) .ge. s(l+1)) go to 600
|
||||
t = s(l)
|
||||
s(l) = s(l+1)
|
||||
s(l+1) = t
|
||||
if (wantv .and. l .lt. p)
|
||||
* call dswap(p,v(1,l),1,v(1,l+1),1)
|
||||
if (wantu .and. l .lt. n)
|
||||
* call dswap(n,u(1,l),1,u(1,l+1),1)
|
||||
l = l + 1
|
||||
go to 590
|
||||
600 continue
|
||||
iter = 0
|
||||
m = m - 1
|
||||
610 continue
|
||||
go to 360
|
||||
620 continue
|
||||
return
|
||||
end
|
||||
93
pmsco/loess/ethanol.c
Normal file
93
pmsco/loess/ethanol.c
Normal file
@ -0,0 +1,93 @@
|
||||
#include <stdio.h>
|
||||
#include "loess.h"
|
||||
|
||||
struct loess_struct ethanol, ethanol_cp;
|
||||
struct pred_struct ethanol_pred, ethanol_grid;
|
||||
struct ci_struct ethanol_ci;
|
||||
double NOx[] = {3.741, 2.295, 1.498, 2.881, 0.76, 3.12, 0.638, 1.17, 2.358,
|
||||
0.606, 3.669, 1, 0.981, 1.192, 0.926, 1.59, 1.806, 1.962,
|
||||
4.028, 3.148, 1.836, 2.845, 1.013, 0.414, 0.812, 0.374, 3.623,
|
||||
1.869, 2.836, 3.567, 0.866, 1.369, 0.542, 2.739, 1.2, 1.719,
|
||||
3.423, 1.634, 1.021, 2.157, 3.361, 1.39, 1.947, 0.962, 0.571,
|
||||
2.219, 1.419, 3.519, 1.732, 3.206, 2.471, 1.777, 2.571, 3.952,
|
||||
3.931, 1.587, 1.397, 3.536, 2.202, 0.756, 1.62, 3.656, 2.964,
|
||||
3.76, 0.672, 3.677, 3.517, 3.29, 1.139, 0.727, 2.581, 0.923,
|
||||
1.527, 3.388, 2.085, 0.966, 3.488, 0.754, 0.797, 2.064, 3.732,
|
||||
0.586, 0.561, 0.563, 0.678, 0.37, 0.53, 1.9};
|
||||
double C_E[] = {12, 12, 12, 12, 12, 9, 9, 9, 12, 12, 12, 12, 15, 18, 7.5, 12,
|
||||
12, 15, 15, 9, 9, 7.5, 7.5, 18, 18, 15, 15, 7.5, 7.5, 9, 15, 15,
|
||||
15, 15, 15, 9, 9, 7.5, 7.5, 7.5, 18, 18, 18, 18, 9, 9, 9, 9,
|
||||
7.5, 7.5, 7.5, 15, 18, 18, 15, 15, 7.5, 7.5, 7.5, 7.5, 7.5, 7.5,
|
||||
7.5, 18, 18, 18, 12, 12, 9, 9, 9, 15, 15, 15, 15, 15, 7.5, 7.5,
|
||||
9, 7.5, 18, 18, 7.5, 9, 12, 15, 18, 18,
|
||||
0.907, 0.761, 1.108, 1.016, 1.189, 1.001, 1.231, 1.123, 1.042,
|
||||
1.215, 0.93, 1.152, 1.138, 0.601, 0.696, 0.686, 1.072, 1.074,
|
||||
0.934, 0.808, 1.071, 1.009, 1.142, 1.229, 1.175, 0.568, 0.977,
|
||||
0.767, 1.006, 0.893, 1.152, 0.693, 1.232, 1.036, 1.125, 1.081,
|
||||
0.868, 0.762, 1.144, 1.045, 0.797, 1.115, 1.07, 1.219, 0.637,
|
||||
0.733, 0.715, 0.872, 0.765, 0.878, 0.811, 0.676, 1.045, 0.968,
|
||||
0.846, 0.684, 0.729, 0.911, 0.808, 1.168, 0.749, 0.892, 1.002,
|
||||
0.812, 1.23, 0.804, 0.813, 1.002, 0.696, 1.199, 1.03, 0.602,
|
||||
0.694, 0.816, 1.037, 1.181, 0.899, 1.227, 1.18, 0.795, 0.99,
|
||||
1.201, 0.629, 0.608, 0.584, 0.562, 0.535, 0.655};
|
||||
double newdata[] = {7.5, 9.0, 12.0, 15.0, 18.0, 0.6, 0.8, 1.0, 0.8, 0.6};
|
||||
double Cmin = 7.5, Cmax = 18.0, Emin = 0.535, Emax = 1.232;
|
||||
double Cm[7], Em[16], grid[224];
|
||||
double tmp, coverage = .99;
|
||||
int n = 88, p = 2, m = 5, se_fit = FALSE;
|
||||
int i, j, k;
|
||||
|
||||
main() {
|
||||
printf("\nloess(ðanol): (span = 0.5)\n");
|
||||
loess_setup(C_E, NOx, n, p, ðanol);
|
||||
ethanol.model.span = 0.5;
|
||||
loess(ðanol);
|
||||
loess_summary(ðanol);
|
||||
|
||||
printf("\nloess(ðanol): (span = 0.25)\n");
|
||||
ethanol.model.span = 0.25;
|
||||
loess(ðanol);
|
||||
loess_summary(ðanol);
|
||||
|
||||
printf("\nloess(ðanol_cp): (span = 0.25)\n");
|
||||
loess_setup(C_E, NOx, n, p, ðanol_cp);
|
||||
ethanol_cp.model.span = 0.25;
|
||||
ethanol_cp.model.parametric[0] = TRUE;
|
||||
ethanol_cp.model.drop_square[0] = TRUE;
|
||||
loess(ðanol_cp);
|
||||
loess_summary(ðanol_cp);
|
||||
|
||||
printf("\nloess(ðanol_cp): (span = 0.5)\n");
|
||||
ethanol_cp.model.span = 0.5;
|
||||
loess(ðanol_cp);
|
||||
loess_summary(ðanol_cp);
|
||||
|
||||
printf("\npredict(newdata, m, ðanol, ðanol_pred, %d):\n", se_fit);
|
||||
predict(newdata, m, ðanol_cp, ðanol_pred, se_fit);
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", ethanol_pred.fit[i]);
|
||||
printf("\n");
|
||||
|
||||
m = 112;
|
||||
se_fit = TRUE;
|
||||
tmp = (Cmax - Cmin) / 6;
|
||||
for(i = 0; i < 7; i++)
|
||||
Cm[i] = Cmin + tmp * i;
|
||||
tmp = (Emax - Emin) / 15;
|
||||
for(i = 0; i < 16; i++)
|
||||
Em[i] = Emin + tmp * i;
|
||||
for(i = 0; i < 16; i++) {
|
||||
k = i * 7;
|
||||
for(j = 0; j < 7; j++) {
|
||||
grid[k + j] = Cm[j];
|
||||
grid[m + k + j] = Em[i];
|
||||
}
|
||||
}
|
||||
predict(grid, m, ðanol_cp, ðanol_grid, se_fit);
|
||||
pointwise(ðanol_grid, m, coverage, ðanol_ci);
|
||||
|
||||
loess_free_mem(ðanol);
|
||||
loess_free_mem(ðanol_cp);
|
||||
pred_free_mem(ðanol_pred);
|
||||
pred_free_mem(ðanol_grid);
|
||||
}
|
||||
7
pmsco/loess/fix_main.c
Normal file
7
pmsco/loess/fix_main.c
Normal file
@ -0,0 +1,7 @@
|
||||
// workaround for linker error
|
||||
// "libf2c.so.0: undefined symbol: MAIN__ "
|
||||
//
|
||||
int MAIN__()
|
||||
{ return(0);
|
||||
}
|
||||
|
||||
204
pmsco/loess/galaxy.c
Normal file
204
pmsco/loess/galaxy.c
Normal file
@ -0,0 +1,204 @@
|
||||
#include <stdio.h>
|
||||
#include "loess.h"
|
||||
|
||||
struct loess_struct galaxy;
|
||||
struct pred_struct galaxy_contour, spine_fit, spine_se;
|
||||
struct ci_struct spine_ci;
|
||||
double velocity[] = {1769, 1749, 1749, 1758, 1750, 1745, 1750, 1753, 1734,
|
||||
1710, 1711, 1709, 1674, 1665, 1680, 1648, 1626, 1581, 1602,
|
||||
1558, 1538, 1506, 1521, 1498, 1501, 1491, 1481, 1468, 1455,
|
||||
1454, 1456, 1459, 1451, 1465, 1451, 1486, 1433, 1631, 1618,
|
||||
1607, 1608, 1601, 1603, 1612, 1607, 1618, 1649, 1595, 1580,
|
||||
1574, 1574, 1559, 1578, 1591, 1579, 1588, 1581, 1569, 1572,
|
||||
1584, 1565, 1718, 1711, 1710, 1715, 1713, 1717, 1715, 1712,
|
||||
1710, 1692, 1669, 1679, 1691, 1647, 1630, 1616, 1576, 1561,
|
||||
1558, 1538, 1525, 1509, 1501, 1494, 1489, 1493, 1487, 1495,
|
||||
1511, 1505, 1508, 1507, 1513, 1493, 1495, 1736, 1744, 1765,
|
||||
1766, 1764, 1715, 1751, 1761, 1763, 1758, 1743, 1738, 1732,
|
||||
1734, 1723, 1706, 1665, 1677, 1679, 1601, 1629, 1621, 1574,
|
||||
1559, 1540, 1525, 1517, 1506, 1481, 1465, 1468, 1465, 1454,
|
||||
1448, 1441, 1441, 1430, 1434, 1445, 1464, 1471, 1442, 1436,
|
||||
1434, 1428, 1558, 1563, 1581, 1548, 1572, 1574, 1578, 1576,
|
||||
1583, 1584, 1566, 1568, 1577, 1587, 1606, 1593, 1584, 1595,
|
||||
1617, 1552, 1597, 1615, 1626, 1626, 1586, 1624, 1600, 1585,
|
||||
1738, 1690, 1729, 1719, 1702, 1754, 1741, 1736, 1731, 1725,
|
||||
1710, 1673, 1669, 1641, 1675, 1681, 1645, 1594, 1583, 1599,
|
||||
1578, 1548, 1543, 1537, 1543, 1519, 1500, 1488, 1486, 1483,
|
||||
1481, 1485, 1480, 1479, 1505, 1482, 1481, 1489, 1531, 1533,
|
||||
1539, 1526, 1551, 1549, 1532, 1538, 1550, 1536, 1519, 1536,
|
||||
1535, 1536, 1533, 1528, 1539, 1546, 1552, 1557, 1573, 1553,
|
||||
1576, 1591, 1591, 1624, 1633, 1597, 1605, 1629, 1658, 1664,
|
||||
1667, 1671, 1687, 1682, 1668, 1673, 1684, 1668, 1618, 1658,
|
||||
1644, 1647, 1642, 1616, 1629, 1610, 1603, 1613, 1603, 1606,
|
||||
1603, 1608, 1613, 1616, 1615, 1611, 1580, 1580, 1586, 1591,
|
||||
1592, 1562, 1572, 1589, 1588, 1585, 1586, 1573, 1573, 1558,
|
||||
1566, 1740, 1704, 1748, 1757, 1775, 1765, 1762, 1752, 1752,
|
||||
1753, 1753, 1748, 1730, 1709, 1688, 1687, 1678, 1654, 1634,
|
||||
1611, 1590, 1562, 1565, 1541, 1537, 1515, 1498, 1479, 1481,
|
||||
1475, 1466, 1461, 1457, 1455, 1452, 1453, 1448, 1469, 1456,
|
||||
1448, 1409, 1416, 1429};
|
||||
double direction[] = {8.46279, 7.96498, 7.46717, 6.96936, 6.47154, 5.97373,
|
||||
5.47592, 4.97811, 4.4803, 3.98249, 3.46303, 2.96522,
|
||||
2.46741, 1.9696, 1.47179, 0.973978, 0.476167, -0.021644,
|
||||
-0.519455, -1.01727, -1.51508, -2.01289, -2.5107,
|
||||
-3.00851, -3.52797, -4.02578, -4.52359, -5.0214,
|
||||
-5.51921, -6.01702, -6.51483, -7.01264, -7.51045,
|
||||
-8.00827, -8.50608, -9.5017, -11.0168, 27.8244, 21.088,
|
||||
18.8425, 16.597, 14.3516, 12.1061, 9.86059, 7.61511,
|
||||
5.272, 3.02652, 0.781037, -1.46444, -3.70992, -5.95541,
|
||||
-8.20089, -10.4464, -12.6918, -14.9373, -17.1828,
|
||||
-19.4283, -21.6738, -23.9193, -26.2624, -28.5078,
|
||||
23.8699, 22.3013, 20.7327, 19.1642, 17.5956, 16.027,
|
||||
14.3902, 12.8216, 11.253, 9.68438, 8.11578, 6.54718,
|
||||
4.97859, 3.40999, 1.8414, 0.272799, -1.2958, -2.86439,
|
||||
-4.43299, -6.00159, -7.63838, -9.20698, -10.7756,
|
||||
-12.3442, -13.9128, -15.4814, -17.05, -18.6186,
|
||||
-20.1872, -21.7557, -23.3243, -24.8929, -26.4615,
|
||||
-28.0301, -29.6669, 18.4201, 17.5959, 16.7716, 15.9474,
|
||||
14.263, 13.4388, 12.6146, 11.7903, 10.9661, 10.1418,
|
||||
9.31757, 8.49332, 7.66907, 6.84483, 6.02058, 5.19634,
|
||||
4.37209, 3.54784, 2.68776, 1.86351, 1.03927, 0.215021,
|
||||
-0.609226, -1.43347, -2.25772, -3.08196, -3.90621,
|
||||
-4.73046, -5.5547, -6.37895, -7.2032, -8.02744,
|
||||
-8.88752, -9.71177, -10.536, -11.3603, -12.1845,
|
||||
-13.0088, -13.833, -14.6572, -15.4815, -16.3057,
|
||||
-17.13, -17.9542, -18.7785, 25.8899, 24.2078, 22.4526,
|
||||
20.8436, 19.1615, 17.4794, 15.7972, 14.1151, 12.433,
|
||||
10.7509, 9.06879, 7.31354, 5.70456, 3.94931, 2.19406,
|
||||
0.511948, -1.09703, -2.77914, -4.46126, -6.07024,
|
||||
-7.82548, -9.5076, -11.1897, -12.8718, -14.5539,
|
||||
-16.2361, -23.1108, -24.7198, 1.97596, 1.77531, 1.67498,
|
||||
1.57466, 1.47434, 1.37401, 1.27369, 1.17336, 1.07304,
|
||||
0.972712, 0.872388, 0.767701, 0.667377, 0.567052,
|
||||
0.466727, 0.366403, 0.266078, 0.165754, 0.0654291,
|
||||
-0.0348955, -0.13522, -0.235545, -0.335869, -0.436194,
|
||||
-0.536518, -0.636843, -0.74153, -0.841854, -0.942179,
|
||||
-1.0425, -1.14283, -1.24315, -1.34348, -1.4438,
|
||||
-1.54413, -1.64445, -1.74478, -1.8451, 24.8532, 23.827,
|
||||
22.8007, 21.7298, 20.7036, 19.6773, 18.6511, 16.5539,
|
||||
15.5723, 14.546, 13.4752, 12.4489, 11.4227, 10.3964,
|
||||
9.37015, 8.3439, 7.31764, 6.29139, 5.26513, 4.23888,
|
||||
3.21262, 2.18637, 1.16011, 0.133859, -0.937015,
|
||||
-1.96327, -2.98953, -4.01578, -5.04204, -6.06829,
|
||||
-7.04993, -8.07618, -9.14706, -10.1733, -11.1996,
|
||||
-12.2258, -13.2521, -14.2783, -15.3046, -16.3308,
|
||||
-17.3571, -18.3834, -19.4096, -20.4359, -21.4621,
|
||||
-22.4884, 29.4841, 27.0434, 25.0908, 22.6501, 20.4046,
|
||||
18.1591, 15.9136, 13.7658, 11.4227, 9.17718, 6.9317,
|
||||
4.58859, 2.44074, 0.0976296, -2.05022, -4.19807,
|
||||
-6.63881, -8.88429, -11.1298, -13.2776, -15.5231,
|
||||
-17.8662, -20.1117, -22.3572, -24.6027, -26.8481,
|
||||
-29.0936, 10.8869, 9.39348, 8.91731, 8.39786, 7.92169,
|
||||
7.42388, 6.92607, 6.42826, 5.9088, 5.41099, 4.91318,
|
||||
4.41537, 3.91756, 3.44139, 2.92193, 2.42412, 1.92631,
|
||||
1.4285, 0.93069, 0.432879, -0.0649319, -0.562743,
|
||||
-1.06055, -1.55837, -2.07782, -2.55399, -3.07344,
|
||||
-3.57125, -4.06906, -4.56688, -5.06469, -5.5625,
|
||||
-6.06031, -6.55812, -7.05593, -7.57539, -8.0732,
|
||||
-8.54937, -9.09046, -9.58827, -10.0428, -10.5406,
|
||||
-11.0601,
|
||||
-38.1732, -35.9277, -33.6822, -31.4367, -29.1912,
|
||||
-26.9458, -24.7003, -22.4548, -20.2093, -17.9638, -15.6207,
|
||||
-13.3753, -11.1298, -8.88429, -6.63881, -4.39333, -2.14785,
|
||||
0.0976296, 2.34311, 4.58859, 6.83407, 9.07955, 11.325,
|
||||
13.5705, 15.9136, 18.1591, 20.4046, 22.6501, 24.8955,
|
||||
27.141, 29.3865, 31.632, 33.8775, 36.123, 38.3684, 42.8594,
|
||||
49.6935, 6.16853, 4.6751, 4.17728, 3.67947, 3.18166, 2.68385,
|
||||
2.18604, 1.68823, 1.16877, 0.670963, 0.173152, -0.324659,
|
||||
-0.822471, -1.32028, -1.81809, -2.3159, -2.81371, -3.31153,
|
||||
-3.80934, -4.30715, -4.80496, -5.30277, -5.82223, -6.32004,
|
||||
-25.5974, -23.9153, -22.2332, -20.551, -18.8689, -17.1868,
|
||||
-15.4316, -13.7494, -12.0673, -10.3852, -8.70311, -7.021,
|
||||
-5.33888, -3.65677, -1.97466, -0.292541, 1.38957, 3.07169,
|
||||
4.7538, 6.43591, 8.19116, 9.87327, 11.5554, 13.2375, 14.9196,
|
||||
16.6017, 18.2838, 19.966, 21.6481, 23.3302, 25.0123, 26.6944,
|
||||
28.3765, 30.0586, 31.8139, -47.986, -45.8388, -43.6916,
|
||||
-41.5443, -37.1565, -35.0093, -32.862, -30.7148, -28.5676,
|
||||
-26.4203, -24.2731, -22.1259, -19.9786, -17.8314, -15.6842,
|
||||
-13.5369, -11.3897, -9.24245, -7.00185, -4.85462, -2.70738,
|
||||
-0.560148, 1.58709, 3.73432, 5.88156, 8.02879, 10.176,
|
||||
12.3233, 14.4705, 16.6177, 18.765, 20.9122, 23.1528, 25.3,
|
||||
27.4473, 29.5945, 31.7417, 33.889, 36.0362, 38.1834, 40.3307,
|
||||
42.4779, 44.6251, 46.7724, 48.9196, 24.1427, 22.5741, 20.9373,
|
||||
19.437, 17.8684, 16.2998, 14.7312, 13.1626, 11.594, 10.0254,
|
||||
8.45678, 6.81998, 5.31959, 3.68279, 2.04599, 0.477399, -1.023,
|
||||
-2.59159, -4.16019, -5.66059, -7.29738, -8.86598, -10.4346,
|
||||
-12.0032, -13.5718, -15.1404, -21.5511, -23.0515, -45.2569,
|
||||
-40.6613, -38.3635, -36.0656, -33.7678, -31.47, -29.1722,
|
||||
-26.8744, -24.5766, -22.2788, -19.981, -17.5832, -15.2854,
|
||||
-12.9876, -10.6898, -8.392, -6.09419, -3.79638, -1.49857,
|
||||
0.799239, 3.09705, 5.39486, 7.69267, 9.99048, 12.2883,
|
||||
14.5861, 16.9838, 19.2816, 21.5794, 23.8773, 26.1751, 28.4729,
|
||||
30.7707, 33.0685, 35.3663, 37.6641, 39.9619, 42.2597, 49.8478,
|
||||
47.7895, 45.7311, 43.5833, 41.525, 39.4666, 37.4083, 33.2021,
|
||||
31.2332, 29.1749, 27.027, 24.9687, 22.9103, 20.852, 18.7936,
|
||||
16.7353, 14.6769, 12.6186, 10.5602, 8.50188, 6.44353, 4.38518,
|
||||
2.32683, 0.26848, -1.87936, -3.93771, -5.99606, -8.05441,
|
||||
-10.1128, -12.1711, -14.14, -16.1983, -18.3462, -20.4045,
|
||||
-22.4629, -24.5212, -26.5796, -28.6379, -30.6962, -32.7546,
|
||||
-34.8129, -36.8713, -38.9296, -40.988, -43.0463, -45.1047,
|
||||
6.53648, 5.99538, 5.5625, 5.0214, 4.52359, 4.02578, 3.52797,
|
||||
3.0518, 2.53234, 2.03453, 1.53672, 1.01727, 0.541099,
|
||||
0.021644, -0.454523, -0.93069, -1.47179, -1.9696, -2.46741,
|
||||
-2.94358, -3.44139, -3.96084, -4.45866, -4.95647, -5.45428,
|
||||
-5.95209, -6.4499, -49.1077, -42.3712, -40.2234, -37.8803,
|
||||
-35.7324, -33.487, -31.2415, -28.996, -26.6529, -24.4074,
|
||||
-22.1619, -19.9164, -17.671, -15.5231, -13.18, -10.9345,
|
||||
-8.68903, -6.44355, -4.19807, -1.95259, 0.292889, 2.53837,
|
||||
4.78385, 7.02933, 9.37244, 11.5203, 13.8634, 16.1089, 18.3544,
|
||||
20.5998, 22.8453, 25.0908, 27.3363, 29.5818, 31.8272, 34.1704,
|
||||
36.4158, 38.5637, 41.0044, 43.2499, 45.3001, 47.5456,
|
||||
49.8887};
|
||||
double ew[59], ns[99], grid[11682], fit_eval[200], ci_eval[30];
|
||||
double tmp, range = 98, coverage = .99;
|
||||
int n = 323, p = 2, m, se_fit = FALSE;
|
||||
int i, j, k;
|
||||
|
||||
main() {
|
||||
printf("\nloess(&galaxy):\n");
|
||||
loess_setup(direction, velocity, n, p, &galaxy);
|
||||
galaxy.model.span = 0.35;
|
||||
galaxy.model.normalize = FALSE;
|
||||
galaxy.model.family = "symmetric";
|
||||
loess(&galaxy);
|
||||
loess_summary(&galaxy);
|
||||
|
||||
m = 5841;
|
||||
tmp = -29.0;
|
||||
for(i = 0; i < 59; i++)
|
||||
ew[i] = tmp++;
|
||||
tmp = -49.0;
|
||||
for(i = 0; i < 99; i++)
|
||||
ns[i] = tmp++;
|
||||
for(i = 0; i < 99; i++) {
|
||||
k = i * 59;
|
||||
for(j = 0; j < 59; j++) {
|
||||
grid[k + j] = ew[j];
|
||||
grid[m + k + j] = ns[i];
|
||||
}
|
||||
}
|
||||
predict(grid, m, &galaxy, &galaxy_contour, se_fit);
|
||||
|
||||
m = 100;
|
||||
tmp = range / 99;
|
||||
for(i = 0; i < 100; i++) {
|
||||
fit_eval[i + 100] = -49 + tmp * i;
|
||||
fit_eval[i] = fit_eval[i + 100] / (-3.7);
|
||||
}
|
||||
predict(fit_eval, m, &galaxy, &spine_fit, se_fit);
|
||||
|
||||
m = 15;
|
||||
se_fit = TRUE;
|
||||
tmp = range / 14;
|
||||
for(i = 0; i < m; i++) {
|
||||
ci_eval[i + m] = -49 + tmp * i;
|
||||
ci_eval[i] = fit_eval[i + 100] / (-3.7);
|
||||
}
|
||||
predict(ci_eval, m, &galaxy, &spine_se, se_fit);
|
||||
pointwise(&spine_se, m, coverage, &spine_ci);
|
||||
|
||||
loess_free_mem(&galaxy);
|
||||
pred_free_mem(&galaxy_contour);
|
||||
pred_free_mem(&spine_fit);
|
||||
pred_free_mem(&spine_se);
|
||||
}
|
||||
69
pmsco/loess/gas.c
Normal file
69
pmsco/loess/gas.c
Normal file
@ -0,0 +1,69 @@
|
||||
/* sample program for the gas data using loess */
|
||||
|
||||
#include <stdio.h>
|
||||
#include "loess.h"
|
||||
|
||||
struct loess_struct gas, gas_null;
|
||||
struct pred_struct gas_pred;
|
||||
struct ci_struct gas_ci;
|
||||
struct anova_struct gas_anova;
|
||||
double NOx[] = {4.818, 2.849, 3.275, 4.691, 4.255, 5.064, 2.118, 4.602,
|
||||
2.286, 0.97, 3.965, 5.344, 3.834, 1.99, 5.199, 5.283,
|
||||
3.752, 0.537, 1.64, 5.055, 4.937, 1.561};
|
||||
double E[] = {0.831, 1.045, 1.021, 0.97, 0.825, 0.891, 0.71, 0.801,
|
||||
1.074, 1.148, 1, 0.928, 0.767, 0.701, 0.807, 0.902,
|
||||
0.997, 1.224, 1.089, 0.973, 0.98, 0.665};
|
||||
double gas_fit_E[] = {0.665, 0.949, 1.224};
|
||||
double newdata[] = {0.6650000, 0.7581667, 0.8513333, 0.9445000,
|
||||
1.0376667, 1.1308333, 1.2240000};
|
||||
double coverage = .99;
|
||||
int i, n = 22, p = 1, m = 3, se_fit = FALSE;
|
||||
|
||||
main() {
|
||||
printf("\nloess(&gas):\n");
|
||||
loess_setup(E, NOx, n, p, &gas);
|
||||
gas.model.span = 2.0 / 3.0;
|
||||
loess(&gas);
|
||||
loess_summary(&gas);
|
||||
|
||||
printf("\nloess(&gas_null):\n");
|
||||
loess_setup(E, NOx, n, p, &gas_null);
|
||||
gas_null.model.span = 1.0;
|
||||
loess(&gas_null);
|
||||
loess_summary(&gas_null);
|
||||
|
||||
printf("\npredict(gas_fit_E, m, &gas, &gas_pred, %d):\n", se_fit);
|
||||
predict(gas_fit_E, m, &gas, &gas_pred, se_fit);
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", gas_pred.fit[i]);
|
||||
printf("\n");
|
||||
|
||||
m = 7;
|
||||
se_fit = TRUE;
|
||||
predict(newdata, m, &gas, &gas_pred, se_fit);
|
||||
printf("\npointwise(&gas_pred, m, coverage, &gas_ci):\n");
|
||||
pointwise(&gas_pred, m, coverage, &gas_ci);
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", gas_ci.upper[i]);
|
||||
printf("\n");
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", gas_ci.fit[i]);
|
||||
printf("\n");
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", gas_ci.lower[i]);
|
||||
printf("\n");
|
||||
|
||||
printf("\nanova(&gas_null, &gas, &gas_anova):\n");
|
||||
anova(&gas_null, &gas, &gas_anova);
|
||||
printf("%g %g %g %g\n", gas_anova.dfn, gas_anova.dfd,
|
||||
gas_anova.F_value, gas_anova.Pr_F);
|
||||
|
||||
loess_free_mem(&gas);
|
||||
loess_free_mem(&gas_null);
|
||||
pred_free_mem(&gas_pred);
|
||||
pw_free_mem(&gas_ci);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
327
pmsco/loess/loess.c
Normal file
327
pmsco/loess/loess.c
Normal file
@ -0,0 +1,327 @@
|
||||
#include "S.h"
|
||||
#include "loess.h"
|
||||
|
||||
static char *surf_stat;
|
||||
|
||||
void
|
||||
loess_setup(x, y, n, p, lo)
|
||||
double *x, *y;
|
||||
int n, p;
|
||||
struct loess_struct *lo;
|
||||
{
|
||||
int i, max_kd;
|
||||
|
||||
max_kd = n > 200 ? n : 200;
|
||||
|
||||
lo->in.y = (double *) malloc(n * sizeof(double));
|
||||
lo->in.x = (double *) malloc(n * p * sizeof(double));
|
||||
lo->in.weights = (double *) malloc(n * sizeof(double));
|
||||
for(i = 0; i < (n * p); i++)
|
||||
lo->in.x[i] = x[i];
|
||||
for(i = 0; i < n; i++) {
|
||||
lo->in.y[i] = y[i];
|
||||
lo->in.weights[i] = 1;
|
||||
}
|
||||
lo->in.n = n;
|
||||
lo->in.p = p;
|
||||
lo->model.span = 0.75;
|
||||
lo->model.degree = 2;
|
||||
lo->model.normalize = TRUE;
|
||||
for(i = 0; i < 8; i++)
|
||||
lo->model.parametric[i] = lo->model.drop_square[i] = FALSE;
|
||||
lo->model.family = "gaussian";
|
||||
lo->control.surface = "interpolate";
|
||||
lo->control.statistics = "approximate";
|
||||
lo->control.cell = 0.2;
|
||||
lo->control.trace_hat = "wait.to.decide";
|
||||
lo->control.iterations = 4;
|
||||
|
||||
lo->out.fitted_values = (double *) malloc(n * sizeof(double));
|
||||
lo->out.fitted_residuals = (double *) malloc(n * sizeof(double));
|
||||
lo->out.pseudovalues = (double *) malloc(n * sizeof(double));
|
||||
lo->out.diagonal = (double *) malloc(n * sizeof(double));
|
||||
lo->out.robust = (double *) malloc(n * sizeof(double));
|
||||
lo->out.divisor = (double *) malloc(p * sizeof(double));
|
||||
|
||||
lo->kd_tree.parameter = (int *) malloc(7 * sizeof(int));
|
||||
lo->kd_tree.a = (int *) malloc(max_kd * sizeof(int));
|
||||
lo->kd_tree.xi = (double *) malloc(max_kd * sizeof(double));
|
||||
lo->kd_tree.vert = (double *) malloc(p * 2 * sizeof(double));
|
||||
lo->kd_tree.vval = (double *) malloc((p + 1) * max_kd * sizeof(double));
|
||||
}
|
||||
|
||||
void
|
||||
loess(lo)
|
||||
struct loess_struct *lo;
|
||||
{
|
||||
int size_info[2], iterations;
|
||||
void loess_();
|
||||
|
||||
size_info[0] = lo->in.p;
|
||||
size_info[1] = lo->in.n;
|
||||
|
||||
iterations = (!strcmp(lo->model.family, "gaussian")) ? 0 :
|
||||
lo->control.iterations;
|
||||
if(!strcmp(lo->control.trace_hat, "wait.to.decide")) {
|
||||
if(!strcmp(lo->control.surface, "interpolate"))
|
||||
lo->control.trace_hat = (lo->in.n < 500) ? "exact" : "approximate";
|
||||
else
|
||||
lo->control.trace_hat = "exact";
|
||||
}
|
||||
loess_(lo->in.y, lo->in.x, size_info, lo->in.weights,
|
||||
&lo->model.span,
|
||||
&lo->model.degree,
|
||||
lo->model.parametric,
|
||||
lo->model.drop_square,
|
||||
&lo->model.normalize,
|
||||
&lo->control.statistics,
|
||||
&lo->control.surface,
|
||||
&lo->control.cell,
|
||||
&lo->control.trace_hat,
|
||||
&iterations,
|
||||
lo->out.fitted_values,
|
||||
lo->out.fitted_residuals,
|
||||
&lo->out.enp,
|
||||
&lo->out.s,
|
||||
&lo->out.one_delta,
|
||||
&lo->out.two_delta,
|
||||
lo->out.pseudovalues,
|
||||
&lo->out.trace_hat,
|
||||
lo->out.diagonal,
|
||||
lo->out.robust,
|
||||
lo->out.divisor,
|
||||
lo->kd_tree.parameter,
|
||||
lo->kd_tree.a,
|
||||
lo->kd_tree.xi,
|
||||
lo->kd_tree.vert,
|
||||
lo->kd_tree.vval);
|
||||
}
|
||||
|
||||
void
|
||||
loess_(y, x_, size_info, weights, span, degree, parametric, drop_square,
|
||||
normalize, statistics, surface, cell, trace_hat_in, iterations,
|
||||
fitted_values, fitted_residuals, enp, s, one_delta, two_delta,
|
||||
pseudovalues, trace_hat_out, diagonal, robust, divisor,
|
||||
parameter, a, xi, vert, vval)
|
||||
double *y, *x_, *weights, *span, *cell, *pseudovalues,
|
||||
*fitted_values, *fitted_residuals, *enp, *s, *one_delta, *two_delta,
|
||||
*trace_hat_out, *diagonal, *robust, *divisor, *xi, *vert, *vval;
|
||||
int *size_info, *degree, *parametric, *drop_square, *normalize,
|
||||
*iterations, *parameter, *a;
|
||||
char **statistics, **surface, **trace_hat_in;
|
||||
{
|
||||
double *x, *x_tmp, new_cell, trL, delta1, delta2, sum_squares = 0,
|
||||
*pseudo_resid, *temp, *xi_tmp, *vert_tmp, *vval_tmp,
|
||||
*diag_tmp, trL_tmp = 0, d1_tmp = 0, d2_tmp = 0, sum, mean;
|
||||
int i, j, k, p, N, D, sum_drop_sqr = 0, sum_parametric = 0,
|
||||
setLf, nonparametric = 0, *order_parametric,
|
||||
*order_drop_sqr, zero = 0, max_kd, *a_tmp, *param_tmp;
|
||||
int cut, comp();
|
||||
char *new_stat;
|
||||
void condition();
|
||||
|
||||
D = size_info[0];
|
||||
N = size_info[1];
|
||||
max_kd = (N > 200 ? N : 200);
|
||||
*one_delta = *two_delta = *trace_hat_out = 0;
|
||||
|
||||
x = (double *) malloc(D * N * sizeof(double));
|
||||
x_tmp = (double *) malloc(D * N * sizeof(double));
|
||||
temp = (double *) malloc(N * sizeof(double));
|
||||
a_tmp = (int *) malloc(max_kd * sizeof(int));
|
||||
xi_tmp = (double *) malloc(max_kd * sizeof(double));
|
||||
vert_tmp = (double *) malloc(D * 2 * sizeof(double));
|
||||
vval_tmp = (double *) malloc((D + 1) * max_kd * sizeof(double));
|
||||
diag_tmp = (double *) malloc(N * sizeof(double));
|
||||
param_tmp = (int *) malloc(N * sizeof(int));
|
||||
order_parametric = (int *) malloc(D * sizeof(int));
|
||||
order_drop_sqr = (int *) malloc(D * sizeof(int));
|
||||
if((*iterations) > 0)
|
||||
pseudo_resid = (double *) malloc(N * sizeof(double));
|
||||
|
||||
new_cell = (*span) * (*cell);
|
||||
for(i = 0; i < N; i++)
|
||||
robust[i] = 1;
|
||||
for(i = 0; i < (N * D); i++)
|
||||
x_tmp[i] = x_[i];
|
||||
if((*normalize) && (D > 1)) {
|
||||
cut = ceil(0.100000000000000000001 * N);
|
||||
for(i = 0; i < D; i++) {
|
||||
k = i * N;
|
||||
for(j = 0; j < N; j++)
|
||||
temp[j] = x_[k + j];
|
||||
qsort(temp, N, sizeof(double), comp);
|
||||
sum = 0;
|
||||
for(j = cut; j <= (N - cut - 1); j++)
|
||||
sum = sum + temp[j];
|
||||
mean = sum / (N - 2 * cut);
|
||||
sum = 0;
|
||||
for(j = cut; j <= (N - cut - 1); j++) {
|
||||
temp[j] = temp[j] - mean;
|
||||
sum = sum + temp[j] * temp[j];
|
||||
}
|
||||
divisor[i] = sqrt(sum / (N - 2 * cut - 1));
|
||||
for(j = 0; j < N; j++) {
|
||||
p = k + j;
|
||||
x_tmp[p] = x_[p] / divisor[i];
|
||||
}
|
||||
}
|
||||
}
|
||||
else
|
||||
for(i = 0; i < D; i++) divisor[i] = 1;
|
||||
j = D - 1;
|
||||
for(i = 0; i < D; i++) {
|
||||
sum_drop_sqr = sum_drop_sqr + drop_square[i];
|
||||
sum_parametric = sum_parametric + parametric[i];
|
||||
if(parametric[i])
|
||||
order_parametric[j--] = i;
|
||||
else
|
||||
order_parametric[nonparametric++] = i;
|
||||
}
|
||||
for(i = 0; i < D; i++) {
|
||||
order_drop_sqr[i] = 2 - drop_square[order_parametric[i]];
|
||||
k = i * N;
|
||||
p = order_parametric[i] * N;
|
||||
for(j = 0; j < N; j++)
|
||||
x[k + j] = x_tmp[p + j];
|
||||
}
|
||||
if((*degree) == 1 && sum_drop_sqr) {
|
||||
fprintf(stderr, "Specified the square of a factor predictor to be dropped when degree = 1");
|
||||
exit(1);
|
||||
}
|
||||
if(D == 1 && sum_drop_sqr) {
|
||||
fprintf(stderr, "Specified the square of a predictor to be dropped with only one numeric predictor");
|
||||
exit(1);
|
||||
}
|
||||
if(sum_parametric == D) {
|
||||
fprintf(stderr, "Specified parametric for all predictors");
|
||||
exit(1);
|
||||
}
|
||||
for(j = 0; j <= (*iterations); j++) {
|
||||
new_stat = j ? "none" : *statistics;
|
||||
for(i = 0; i < N; i++)
|
||||
robust[i] = weights[i] * robust[i];
|
||||
condition(surface, new_stat, trace_hat_in);
|
||||
setLf = !strcmp(surf_stat, "interpolate/exact");
|
||||
loess_raw(y, x, weights, robust, &D, &N, span, degree,
|
||||
&nonparametric, order_drop_sqr, &sum_drop_sqr,
|
||||
&new_cell, &surf_stat, fitted_values, parameter, a,
|
||||
xi, vert, vval, diagonal, &trL, &delta1, &delta2,
|
||||
&setLf);
|
||||
if(j == 0) {
|
||||
*trace_hat_out = trL;
|
||||
*one_delta = delta1;
|
||||
*two_delta = delta2;
|
||||
}
|
||||
for(i = 0; i < N; i++)
|
||||
fitted_residuals[i] = y[i] - fitted_values[i];
|
||||
if(j < (*iterations))
|
||||
F77_SUB(lowesw)(fitted_residuals, &N, robust, temp);
|
||||
}
|
||||
if((*iterations) > 0) {
|
||||
F77_SUB(lowesp)(&N, y, fitted_values, weights, robust, temp, pseudovalues);
|
||||
|
||||
loess_raw(pseudovalues, x, weights, weights, &D, &N, span,
|
||||
degree, &nonparametric, order_drop_sqr, &sum_drop_sqr,
|
||||
&new_cell, &surf_stat, temp, param_tmp, a_tmp, xi_tmp,
|
||||
vert_tmp, vval_tmp, diag_tmp, &trL_tmp, &d1_tmp, &d2_tmp, &zero);
|
||||
for(i = 0; i < N; i++)
|
||||
pseudo_resid[i] = pseudovalues[i] - temp[i];
|
||||
}
|
||||
if((*iterations) == 0)
|
||||
for(i = 0; i < N; i++)
|
||||
sum_squares = sum_squares + weights[i] *
|
||||
fitted_residuals[i] * fitted_residuals[i];
|
||||
else
|
||||
for(i = 0; i < N; i++)
|
||||
sum_squares = sum_squares + weights[i] *
|
||||
pseudo_resid[i] * pseudo_resid[i];
|
||||
*enp = (*one_delta) + 2 * (*trace_hat_out) - N;
|
||||
*s = sqrt(sum_squares / (*one_delta));
|
||||
|
||||
free(x);
|
||||
free(x_tmp);
|
||||
free(temp);
|
||||
free(xi_tmp);
|
||||
free(vert_tmp);
|
||||
free(vval_tmp);
|
||||
free(diag_tmp);
|
||||
free(a_tmp);
|
||||
free(param_tmp);
|
||||
free(order_parametric);
|
||||
free(order_drop_sqr);
|
||||
if((*iterations) > 0)
|
||||
free(pseudo_resid);
|
||||
}
|
||||
|
||||
void
|
||||
loess_free_mem(lo)
|
||||
struct loess_struct *lo;
|
||||
{
|
||||
free(lo->in.x);
|
||||
free(lo->in.y);
|
||||
free(lo->in.weights);
|
||||
free(lo->out.fitted_values);
|
||||
free(lo->out.fitted_residuals);
|
||||
free(lo->out.pseudovalues);
|
||||
free(lo->out.diagonal);
|
||||
free(lo->out.robust);
|
||||
free(lo->out.divisor);
|
||||
free(lo->kd_tree.parameter);
|
||||
free(lo->kd_tree.a);
|
||||
free(lo->kd_tree.xi);
|
||||
free(lo->kd_tree.vert);
|
||||
free(lo->kd_tree.vval);
|
||||
}
|
||||
|
||||
void
|
||||
loess_summary(lo)
|
||||
struct loess_struct *lo;
|
||||
{
|
||||
printf("Number of Observations: %d\n", lo->in.n);
|
||||
printf("Equivalent Number of Parameters: %.1f\n", lo->out.enp);
|
||||
if(!strcmp(lo->model.family, "gaussian"))
|
||||
printf("Residual Standard Error: ");
|
||||
else
|
||||
printf("Residual Scale Estimate: ");
|
||||
printf("%.4f\n", lo->out.s);
|
||||
}
|
||||
|
||||
void
|
||||
condition(surface, new_stat, trace_hat_in)
|
||||
char **surface, *new_stat, **trace_hat_in;
|
||||
{
|
||||
if(!strcmp(*surface, "interpolate")) {
|
||||
if(!strcmp(new_stat, "none"))
|
||||
surf_stat = "interpolate/none";
|
||||
else if(!strcmp(new_stat, "exact"))
|
||||
surf_stat = "interpolate/exact";
|
||||
else if(!strcmp(new_stat, "approximate"))
|
||||
{
|
||||
if(!strcmp(*trace_hat_in, "approximate"))
|
||||
surf_stat = "interpolate/2.approx";
|
||||
else if(!strcmp(*trace_hat_in, "exact"))
|
||||
surf_stat = "interpolate/1.approx";
|
||||
}
|
||||
}
|
||||
else if(!strcmp(*surface, "direct")) {
|
||||
if(!strcmp(new_stat, "none"))
|
||||
surf_stat = "direct/none";
|
||||
else if(!strcmp(new_stat, "exact"))
|
||||
surf_stat = "direct/exact";
|
||||
else if(!strcmp(new_stat, "approximate"))
|
||||
surf_stat = "direct/approximate";
|
||||
}
|
||||
}
|
||||
|
||||
int
|
||||
comp(d1, d2)
|
||||
double *d1, *d2;
|
||||
{
|
||||
if(*d1 < *d2)
|
||||
return(-1);
|
||||
else if(*d1 == *d2)
|
||||
return(0);
|
||||
else
|
||||
return(1);
|
||||
}
|
||||
70
pmsco/loess/loess.h
Normal file
70
pmsco/loess/loess.h
Normal file
@ -0,0 +1,70 @@
|
||||
/* for the meaning of these fields, see struct.m */
|
||||
/* longs are used here so that the codes can be called from S */
|
||||
|
||||
#define TRUE 1
|
||||
#define FALSE 0
|
||||
|
||||
extern struct loess_struct {
|
||||
struct {
|
||||
int n;
|
||||
int p;
|
||||
double *y;
|
||||
double *x;
|
||||
double *weights;
|
||||
} in;
|
||||
struct {
|
||||
double span;
|
||||
int degree;
|
||||
int normalize;
|
||||
int parametric[8];
|
||||
int drop_square[8];
|
||||
char *family;
|
||||
} model;
|
||||
struct {
|
||||
char *surface;
|
||||
char *statistics;
|
||||
double cell;
|
||||
char *trace_hat;
|
||||
int iterations;
|
||||
} control;
|
||||
struct {
|
||||
int *parameter;
|
||||
int *a;
|
||||
double *xi;
|
||||
double *vert;
|
||||
double *vval;
|
||||
} kd_tree;
|
||||
struct {
|
||||
double *fitted_values;
|
||||
double *fitted_residuals;
|
||||
double enp;
|
||||
double s;
|
||||
double one_delta;
|
||||
double two_delta;
|
||||
double *pseudovalues;
|
||||
double trace_hat;
|
||||
double *diagonal;
|
||||
double *robust;
|
||||
double *divisor;
|
||||
} out;
|
||||
} loess_struct;
|
||||
|
||||
extern struct pred_struct {
|
||||
double *fit;
|
||||
double *se_fit;
|
||||
double residual_scale;
|
||||
double df;
|
||||
} pred_struct;
|
||||
|
||||
extern struct anova_struct {
|
||||
double dfn;
|
||||
double dfd;
|
||||
double F_value;
|
||||
double Pr_F;
|
||||
} anova_struct;
|
||||
|
||||
extern struct ci_struct {
|
||||
double *fit;
|
||||
double *upper;
|
||||
double *lower;
|
||||
} ci_struct;
|
||||
284
pmsco/loess/loess.i
Normal file
284
pmsco/loess/loess.i
Normal file
@ -0,0 +1,284 @@
|
||||
%module loess
|
||||
%include "typemaps.i"
|
||||
|
||||
%{
|
||||
#define SWIG_FILE_WITH_INIT
|
||||
#include <errno.h>
|
||||
#define EARRLEN 1000
|
||||
#include "loess.h"
|
||||
|
||||
extern void loess(struct loess_struct *lo);
|
||||
|
||||
extern void loess_summary(struct loess_struct *lo);
|
||||
|
||||
// not implemented
|
||||
// extern void predict(double *eval, int m, struct loess_struct *lo, struct pred_struct *pre, int se);
|
||||
%}
|
||||
|
||||
%include "numpy.i"
|
||||
|
||||
%init %{
|
||||
import_array();
|
||||
%}
|
||||
|
||||
%apply (double *IN_ARRAY1, int DIM1) {(double *v, int n)};
|
||||
%apply (int *IN_ARRAY1, int DIM1) {(int *v, int n)};
|
||||
%apply (double **ARGOUTVIEWM_ARRAY1, int *DIM1) {(double **w, int *n)};
|
||||
%apply (int **ARGOUTVIEWM_ARRAY1, int *DIM1) {(int **w, int *n)};
|
||||
|
||||
%include "loess.h"
|
||||
|
||||
extern void loess(struct loess_struct *lo);
|
||||
|
||||
extern void loess_summary(struct loess_struct *lo);
|
||||
|
||||
// not implemented
|
||||
// extern void predict(double *eval, int m, struct loess_struct *lo, struct pred_struct *pre, int se);
|
||||
|
||||
%exception {
|
||||
errno = 0;
|
||||
$action
|
||||
|
||||
if (errno != 0) {
|
||||
switch(errno) {
|
||||
case ENOMEM:
|
||||
PyErr_Format(PyExc_MemoryError, "memory allocation failed.");
|
||||
break;
|
||||
case EARRLEN:
|
||||
PyErr_Format(PyExc_ValueError, "unexpected array length.");
|
||||
break;
|
||||
default:
|
||||
PyErr_Format(PyExc_Exception, "unknown exception.");
|
||||
}
|
||||
SWIG_fail;
|
||||
}
|
||||
}
|
||||
|
||||
%extend loess_struct {
|
||||
//// constructor of a loess_struct
|
||||
//
|
||||
// @param n: number of data points.
|
||||
//
|
||||
// @param p: number of factors (independent variables). maximum 8.
|
||||
|
||||
loess_struct(int n, int p) {
|
||||
struct loess_struct *lo;
|
||||
lo = (struct loess_struct *) malloc(sizeof(loess_struct));
|
||||
|
||||
int i, max_kd;
|
||||
max_kd = n > 200 ? n : 200;
|
||||
|
||||
lo->in.y = (double *) malloc(n * sizeof(double));
|
||||
lo->in.x = (double *) malloc(n * p * sizeof(double));
|
||||
lo->in.weights = (double *) malloc(n * sizeof(double));
|
||||
for(i = 0; i < (n * p); i++)
|
||||
lo->in.x[i] = 0.0;
|
||||
for(i = 0; i < n; i++) {
|
||||
lo->in.y[i] = 0.0;
|
||||
lo->in.weights[i] = 1.0;
|
||||
}
|
||||
lo->in.n = n;
|
||||
lo->in.p = p;
|
||||
lo->model.span = 0.75;
|
||||
lo->model.degree = 2;
|
||||
lo->model.normalize = TRUE;
|
||||
for(i = 0; i < 8; i++)
|
||||
lo->model.parametric[i] = lo->model.drop_square[i] = FALSE;
|
||||
lo->model.family = "gaussian";
|
||||
lo->control.surface = "interpolate";
|
||||
lo->control.statistics = "approximate";
|
||||
lo->control.cell = 0.2;
|
||||
lo->control.trace_hat = "wait.to.decide";
|
||||
lo->control.iterations = 4;
|
||||
|
||||
lo->out.fitted_values = (double *) malloc(n * sizeof(double));
|
||||
lo->out.fitted_residuals = (double *) malloc(n * sizeof(double));
|
||||
lo->out.pseudovalues = (double *) malloc(n * sizeof(double));
|
||||
lo->out.diagonal = (double *) malloc(n * sizeof(double));
|
||||
lo->out.robust = (double *) malloc(n * sizeof(double));
|
||||
lo->out.divisor = (double *) malloc(p * sizeof(double));
|
||||
|
||||
lo->kd_tree.parameter = (int *) malloc(7 * sizeof(int));
|
||||
lo->kd_tree.a = (int *) malloc(max_kd * sizeof(int));
|
||||
lo->kd_tree.xi = (double *) malloc(max_kd * sizeof(double));
|
||||
lo->kd_tree.vert = (double *) malloc(p * 2 * sizeof(double));
|
||||
lo->kd_tree.vval = (double *) malloc((p + 1) * max_kd * sizeof(double));
|
||||
|
||||
return lo;
|
||||
}
|
||||
|
||||
~loess_struct() {
|
||||
free($self->in.x);
|
||||
free($self->in.y);
|
||||
free($self->in.weights);
|
||||
free($self->out.fitted_values);
|
||||
free($self->out.fitted_residuals);
|
||||
free($self->out.pseudovalues);
|
||||
free($self->out.diagonal);
|
||||
free($self->out.robust);
|
||||
free($self->out.divisor);
|
||||
free($self->kd_tree.parameter);
|
||||
free($self->kd_tree.a);
|
||||
free($self->kd_tree.xi);
|
||||
free($self->kd_tree.vert);
|
||||
free($self->kd_tree.vval);
|
||||
free($self);
|
||||
}
|
||||
|
||||
void set_x(double *v, int n) {
|
||||
int n_exp = $self->in.n * $self->in.p;
|
||||
if (n == n_exp) {
|
||||
int i;
|
||||
for(i = 0; i < n; i++)
|
||||
$self->in.x[i] = v[i];
|
||||
} else {
|
||||
errno = EARRLEN;
|
||||
}
|
||||
}
|
||||
|
||||
void set_y(double *v, int n) {
|
||||
int n_exp = $self->in.n;
|
||||
if (n == n_exp) {
|
||||
int i;
|
||||
for(i = 0; i < n; i++)
|
||||
$self->in.y[i] = v[i];
|
||||
} else {
|
||||
errno = EARRLEN;
|
||||
}
|
||||
}
|
||||
|
||||
void set_parametric(int *v, int n) {
|
||||
int n_exp = $self->in.p;
|
||||
if (n == n_exp) {
|
||||
int i;
|
||||
for(i = 0; i < n; i++)
|
||||
$self->model.parametric[i] = v[i];
|
||||
} else {
|
||||
errno = EARRLEN;
|
||||
}
|
||||
}
|
||||
|
||||
void set_drop_square(int *v, int n) {
|
||||
int n_exp = $self->in.p;
|
||||
if (n == n_exp) {
|
||||
int i;
|
||||
for(i = 0; i < n; i++)
|
||||
$self->model.drop_square[i] = v[i];
|
||||
} else {
|
||||
errno = EARRLEN;
|
||||
}
|
||||
}
|
||||
|
||||
void get_x(double **w, int *n) {
|
||||
int ni = $self->in.n * $self->in.p;
|
||||
|
||||
double *temp;
|
||||
temp = (double *)malloc(ni * sizeof(double));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->in.x[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_y(double **w, int *n) {
|
||||
int ni = $self->in.n;
|
||||
|
||||
double *temp;
|
||||
temp = (double *)malloc(ni * sizeof(double));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->in.y[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_weights(double **w, int *n) {
|
||||
int ni = $self->in.n;
|
||||
|
||||
double *temp;
|
||||
temp = (double *)malloc(ni * sizeof(double));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->in.weights[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_fitted_values(double **w, int *n) {
|
||||
int ni = $self->in.n;
|
||||
|
||||
double *temp;
|
||||
temp = (double *)malloc(ni * sizeof(double));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->out.fitted_values[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_fitted_residuals(double **w, int *n) {
|
||||
int ni = $self->in.n;
|
||||
|
||||
double *temp;
|
||||
temp = (double *)malloc(ni * sizeof(double));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->out.fitted_residuals[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_parametric(int **w, int *n) {
|
||||
int ni = $self->in.p;
|
||||
|
||||
int *temp;
|
||||
temp = (int *)malloc(ni * sizeof(int));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->model.parametric[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
void get_drop_square(int **w, int *n) {
|
||||
int ni = $self->in.p;
|
||||
|
||||
int *temp;
|
||||
temp = (int *)malloc(ni * sizeof(int));
|
||||
if (temp == NULL)
|
||||
errno = ENOMEM;
|
||||
|
||||
int i;
|
||||
for(i = 0; i < ni; i++)
|
||||
temp[i] = $self->model.drop_square[i];
|
||||
|
||||
*w = temp;
|
||||
*n = ni;
|
||||
}
|
||||
|
||||
};
|
||||
75
pmsco/loess/loess.m
Normal file
75
pmsco/loess/loess.m
Normal file
@ -0,0 +1,75 @@
|
||||
NAME
|
||||
|
||||
loess_setup, loess, loess_summary, loess_free_mem, anova
|
||||
|
||||
SYNOPSIS
|
||||
|
||||
#include "loess.h"
|
||||
double *x, *y;
|
||||
long n, p;
|
||||
struct loess_struct *lo, *lo2;
|
||||
struct anova_struct *aov;
|
||||
|
||||
void loess_setup(x, y, n, p, lo)
|
||||
|
||||
void loess(lo)
|
||||
|
||||
void loess_summary(lo)
|
||||
|
||||
void loess_free_mem(lo)
|
||||
|
||||
void anova(lo, lo2, aov);
|
||||
|
||||
PARAMETERS
|
||||
|
||||
x predictors vector (of length n * p)
|
||||
The j-th coordinate of the i-th point is in x[i+n*j],
|
||||
where 0<=j<p, 0<=i<n.
|
||||
|
||||
y response vector (of length n).
|
||||
|
||||
n number of observations.
|
||||
|
||||
p number of variables/predictors.
|
||||
|
||||
lo copy of data; controls; k-d tree and coefficients.
|
||||
|
||||
aov results of the F-test in the analysis of variance.
|
||||
|
||||
DESCRIPTION
|
||||
|
||||
loess_setup() sets up all default values in loess_struct's in,
|
||||
model, and control structures; it also allocates memory for the
|
||||
kd_tree and out structures based on n and p. Caller can then
|
||||
override any of these parameters by explicitly redefining them
|
||||
before the call to loess() (see sample.c). loess_setup()
|
||||
has the side-effect of copying x, y, n, and p into the in
|
||||
structure for ease of arguments-passing in subsequent calls to
|
||||
other loess and predict routines.
|
||||
|
||||
loess() takes this structure, and does the actual loess
|
||||
computation. It stored the results in the out structure.
|
||||
|
||||
loess_summary() is a simple utility routine that summarizes the
|
||||
results of the loess computation. Since it takes in the whole
|
||||
loess structure as its argument, it has the potential of printing
|
||||
out any parameter of interest with only a slight modification to
|
||||
the code.
|
||||
|
||||
loess_free_mem() frees up all dynamically allocated memory
|
||||
used by the loess structure.
|
||||
|
||||
anova() performs an analysis of variance on two loess models, and
|
||||
stores the results of the F-test in the anova_struct structure.
|
||||
|
||||
loess_struct and anova_struct are defined in loess.h and documented
|
||||
in struct.m. Although the internal arrays are allocated by
|
||||
loess_setup(), the struct arguments (lo, lo2, aov) should be
|
||||
allocated by the caller. Thus a typical call would be
|
||||
struct loess_struct lo;
|
||||
loess_setup(x,y,n,p.&lo);
|
||||
|
||||
SEE ALSO
|
||||
|
||||
predict, pointwise, pred_free_mem, pw_free_mem
|
||||
|
||||
347
pmsco/loess/loessc.c
Normal file
347
pmsco/loess/loessc.c
Normal file
@ -0,0 +1,347 @@
|
||||
#include "S.h"
|
||||
|
||||
#define min(x,y) ((x) < (y) ? (x) : (y))
|
||||
#define max(x,y) ((x) > (y) ? (x) : (y))
|
||||
#define GAUSSIAN 1
|
||||
#define SYMMETRIC 0
|
||||
|
||||
static int *iv, liv, lv, tau;
|
||||
static double *v;
|
||||
|
||||
loess_raw(y, x, weights, robust, d, n, span, degree, nonparametric,
|
||||
drop_square, sum_drop_sqr, cell, surf_stat, surface, parameter, a,
|
||||
xi, vert, vval, diagonal, trL, one_delta, two_delta, setLf)
|
||||
double *y, *x, *weights, *robust, *span, *cell, *surface, *xi, *vert,
|
||||
*vval, *diagonal, *trL, *one_delta, *two_delta;
|
||||
int *d, *n, *parameter, *a, *degree, *nonparametric, *drop_square,
|
||||
*sum_drop_sqr, *setLf;
|
||||
char **surf_stat;
|
||||
{
|
||||
int zero = 0, one = 1, two = 2, nsing, i, k;
|
||||
double *hat_matrix, *LL;
|
||||
|
||||
*trL = 0;
|
||||
loess_workspace(d, n, span, degree, nonparametric, drop_square,
|
||||
sum_drop_sqr, setLf);
|
||||
v[1] = *cell;
|
||||
if(!strcmp(*surf_stat, "interpolate/none")) {
|
||||
F77_SUB(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v);
|
||||
F77_SUB(lowese)(iv, &liv, &lv, v, n, x, surface);
|
||||
loess_prune(parameter, a, xi, vert, vval);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "direct/none")) {
|
||||
F77_SUB(lowesf)(x, y, robust, iv, &liv, &lv, v, n, x,
|
||||
&zero, &zero, surface);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "interpolate/1.approx")) {
|
||||
F77_SUB(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v);
|
||||
F77_SUB(lowese)(iv, &liv, &lv, v, n, x, surface);
|
||||
nsing = iv[29];
|
||||
for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i];
|
||||
F77_SUB(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
|
||||
loess_prune(parameter, a, xi, vert, vval);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "interpolate/2.approx")) {
|
||||
F77_SUB(lowesb)(x, y, robust, &zero, &zero, iv, &liv, &lv, v);
|
||||
F77_SUB(lowese)(iv, &liv, &lv, v, n, x, surface);
|
||||
nsing = iv[29];
|
||||
F77_SUB(ehg196)(&tau, d, span, trL);
|
||||
F77_SUB(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
|
||||
loess_prune(parameter, a, xi, vert, vval);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "direct/approximate")) {
|
||||
F77_SUB(lowesf)(x, y, weights, iv, &liv, &lv, v, n, x,
|
||||
diagonal, &one, surface);
|
||||
nsing = iv[29];
|
||||
for(i = 0; i < (*n); i++) *trL = *trL + diagonal[i];
|
||||
F77_SUB(lowesa)(trL, n, d, &tau, &nsing, one_delta, two_delta);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "interpolate/exact")) {
|
||||
hat_matrix = Calloc((*n)*(*n), double);
|
||||
LL = Calloc((*n)*(*n), double);
|
||||
F77_SUB(lowesb)(x, y, weights, diagonal, &one, iv, &liv, &lv, v);
|
||||
F77_SUB(lowesl)(iv, &liv, &lv, v, n, x, hat_matrix);
|
||||
F77_SUB(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta);
|
||||
F77_SUB(lowese)(iv, &liv, &lv, v, n, x, surface);
|
||||
loess_prune(parameter, a, xi, vert, vval);
|
||||
Free(hat_matrix);
|
||||
Free(LL);
|
||||
}
|
||||
else if (!strcmp(*surf_stat, "direct/exact")) {
|
||||
hat_matrix = Calloc((*n)*(*n), double);
|
||||
LL = Calloc((*n)*(*n), double);
|
||||
F77_SUB(lowesf)(x, y, weights, iv, liv, lv, v, n, x,
|
||||
hat_matrix, &two, surface);
|
||||
F77_SUB(lowesc)(n, hat_matrix, LL, trL, one_delta, two_delta);
|
||||
k = (*n) + 1;
|
||||
for(i = 0; i < (*n); i++)
|
||||
diagonal[i] = hat_matrix[i * k];
|
||||
Free(hat_matrix);
|
||||
Free(LL);
|
||||
}
|
||||
loess_free();
|
||||
}
|
||||
|
||||
loess_dfit(y, x, x_evaluate, weights, span, degree, nonparametric,
|
||||
drop_square, sum_drop_sqr, d, n, m, fit)
|
||||
double *y, *x, *x_evaluate, *weights, *span, *fit;
|
||||
int *degree, *nonparametric, *drop_square, *sum_drop_sqr, *d, *n, *m;
|
||||
{
|
||||
int zero = 0, one = 1;
|
||||
|
||||
loess_workspace(d, n, span, degree, nonparametric, drop_square,
|
||||
sum_drop_sqr, &zero);
|
||||
F77_SUB(lowesf)(x, y, weights, iv, &liv, &lv, v, m, x_evaluate,
|
||||
&zero, &zero, fit);
|
||||
loess_free();
|
||||
}
|
||||
|
||||
loess_dfitse(y, x, x_evaluate, weights, robust, family, span, degree,
|
||||
nonparametric, drop_square, sum_drop_sqr, d, n, m, fit, L)
|
||||
double *y, *x, *x_evaluate, *weights, *robust, *span, *fit, *L;
|
||||
int *family, *degree, *nonparametric, *drop_square, *sum_drop_sqr,
|
||||
*d, *n, *m;
|
||||
{
|
||||
int zero = 0, one = 1, two = 2;
|
||||
|
||||
loess_workspace(d, n, span, degree, nonparametric, drop_square,
|
||||
sum_drop_sqr, &zero);
|
||||
if(*family == GAUSSIAN)
|
||||
F77_SUB(lowesf)(x, y, weights, iv, &liv, &lv, v, m,
|
||||
x_evaluate, L, &two, fit);
|
||||
else if(*family == SYMMETRIC)
|
||||
{
|
||||
F77_SUB(lowesf)(x, y, weights, iv, &liv, &lv, v, m,
|
||||
x_evaluate, L, &two, fit);
|
||||
F77_SUB(lowesf)(x, y, robust, iv, &liv, &lv, v, m,
|
||||
x_evaluate, &zero, &zero, fit);
|
||||
}
|
||||
loess_free();
|
||||
}
|
||||
loess_ifit(parameter, a, xi, vert, vval, m, x_evaluate, fit)
|
||||
double *xi, *vert, *vval, *x_evaluate, *fit;
|
||||
int *parameter, *a, *m;
|
||||
{
|
||||
loess_grow(parameter, a, xi, vert, vval);
|
||||
F77_SUB(lowese)(iv, &liv, &lv, v, m, x_evaluate, fit);
|
||||
loess_free();
|
||||
}
|
||||
|
||||
loess_ise(y, x, x_evaluate, weights, span, degree, nonparametric,
|
||||
drop_square, sum_drop_sqr, cell, d, n, m, fit, L)
|
||||
double *y, *x, *x_evaluate, *weights, *span, *cell, *fit, *L;
|
||||
int *degree, *nonparametric, *drop_square, *sum_drop_sqr, *d, *n, *m;
|
||||
{
|
||||
int zero = 0, one = 1;
|
||||
|
||||
loess_workspace(d, n, span, degree, nonparametric, drop_square,
|
||||
sum_drop_sqr, &one);
|
||||
v[1] = *cell;
|
||||
F77_SUB(lowesb)(x, y, weights, &zero, &zero, iv, &liv, &lv, v);
|
||||
F77_SUB(lowesl)(iv, &liv, &lv, v, m, x_evaluate, L);
|
||||
loess_free();
|
||||
}
|
||||
|
||||
loess_workspace(d, n, span, degree, nonparametric, drop_square,
|
||||
sum_drop_sqr, setLf)
|
||||
int *d, *n, *degree, *nonparametric, *drop_square, *sum_drop_sqr,
|
||||
*setLf;
|
||||
double *span;
|
||||
{
|
||||
int D, N, tau0, nvmax, nf, version = 106, i;
|
||||
|
||||
D = *d;
|
||||
N = *n;
|
||||
nvmax = max(200, N);
|
||||
nf = min(N, floor(N * (*span)));
|
||||
tau0 = ((*degree) > 1) ? ((D + 2) * (D + 1) * 0.5) : (D + 1);
|
||||
tau = tau0 - (*sum_drop_sqr);
|
||||
lv = 50 + (3 * D + 3) * nvmax + N + (tau0 + 2) * nf;
|
||||
liv = 50 + ((int)pow((double)2, (double)D) + 4) * nvmax + 2 * N;
|
||||
if(*setLf) {
|
||||
lv = lv + (D + 1) * nf * nvmax;
|
||||
liv = liv + nf * nvmax;
|
||||
}
|
||||
iv = Calloc(liv, int);
|
||||
v = Calloc(lv, double);
|
||||
|
||||
F77_SUB(lowesd)(&version, iv, &liv, &lv, v, d, n, span, degree,
|
||||
&nvmax, setLf);
|
||||
iv[32] = *nonparametric;
|
||||
for(i = 0; i < D; i++)
|
||||
iv[i + 40] = drop_square[i];
|
||||
}
|
||||
|
||||
loess_prune(parameter, a, xi, vert, vval)
|
||||
double *xi, *vert, *vval;
|
||||
int *parameter, *a;
|
||||
{
|
||||
int d, vc, a1, v1, xi1, vv1, nc, nv, nvmax, i, j, k;
|
||||
|
||||
d = iv[1];
|
||||
vc = iv[3] - 1;
|
||||
nc = iv[4];
|
||||
nv = iv[5];
|
||||
a1 = iv[6] - 1;
|
||||
v1 = iv[10] - 1;
|
||||
xi1 = iv[11] - 1;
|
||||
vv1 = iv[12] - 1;
|
||||
nvmax = iv[13];
|
||||
|
||||
for(i = 0; i < 5; i++)
|
||||
parameter[i] = iv[i + 1];
|
||||
parameter[5] = iv[21] - 1;
|
||||
parameter[6] = iv[14] - 1;
|
||||
|
||||
for(i = 0; i < d; i++){
|
||||
k = nvmax * i;
|
||||
vert[i] = v[v1 + k];
|
||||
vert[i + d] = v[v1 + vc + k];
|
||||
}
|
||||
for(i = 0; i < nc; i++) {
|
||||
xi[i] = v[xi1 + i];
|
||||
a[i] = iv[a1 + i];
|
||||
}
|
||||
k = (d + 1) * nv;
|
||||
for(i = 0; i < k; i++)
|
||||
vval[i] = v[vv1 + i];
|
||||
}
|
||||
|
||||
loess_grow(parameter, a, xi, vert, vval)
|
||||
double *xi, *vert, *vval;
|
||||
int *parameter, *a;
|
||||
{
|
||||
int d, vc, nc, nv, a1, v1, xi1, vv1, i, j, k;
|
||||
|
||||
d = parameter[0];
|
||||
vc = parameter[2];
|
||||
nc = parameter[3];
|
||||
nv = parameter[4];
|
||||
liv = parameter[5];
|
||||
lv = parameter[6];
|
||||
iv = Calloc(liv, int);
|
||||
v = Calloc(lv, double);
|
||||
|
||||
iv[1] = d;
|
||||
iv[2] = parameter[1];
|
||||
iv[3] = vc;
|
||||
iv[5] = iv[13] = nv;
|
||||
iv[4] = iv[16] = nc;
|
||||
iv[6] = 50;
|
||||
iv[7] = iv[6] + nc;
|
||||
iv[8] = iv[7] + vc * nc;
|
||||
iv[9] = iv[8] + nc;
|
||||
iv[10] = 50;
|
||||
iv[12] = iv[10] + nv * d;
|
||||
iv[11] = iv[12] + (d + 1) * nv;
|
||||
iv[27] = 173;
|
||||
|
||||
v1 = iv[10] - 1;
|
||||
xi1 = iv[11] - 1;
|
||||
a1 = iv[6] - 1;
|
||||
vv1 = iv[12] - 1;
|
||||
|
||||
for(i = 0; i < d; i++) {
|
||||
k = nv * i;
|
||||
v[v1 + k] = vert[i];
|
||||
v[v1 + vc - 1 + k] = vert[i + d];
|
||||
}
|
||||
for(i = 0; i < nc; i++) {
|
||||
v[xi1 + i] = xi[i];
|
||||
iv[a1 + i] = a[i];
|
||||
}
|
||||
k = (d + 1) * nv;
|
||||
for(i = 0; i < k; i++)
|
||||
v[vv1 + i] = vval[i];
|
||||
|
||||
F77_SUB(ehg169)(&d, &vc, &nc, &nc, &nv, &nv, v+v1, iv+a1,
|
||||
v+xi1, iv+iv[7]-1, iv+iv[8]-1, iv+iv[9]-1);
|
||||
}
|
||||
|
||||
loess_free()
|
||||
{
|
||||
Free(v);
|
||||
Free(iv);
|
||||
}
|
||||
|
||||
/* begin ehg's FORTRAN-callable C-codes */
|
||||
|
||||
void
|
||||
F77_SUB(ehg182)(i)
|
||||
int *i;
|
||||
{
|
||||
char *mess, mess2[50];
|
||||
switch(*i){
|
||||
case 100: mess="wrong version number in lowesd. Probably typo in caller."; break;
|
||||
case 101: mess="d>dMAX in ehg131. Need to recompile with increased dimensions."; break;
|
||||
case 102: mess="liv too small. (Discovered by lowesd)"; break;
|
||||
case 103: mess="lv too small. (Discovered by lowesd)"; break;
|
||||
case 104: mess="span too small. fewer data values than degrees of freedom."; break;
|
||||
case 105: mess="k>d2MAX in ehg136. Need to recompile with increased dimensions."; break;
|
||||
case 106: mess="lwork too small"; break;
|
||||
case 107: mess="invalid value for kernel"; break;
|
||||
case 108: mess="invalid value for ideg"; break;
|
||||
case 109: mess="lowstt only applies when kernel=1."; break;
|
||||
case 110: mess="not enough extra workspace for robustness calculation"; break;
|
||||
case 120: mess="zero-width neighborhood. make span bigger"; break;
|
||||
case 121: mess="all data on boundary of neighborhood. make span bigger"; break;
|
||||
case 122: mess="extrapolation not allowed with blending"; break;
|
||||
case 123: mess="ihat=1 (diag L) in l2fit only makes sense if z=x (eval=data)."; break;
|
||||
case 171: mess="lowesd must be called first."; break;
|
||||
case 172: mess="lowesf must not come between lowesb and lowese, lowesr, or lowesl."; break;
|
||||
case 173: mess="lowesb must come before lowese, lowesr, or lowesl."; break;
|
||||
case 174: mess="lowesb need not be called twice."; break;
|
||||
case 175: mess="need setLf=.true. for lowesl."; break;
|
||||
case 180: mess="nv>nvmax in cpvert."; break;
|
||||
case 181: mess="nt>20 in eval."; break;
|
||||
case 182: mess="svddc failed in l2fit."; break;
|
||||
case 183: mess="didnt find edge in vleaf."; break;
|
||||
case 184: mess="zero-width cell found in vleaf."; break;
|
||||
case 185: mess="trouble descending to leaf in vleaf."; break;
|
||||
case 186: mess="insufficient workspace for lowesf."; break;
|
||||
case 187: mess="insufficient stack space"; break;
|
||||
case 188: mess="lv too small for computing explicit L"; break;
|
||||
case 191: mess="computed trace L was negative; something is wrong!"; break;
|
||||
case 192: mess="computed delta was negative; something is wrong!"; break;
|
||||
case 193: mess="workspace in loread appears to be corrupted"; break;
|
||||
case 194: mess="trouble in l2fit/l2tr"; break;
|
||||
case 195: mess="only constant, linear, or quadratic local models allowed"; break;
|
||||
case 196: mess="degree must be at least 1 for vertex influence matrix"; break;
|
||||
case 999: mess="not yet implemented"; break;
|
||||
default: sprintf(mess=mess2,"Assert failed; error code %d\n",*i); break;
|
||||
}
|
||||
Recover(mess,NULL_ENTRY); /* in /usr/s/current/src/qpe/debug.c */
|
||||
}
|
||||
|
||||
void
|
||||
F77_SUB(ehg183)(s,i,n,inc)
|
||||
char *s;
|
||||
int *i, *n, *inc;
|
||||
{
|
||||
char mess[4000], num[20];
|
||||
int j;
|
||||
strcpy(mess,s);
|
||||
for (j=0; j<*n; j++) {
|
||||
sprintf(num," %d",i[j * *inc]);
|
||||
strcat(mess,num);
|
||||
}
|
||||
strcat(mess,"\n");
|
||||
Warning(mess,NULL_ENTRY);
|
||||
}
|
||||
|
||||
void
|
||||
F77_SUB(ehg184)(s,x,n,inc)
|
||||
char *s;
|
||||
double *x;
|
||||
int *n, *inc;
|
||||
{
|
||||
char mess[4000], num[30];
|
||||
int j;
|
||||
strcpy(mess,s);
|
||||
for (j=0; j<*n; j++) {
|
||||
sprintf(num," %.5g",x[j * *inc]);
|
||||
strcat(mess,num);
|
||||
}
|
||||
strcat(mess,"\n");
|
||||
Warning(mess,NULL_ENTRY);
|
||||
}
|
||||
2198
pmsco/loess/loessf.f
Normal file
2198
pmsco/loess/loessf.f
Normal file
File diff suppressed because it is too large
Load Diff
201
pmsco/loess/loessf.m
Normal file
201
pmsco/loess/loessf.m
Normal file
@ -0,0 +1,201 @@
|
||||
***************************************************************
|
||||
* LOESS smoothing scattered data in one or more variables *
|
||||
* documentation of Fortran routines *
|
||||
* Cleveland, Devlin, Grosse, Shyu *
|
||||
***************************************************************
|
||||
|
||||
1. The typical program would call lowesd, set tolerances in iv,v if
|
||||
desired, then call lowesb and lowese.
|
||||
2. To save the k-d tree, call lowesd, lowesb and then losave; subsequent
|
||||
programs would call lohead, set liv and lv, then call loread and lowese.
|
||||
3. For statistics, get diagL and then call lowesa or get the full hat
|
||||
matrix and call lowesc. Robustness iterations can take advantage of
|
||||
lowesw and lowesp.
|
||||
|
||||
lowesd(106,iv,liv,lv,v,d,n,f,tdeg,nvmax,setLf) setup workspace
|
||||
lowesf(x,y,w,iv,liv,lv,v,m,z,L,hat,s) slow smooth at z
|
||||
lowesb(x,y,w,diagL,infl,iv,liv,lv,v) build k-d tree
|
||||
lowesr(y,iv,liv,lv,v) rebuild with new data values
|
||||
(does not change y)
|
||||
lowese(iv,liv,lv,v,m,z, s) evaluate smooth at z
|
||||
lowesl(iv,liv,lv,v,m,z, L) explicit hat matrix,
|
||||
which maps from y to z
|
||||
lofort(iunit,iv,liv,lv,v) save k-d tree as Fortran
|
||||
losave(iunit,iv,liv,lv,v) save k-d tree in file
|
||||
lohead(iunit,d,vc,nc,nv) read d,vc,nc,nv from file
|
||||
liv = 50+(vc+3)*nc determine space
|
||||
lv = 50+(2*d+1)*nv+nc requirements
|
||||
loread(iunit,d,vc,nc,nv,iv,liv,lv,v) finish reading k-d tree,
|
||||
ready for lowese
|
||||
lowesa(trL,n,d,tau,nsing, del1,del2) approximate delta
|
||||
lowesc(n,L,LL, trL,del1,del2) exact delta
|
||||
lowesp(n,y,yhat,w,rw, pi,ytilde) pseudo-values
|
||||
lowesw(res,n, rw,pi) robustness weights
|
||||
|
||||
=== arguments ===
|
||||
d number of independent variables [integer] (called "p" elsewhere)
|
||||
del1,del2 delta1, delta2
|
||||
diagL diagonal of hat matrix, only set if infl=.true. (n)
|
||||
f fraction of points to use in local smooth (called "alpha" elsewhere)
|
||||
fc don't refine cells with less than fc*n points; ordinarily=.05
|
||||
hat is hat matrix desired? [integer]
|
||||
0 = none
|
||||
1 = diagonal only
|
||||
2 = full matrix
|
||||
infl is diagonal of hat matrix desired? [logical]
|
||||
iunit Fortran unit number for i/o
|
||||
iv workspace (liv)
|
||||
L hat matrix (m,n) [real]
|
||||
in lowesf, only computed if hat nonzero; if hat=1 only size (n)
|
||||
LL workspace (n,n)
|
||||
liv 50+(2^d+4)*nvmax+2*n
|
||||
if setLf, add nf*nvmax
|
||||
lv 50+(3*d+3)*nvmax+n+(tau0+2)*nf
|
||||
if setLf, add (d+1)*nf*nvmax
|
||||
m number of points to smooth at; ordinarily=n
|
||||
n number of observations
|
||||
nf min(n,floor(n*f))
|
||||
nsing if 0, print warning in lowesa when trL<tau; typically nsing=iv(30)
|
||||
nvmax limit on number of vertices for kd-tree; e.g. max(200,n)
|
||||
pi workspace (n) [integer]
|
||||
res residual yhat-y (n)
|
||||
rw robustness weights (n)
|
||||
s smoothed values at z (m)
|
||||
setLf in lowesb, save matrix factorizations [logical]
|
||||
(needed for lowesr and lowesl)
|
||||
tau dimension of local model = iv(DIM);
|
||||
=d+1 for linear, (d+2)(d+1)/2 for quadratic
|
||||
reduced if dropping squares
|
||||
tau0 =d+1 for linear, (d+2)(d+1)/2 for quadratic
|
||||
tdeg polynomials to fit; 0=constants, 1=linear, 2=quadratics
|
||||
trL trace L = sum diagL
|
||||
v workspace (lv)
|
||||
w weights (n) local regression: min sum wi * (f(xi)-yi)^2
|
||||
x sample locations (n,d)
|
||||
y observations (n)
|
||||
yhat smoothed y (n)
|
||||
ytilde pseudo y (n)
|
||||
z locations where smooth is desired (m,d)
|
||||
|
||||
If using the double precision version, [real] above should be understood
|
||||
as Fortran "double precision".
|
||||
|
||||
The first argument to lowesd is a version number, updated when calling
|
||||
sequences change.
|
||||
|
||||
If you peek inside the fortran, you will quickly notice that it
|
||||
was machine generated; the typeset original (in the language "pine")
|
||||
is much easier to read.
|
||||
|
||||
=== iv indices ===
|
||||
1 INFO return code (not currently used)
|
||||
2 D number of independent variables
|
||||
3 N number of observations
|
||||
4 VC 2^d (number of vertices of a cell)
|
||||
5 NC number of k-d cells
|
||||
6 NV number of k-d vertices
|
||||
7 A1 starting index in iv of a
|
||||
8 C1 starting index in iv of c
|
||||
9 HI1 starting index in iv of hi
|
||||
10 LO1 starting index in iv of lo
|
||||
11 V1 starting index in v of vertices
|
||||
12 XI1 starting index in v of cut values
|
||||
13 VV1 starting index in v of vertex values
|
||||
14 NVMAX maximum allowed value of nv
|
||||
15 WORK1 starting index in v of workspace
|
||||
16 WORK2 starting index in v of workspace
|
||||
17 NCMAX maximum allowed value of nc
|
||||
18 WORK3 starting index in v of workspace
|
||||
19 NF floor(n*f) (number of points used as neighborhood)
|
||||
20 KERNEL 1=tricube, 2=unif
|
||||
21 KIND 1=k-d,cubic blend, (not implemented:2=quadtree,3=triangulation)
|
||||
22 PI1 starting index in iv of tree permutation
|
||||
23 VH starting index in iv of vhit
|
||||
24 VV2 starting index in v of work vval used in trL computation
|
||||
25 LQ starting index in iv of Lq
|
||||
26 WORK4 starting index in v of workspace
|
||||
27 PSI1 starting index in iv of workspace permutation
|
||||
28 SEQ sequence number, to check if routines called out of order
|
||||
takes on values:
|
||||
171 after lowesd
|
||||
172 after lowesf
|
||||
173 after lowesb
|
||||
29 DIM dimension of local regression
|
||||
1 constant
|
||||
d+1 linear (default)
|
||||
(d+2)(d+1)/2 quadratic
|
||||
Modified by ehg127 if cdeg<tdeg.
|
||||
30 SING number of times singular tolerance was met in l2fit, l2tr
|
||||
31 PRINT verbose output?
|
||||
32 DEG total degree (of polynomial for local model)
|
||||
33 NDIST dd = variables 1:dd enter into distance calculation
|
||||
34 LF starting index in v of Lf
|
||||
35..40 reserved for future use
|
||||
41..49 CDEG componentwise degree
|
||||
iv(A1) a coordinate of cut; 0 for leaf (nc)
|
||||
iv(C1) c pointers to corners (index into vertex array v) (vc,nc)
|
||||
iv(HI1) hi right subcell (nc)
|
||||
iv(LO1) lo left subcell (nc)
|
||||
Leaf cell j encloses points x(pi(i),), lo(j)<=i<=hi(j).
|
||||
Also, iv(C1),...,iv(PI1-1) is used as workspace (t) by l2fit
|
||||
------------------------eval only needs workspace up to here
|
||||
iv(PI1) pi permutation of 1:n for listing points in cells
|
||||
iv(VH) vhit cell whose subdivision creates vertex (nv)
|
||||
0 if vertex is corner of original bounding box.
|
||||
iv(LQ) Lq active point indices for block of Lf (nvmax*nf)
|
||||
iv(PSI1) psi workspace permutation of 1:n for sorting distances
|
||||
|
||||
=== v indices ===
|
||||
1 F fraction of n to be used as neighborhood. See also iv(19).
|
||||
2 FCELL no refinement if #points <= fcell * n
|
||||
default .05
|
||||
3 FDIAM no refinement if diameter is fdiam * overall bounding box
|
||||
default 0; Warning: reset to 0 by ehg142 when nsteps>0.
|
||||
4 RCOND reciprocal condition number
|
||||
... 49 reserved for future use
|
||||
iv(V1) v vertices (nv,d)
|
||||
iv(VV1) vval vertex values (0:d,nv)
|
||||
iv(XI1) xi cut values (nc)
|
||||
------------------------eval only needs workspace up to here
|
||||
iv(WORK1) workspace (n) l2fit:dist
|
||||
iv(WORK2) workspace (nf) l2fit:eta
|
||||
iv(WORK3) workspace (dim,nf) l2fit:X
|
||||
iv(VV2) vval2 workspace ((d+1)*nv) pseudo-vval for trL computation
|
||||
iv(LF) Lf hat matrix (data to vertex) ((d+1)*nvmax*nf)
|
||||
iv(WORK4) workspace (nf) l2fit:w
|
||||
|
||||
Internal routine names have been hidden as follows:
|
||||
ehg106 select q-th smallest by partial sorting
|
||||
ehg124 rbuild
|
||||
ehg125 cpvert
|
||||
ehg126 bbox
|
||||
ehg127 l2fit,l2tr computational kernel
|
||||
ehg128 eval
|
||||
ehg129 spread
|
||||
ehg131 lowesb after workspace expansion
|
||||
ehg133 lowese after workspace expansion
|
||||
ehg134 abort by calling S Recover function
|
||||
ehg136 l2fit with hat matrix L
|
||||
ehg137 vleaf
|
||||
ehg138 descend
|
||||
ehg139 l2tr
|
||||
ehg140(w,i,j) w(i)=j used when w is declared real, but should store an int
|
||||
ehg141 delta1,2 from trL
|
||||
ehg142 robust iteration
|
||||
ehg144 now called lowesc
|
||||
ehg152 like ehg142, but for lowesf
|
||||
ehg167 kernel for losave
|
||||
ehg168 kernel for loread
|
||||
ehg169 compute derived k-d tree information
|
||||
ehg170 generate Fortran
|
||||
ehg176,ehg177,ehg178,ehg179,ehg180,ehg181 loeval for delta
|
||||
ehg182 ehgdie(i)
|
||||
ehg183 warning(message,i,n,inc)
|
||||
ehg184 warning(message,x,n,inc)
|
||||
ehg190 now called lowesa, with slight change in calling sequence
|
||||
ehg191 lowesl after workspace expansion
|
||||
ehg192 lowesr after workspace expansion
|
||||
ehg196(tau,d,f,trl) trL approximation
|
||||
ehg197 for deg=1,2
|
||||
m9rwt now called lowesw
|
||||
pseudo now called lowesp
|
||||
172
pmsco/loess/madeup.c
Normal file
172
pmsco/loess/madeup.c
Normal file
@ -0,0 +1,172 @@
|
||||
#include <stdio.h>
|
||||
#include "loess.h"
|
||||
|
||||
struct loess_struct madeup, madeup_new, madeup2;
|
||||
struct pred_struct madeup_pred;
|
||||
struct ci_struct madeup_ci;
|
||||
struct anova_struct madeup_anova;
|
||||
double one_two[] = {-0.957581198938384, -2.80954937859791, -0.696510845605909,
|
||||
3.45100038854536, 0.509259838818042, 0.557854035598286,
|
||||
0.0525817201002309, -2.05064423770094, -1.11567547099143,
|
||||
-1.18366549451658, 0.511958575232253, 0.334364244817592,
|
||||
-2.05706205756846, -0.121896645718402, 0.54423804521097,
|
||||
0.600501641888935, 0.531074442421607, 0.495400347786053,
|
||||
-1.60860176347294, 0.277370954937718, 0.290464363258084,
|
||||
0.579894254111128, -0.290441177117614, 1.30622601704777,
|
||||
-0.482897816720494, -0.716423394441349, 0.742412540254878,
|
||||
-0.91161346344296, 1.27943556865527, -0.189153217811851,
|
||||
0.592292730243945, 0.952415888511291, 0.491436176457309,
|
||||
-0.30568088056691, -0.363871357644093, -0.285424162901343,
|
||||
-0.0372094292657342, -0.923529247741133, 1.13805430719146,
|
||||
-1.33122338081553, 0.55123448290722, -0.852726057929887,
|
||||
1.19687530878469, 0.498781686408254, 0.320179856418398,
|
||||
0.21244678210441, 1.00935803951191, -0.900989007058962,
|
||||
1.13216444413294, 0.0188670824356362, 0.424169515300288,
|
||||
-0.19862121711326, 0.955170163539181, 0.948320512371124,
|
||||
0.473848149342783, -0.699121305560135, -0.612853026250685,
|
||||
0.580431200426044, 1.27799640925722, 0.806797458367235,
|
||||
-1.03855925707748, 1.00866312622584, -0.578256568822387,
|
||||
-0.323244575961333, -0.756301997657156, 1.38635211208482,
|
||||
0.722419488760045, -1.2160777034384, -0.498279906600592,
|
||||
0.726247405185, -0.260119271608589, -0.741134528045221,
|
||||
-0.184110574491516, 0.307761674659839, 0.464568227698959,
|
||||
-0.25253136951752, -0.486503680414154, 0.426634057655542,
|
||||
-1.30396915580526, 0.0671486396913438, 1.77117635735777,
|
||||
0.907249468179712, 0.432349548721498, 1.41989705188111,
|
||||
-0.413389471016361, 2.44202481656431, 0.0411377482323225,
|
||||
0.509505377681864, -0.282743502058313, 0.179881630718384,
|
||||
-1.18808328118875, 0.98265314676344, -1.04288590077335,
|
||||
1.18136543233696, -0.398339818481707, -1.33556478800344,
|
||||
-0.502789555455575, 0.484761653956289, -0.806445812279308,
|
||||
1.41207651978306, -0.878873945799123, -0.935197083131863,
|
||||
-0.33925477332393439, 0.16449721487453731, 1.3700178698345999,
|
||||
-1.4946841727166, 1.3805047732704381,
|
||||
0.88508389905048512, 0.83560940141892148, 0.89623509727336315,
|
||||
-1.289541425794579, 0.2332028995229195, 1.183197522953588,
|
||||
-0.85793361589157902, -1.33423445483833, -0.9233512315474407,
|
||||
0.76914556896670361, -0.37794794349382183, 0.059114341211622581,
|
||||
-1.8706153553475069, -0.67786838062170507, 0.038184754648735768,
|
||||
0.37530087746353391, 0.96471695952212921, 0.69505105492152874,
|
||||
-0.34214020737803602, -1.1454631827640021, -0.99324551114161375,
|
||||
-0.13057284978088679, 1.213711380869505, 0.29124075688915307,
|
||||
1.106890512068581, 0.94957063346615733, 0.46367541051066768,
|
||||
0.45572327290248621, 0.39878553409592049, -0.015849431703916221,
|
||||
-1.3973725035064171, 0.7700624622976332, 0.083291190129894818,
|
||||
0.53179773252409901, 0.049727349788233177, -0.73414037626738005,
|
||||
-0.96348659055127073, 0.57356064323574374, -0.28194211032947131,
|
||||
-0.59450289683584279, 0.77026173196827941, 1.0739830028467161,
|
||||
-0.61570603602075391, -0.084794357704615464, -0.49163022652120109,
|
||||
-1.526968705617602, -0.19688130817103111, 0.1656534453607213,
|
||||
0.19835657518696179, 0.97492977599052544, -0.95484796495550817,
|
||||
0.58847390467129868, -0.42688317000127768, 0.1771186872105201,
|
||||
-0.91644209647809238, -1.8851386926119349, 0.086893856222760746,
|
||||
0.45630642515021741, 0.17428542070878469, -0.0013077214871275221,
|
||||
-0.00058541929918550742, 0.28402285608099398, -0.36567881757010029,
|
||||
-0.54886653165173238, 0.8578476816688223, 0.69909448655308448,
|
||||
-0.14002628501260239, 1.332454137144605, 1.6017946938719501,
|
||||
0.01241549637061686, 0.24342918633361621, 1.0773689561938919,
|
||||
1.8592463357601141, 0.18590984985424869, 0.033342258305766252,
|
||||
0.6130082357970067, 1.068594886375418, -0.68330464261374424,
|
||||
-0.12882583544682871, -1.6555248021907429, 0.013086014377651681,
|
||||
0.062454455755349927, 0.77304176654886514, 0.12704646649909671,
|
||||
0.40865153244567209, 1.195437623807228, -0.18555786800092541,
|
||||
-1.299714084101439, 0.89967540292281434, -0.033647925669371137,
|
||||
-1.5446015243088369, 0.65520298400478949, -0.71393501757996425};
|
||||
double response[] = {14.4535533874191, 6.62282520910778, 13.6714139876233,
|
||||
14.1975175236874, 12.8605301149348, 12.5228556826206, 14.2146384581959,
|
||||
7.9242642010286, 12.5069380013745, 13.7342047122325, 14.7108554131065,
|
||||
13.5962229304995, 5.89001909002711, 13.5586535685782, 14.0431671811957,
|
||||
13.9313910018427, 13.2189198447833, 17.0905598230825, 15.1993220372035,
|
||||
13.2616669404325, 15.7606359467964, 12.0838552528602, 14.344906985408,
|
||||
12.6094936116173, 11.9329594317628, 13.4086741328164, 13.7007653532941,
|
||||
13.0133656112894, 15.794998892751, 14.600198458049, 16.2757508936254,
|
||||
11.5643493993645, 14.8090225170414, 12.9823612913134, 15.003502495484,
|
||||
14.7373366435951, 15.7476765061616, 11.6745084114309, 14.047278212178,
|
||||
14.6669170934119, 13.8062403198314, 13.6111487435938, 13.3471486192318,
|
||||
14.2251519152709, 14.7188461068404, 14.2172164843947, 14.4180584862351,
|
||||
14.7196335400403, 12.799715984732, 13.9330377247579, 15.2646032349699,
|
||||
14.6603872891079, 9.73869078623634, 14.4434243169553, 14.4172837909381,
|
||||
15.1845379738711, 13.3449384473427, 15.3729427547467, 13.8115544407009,
|
||||
15.103777322749, 15.3838341258708, 14.368611819712, 12.525202176137,
|
||||
14.3250330647389, 15.2596577477861, 13.0045474727206, 14.515987797507,
|
||||
15.176981889542, 14.9241874861469, 13.872430121229, 15.3953655496863,
|
||||
13.4280761187509, 15.2034304536162, 14.1866308929129, 13.3058326261246,
|
||||
14.0746238485616, 14.1030921763152, 13.49966901054, 11.5846746059002,
|
||||
14.2648911116312, 14.88561614061, 13.9672969505607, 16.604679813678,
|
||||
10.3676055239145, 14.7434725924834, 16.3088265042892, 14.1086733681544,
|
||||
13.5909878288487, 14.6745463058857, 15.2940472804827, 14.6867226502357,
|
||||
13.6114224063955, 11.9702698734486, 13.8841573398, 15.0717757159234,
|
||||
12.5898155750775, 13.8187450898422, 14.2453171289186, 14.4065299197652,
|
||||
14.3479407847109};
|
||||
double newdata1[] = {-2.5, 0., 2.5, 0., 0., 0.};
|
||||
double newdata2[] = {-0.5, 0.5, 0., 0.};
|
||||
double coverage = .99;
|
||||
int n = 100, p = 2, m = 3, se_fit = FALSE;
|
||||
int i;
|
||||
|
||||
main() {
|
||||
printf("\nloess(&madeup):\n");
|
||||
loess_setup(one_two, response, n, p, &madeup);
|
||||
madeup.model.span = 0.5;
|
||||
loess(&madeup);
|
||||
loess_summary(&madeup);
|
||||
|
||||
printf("\nloess(&madeup_new):\n");
|
||||
loess_setup(one_two, response, n, p, &madeup_new);
|
||||
madeup_new.model.span = 0.8;
|
||||
madeup_new.model.drop_square[0] = TRUE;
|
||||
madeup_new.model.parametric[0] = TRUE;
|
||||
loess(&madeup_new);
|
||||
loess_summary(&madeup_new);
|
||||
|
||||
printf("\nloess(&madeup_new) (family = symmetric):\n");
|
||||
madeup_new.model.family = "symmetric";
|
||||
loess(&madeup_new);
|
||||
loess_summary(&madeup_new);
|
||||
|
||||
printf("\nloess(&madeup_new) (normalize = FALSE):\n");
|
||||
madeup_new.model.normalize = FALSE;
|
||||
loess(&madeup_new);
|
||||
loess_summary(&madeup_new);
|
||||
|
||||
printf("\npredict(newdata1, m, &madeup, &madeup_pred, %d):\n", se_fit);
|
||||
predict(newdata1, m, &madeup, &madeup_pred, se_fit);
|
||||
printf("%g %g %g\n", madeup_pred.fit[0],
|
||||
madeup_pred.fit[1], madeup_pred.fit[2]);
|
||||
|
||||
m = 2;
|
||||
se_fit = TRUE;
|
||||
printf("\npredict(newdata2, m, &madeup, &madeup_pred, %d):\n", se_fit);
|
||||
predict(newdata2, m, &madeup, &madeup_pred, se_fit);
|
||||
printf("%g %g\n", madeup_pred.fit[0], madeup_pred.fit[1]);
|
||||
printf("%g %g\n", madeup_pred.se_fit[0], madeup_pred.se_fit[1]);
|
||||
printf("%g\n", madeup_pred.residual_scale);
|
||||
printf("%g\n", madeup_pred.df);
|
||||
|
||||
printf("\npointwise(&madeup_pred, m, coverage, &madeup_ci):\n");
|
||||
pointwise(&madeup_pred, m, coverage, &madeup_ci);
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", madeup_ci.upper[i]);
|
||||
printf("\n");
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", madeup_ci.fit[i]);
|
||||
printf("\n");
|
||||
for(i = 0; i < m; i++)
|
||||
printf("%g ", madeup_ci.lower[i]);
|
||||
printf("\n");
|
||||
|
||||
loess_setup(one_two, response, n, p, &madeup2);
|
||||
madeup2.model.span = 0.75;
|
||||
loess(&madeup2);
|
||||
|
||||
printf("\nanova(&madeup2, &madeup, &madeup_anova):\n");
|
||||
anova(&madeup2, &madeup, &madeup_anova);
|
||||
printf("%g %g %g %g\n", madeup_anova.dfn, madeup_anova.dfd,
|
||||
madeup_anova.F_value, madeup_anova.Pr_F);
|
||||
|
||||
loess_free_mem(&madeup);
|
||||
loess_free_mem(&madeup2);
|
||||
loess_free_mem(&madeup_new);
|
||||
pred_free_mem(&madeup_pred);
|
||||
pw_free_mem(&madeup_ci);
|
||||
}
|
||||
77
pmsco/loess/makefile
Normal file
77
pmsco/loess/makefile
Normal file
@ -0,0 +1,77 @@
|
||||
SHELL=/bin/sh
|
||||
|
||||
# makefile for the LOESS module
|
||||
#
|
||||
# required libraries: libblas, liblapack, libf2c
|
||||
# (you may have to set soft links so that linker finds them)
|
||||
#
|
||||
# see the top-level makefile for additional information.
|
||||
|
||||
.SUFFIXES:
|
||||
.SUFFIXES: .c .cpp .cxx .exe .f .h .i .o .py .pyf .so .x
|
||||
.PHONY: all loess test gas madeup ethanol air galaxy
|
||||
|
||||
HOST=$(shell hostname)
|
||||
CFLAGS=-O
|
||||
FFLAGS=-O
|
||||
OBJ=loessc.o loess.o predict.o misc.o loessf.o dqrsl.o dsvdc.o fix_main.o
|
||||
LIB=-lblas -lm -lf2c
|
||||
LIBPATH=
|
||||
CC=gcc
|
||||
CCOPTS=
|
||||
SWIG=swig
|
||||
SWIGOPTS=
|
||||
PYTHON=python
|
||||
PYTHONOPTS=
|
||||
ifneq (,$(filter merlin%,$(HOST)))
|
||||
PYTHONINC=-I/usr/include/python2.7 -I/opt/python/python-2.7.5/include/python2.7/
|
||||
else ifneq (,$(filter ra%,$(HOST)))
|
||||
PYTHONINC=-I${PSI_PYTHON27_INCLUDE_DIR}/python2.7 -I${PSI_PYTHON27_LIBRARY_DIR}/python2.7/site-packages/numpy/core/include
|
||||
else
|
||||
PYTHONINC=-I/usr/include/python2.7
|
||||
endif
|
||||
|
||||
all: loess
|
||||
|
||||
loess: _loess.so
|
||||
|
||||
loess_wrap.c: loess.c loess.i
|
||||
$(SWIG) $(SWIGOPTS) -python loess.i
|
||||
|
||||
loess.py _loess.so: loess_wrap.c
|
||||
# setuptools doesn't handle the fortran files correctly
|
||||
# $(PYTHON) $(PYTHONOPTS) setup.py build_ext --inplace
|
||||
$(CC) $(CFLAGS) -fpic -c loessc.c loess.c predict.c misc.c loessf.f dqrsl.f dsvdc.f fix_main.c
|
||||
$(CC) $(CFLAGS) -fpic -c loess_wrap.c $(PYTHONINC)
|
||||
$(CC) -shared $(OBJ) $(LIB) $(LIBPATH) loess_wrap.o -o _loess.so
|
||||
|
||||
examples: gas madeup ethanol air galaxy
|
||||
|
||||
gas: gas.x
|
||||
|
||||
gas.x: gas.o $(OBJ)
|
||||
$(CC) -o gas.x gas.o $(OBJ) $(LIB)
|
||||
|
||||
madeup: madeup.x
|
||||
|
||||
madeup.x: madeup.o $(OBJ)
|
||||
$(CC) -o madeup.x madeup.o $(OBJ) $(LIB)
|
||||
|
||||
ethanol: ethanol.x
|
||||
|
||||
ethanol.x: ethanol.o $(OBJ)
|
||||
$(CC) -o ethanol.x ethanol.o $(OBJ) $(LIB)
|
||||
|
||||
air: air.x
|
||||
|
||||
air.x: air.o $(OBJ)
|
||||
$(CC) -o air.x air.o $(OBJ) $(LIB)
|
||||
|
||||
galaxy: galaxy.x
|
||||
|
||||
galaxy.x: galaxy.o $(OBJ)
|
||||
$(CC) -o galaxy.x galaxy.o $(OBJ) $(LIB)
|
||||
|
||||
clean:
|
||||
rm -f *.o *.so *.x core *.pyc
|
||||
rm -f loess.py loess_wrap.c
|
||||
349
pmsco/loess/misc.c
Normal file
349
pmsco/loess/misc.c
Normal file
@ -0,0 +1,349 @@
|
||||
#include "S.h"
|
||||
#include "loess.h"
|
||||
|
||||
/* If your compiler is so ancient it doesn't recognize void, say
|
||||
#define void
|
||||
*/
|
||||
|
||||
void
|
||||
anova(one, two, out)
|
||||
struct loess_struct *one, *two;
|
||||
struct anova_struct *out;
|
||||
{
|
||||
double one_d1, one_d2, one_s, two_d1, two_d2, two_s,
|
||||
rssdiff, d1diff, tmp, pf();
|
||||
int max_enp;
|
||||
|
||||
one_d1 = one->out.one_delta;
|
||||
one_d2 = one->out.two_delta;
|
||||
one_s = one->out.s;
|
||||
two_d1 = two->out.one_delta;
|
||||
two_d2 = two->out.two_delta;
|
||||
two_s = two->out.s;
|
||||
|
||||
rssdiff = fabs(one_s * one_s * one_d1 - two_s * two_s * two_d1);
|
||||
d1diff = fabs(one_d1 - two_d1);
|
||||
out->dfn = d1diff * d1diff / fabs(one_d2 - two_d2);
|
||||
max_enp = (one->out.enp > two->out.enp);
|
||||
tmp = max_enp ? one_d1 : two_d1;
|
||||
out->dfd = tmp * tmp / (max_enp ? one_d2 : two_d2);
|
||||
tmp = max_enp ? one_s : two_s;
|
||||
out->F_value = (rssdiff / d1diff) / (tmp * tmp);
|
||||
out->Pr_F = 1 - pf(out->F_value, out->dfn, out->dfd);
|
||||
}
|
||||
|
||||
void
|
||||
pointwise(pre, m, coverage, ci)
|
||||
struct pred_struct *pre;
|
||||
int m;
|
||||
double coverage;
|
||||
struct ci_struct *ci;
|
||||
{
|
||||
double t_dist, limit, fit, qt();
|
||||
int i;
|
||||
|
||||
ci->fit = (double *) malloc(m * sizeof(double));
|
||||
ci->upper = (double *) malloc(m * sizeof(double));
|
||||
ci->lower = (double *) malloc(m * sizeof(double));
|
||||
|
||||
t_dist = qt(1 - (1 - coverage)/2, pre->df);
|
||||
for(i = 0; i < m; i++) {
|
||||
limit = pre->se_fit[i] * t_dist;
|
||||
ci->fit[i] = fit = pre->fit[i];
|
||||
ci->upper[i] = fit + limit;
|
||||
ci->lower[i] = fit - limit;
|
||||
}
|
||||
}
|
||||
|
||||
void
|
||||
pw_free_mem(ci)
|
||||
struct ci_struct *ci;
|
||||
{
|
||||
free(ci->fit);
|
||||
free(ci->upper);
|
||||
free(ci->lower);
|
||||
}
|
||||
|
||||
double
|
||||
pf(q, df1, df2)
|
||||
double q, df1, df2;
|
||||
{
|
||||
double ibeta();
|
||||
|
||||
return(ibeta(q*df1/(df2+q*df1), df1/2, df2/2));
|
||||
}
|
||||
|
||||
double
|
||||
qt(p, df)
|
||||
double p, df;
|
||||
{
|
||||
double t, invibeta();
|
||||
|
||||
t = invibeta(fabs(2*p-1), 0.5, df/2);
|
||||
return((p>0.5?1:-1) * sqrt(t*df/(1-t)));
|
||||
}
|
||||
|
||||
/**********************************************************************/
|
||||
/*
|
||||
* Incomplete beta function.
|
||||
* Reference: Abramowitz and Stegun, 26.5.8.
|
||||
* Assumptions: 0 <= x <= 1; a,b > 0.
|
||||
*/
|
||||
#define DOUBLE_EPS 2.2204460492503131E-16
|
||||
#define IBETA_LARGE 1.0e30
|
||||
#define IBETA_SMALL 1.0e-30
|
||||
|
||||
double
|
||||
ibeta(x, a, b)
|
||||
double x, a, b;
|
||||
{
|
||||
int flipped = 0, i, k, count;
|
||||
double I, temp, pn[6], ak, bk, next, prev, factor, val;
|
||||
|
||||
if (x <= 0)
|
||||
return(0);
|
||||
if (x >= 1)
|
||||
return(1);
|
||||
|
||||
/* use ibeta(x,a,b) = 1-ibeta(1-x,b,a) */
|
||||
if ((a+b+1)*x > (a+1)) {
|
||||
flipped = 1;
|
||||
temp = a;
|
||||
a = b;
|
||||
b = temp;
|
||||
x = 1 - x;
|
||||
}
|
||||
|
||||
pn[0] = 0.0;
|
||||
pn[2] = pn[3] = pn[1] = 1.0;
|
||||
count = 1;
|
||||
val = x/(1.0-x);
|
||||
bk = 1.0;
|
||||
next = 1.0;
|
||||
do {
|
||||
count++;
|
||||
k = count/2;
|
||||
prev = next;
|
||||
if (count%2 == 0)
|
||||
ak = -((a+k-1.0)*(b-k)*val)/
|
||||
((a+2.0*k-2.0)*(a+2.0*k-1.0));
|
||||
else
|
||||
ak = ((a+b+k-1.0)*k*val)/
|
||||
((a+2.0*k)*(a+2.0*k-1.0));
|
||||
pn[4] = bk*pn[2] + ak*pn[0];
|
||||
pn[5] = bk*pn[3] + ak*pn[1];
|
||||
next = pn[4] / pn[5];
|
||||
for (i=0; i<=3; i++)
|
||||
pn[i] = pn[i+2];
|
||||
if (fabs(pn[4]) >= IBETA_LARGE)
|
||||
for (i=0; i<=3; i++)
|
||||
pn[i] /= IBETA_LARGE;
|
||||
if (fabs(pn[4]) <= IBETA_SMALL)
|
||||
for (i=0; i<=3; i++)
|
||||
pn[i] /= IBETA_SMALL;
|
||||
} while (fabs(next-prev) > DOUBLE_EPS*prev);
|
||||
factor = a*log(x) + (b-1)*log(1-x);
|
||||
factor -= gamma(a+1) + gamma(b) - gamma(a+b);
|
||||
I = exp(factor) * next;
|
||||
return(flipped ? 1-I : I);
|
||||
}
|
||||
|
||||
/*
|
||||
* Rational approximation to inverse Gaussian distribution.
|
||||
* Absolute error is bounded by 4.5e-4.
|
||||
* Reference: Abramowitz and Stegun, page 933.
|
||||
* Assumption: 0 < p < 1.
|
||||
*/
|
||||
|
||||
static double num[] = {
|
||||
2.515517,
|
||||
0.802853,
|
||||
0.010328
|
||||
};
|
||||
|
||||
static double den[] = {
|
||||
1.000000,
|
||||
1.432788,
|
||||
0.189269,
|
||||
0.001308
|
||||
};
|
||||
|
||||
double
|
||||
invigauss_quick(p)
|
||||
double p;
|
||||
{
|
||||
int lower;
|
||||
double t, n, d, q;
|
||||
|
||||
if(p == 0.5)
|
||||
return(0);
|
||||
lower = p < 0.5;
|
||||
p = lower ? p : 1 - p;
|
||||
t = sqrt(-2 * log(p));
|
||||
n = (num[2]*t + num[1])*t + num[0];
|
||||
d = ((den[3]*t + den[2])*t + den[1])*t + den[0];
|
||||
q = lower ? n/d - t : t - n/d;
|
||||
return(q);
|
||||
}
|
||||
|
||||
/*
|
||||
* Inverse incomplete beta function.
|
||||
* Assumption: 0 <= p <= 1, a,b > 0.
|
||||
*/
|
||||
|
||||
double
|
||||
invibeta(p, a, b)
|
||||
double p, a, b;
|
||||
{
|
||||
int i;
|
||||
double ql, qr, qm, qdiff;
|
||||
double pl, pr, pm, pdiff;
|
||||
double invibeta_quick(), ibeta();
|
||||
|
||||
/* MEANINGFUL(qm);*/
|
||||
qm = 0;
|
||||
if(p == 0 || p == 1)
|
||||
return(p);
|
||||
|
||||
/* initialize [ql,qr] containing the root */
|
||||
ql = qr = invibeta_quick(p, a, b);
|
||||
pl = pr = ibeta(ql, a, b);
|
||||
if(pl == p)
|
||||
return(ql);
|
||||
if(pl < p)
|
||||
while(1) {
|
||||
qr += 0.05;
|
||||
if(qr >= 1) {
|
||||
pr = qr = 1;
|
||||
break;
|
||||
}
|
||||
pr = ibeta(qr, a, b);
|
||||
if(pr == p)
|
||||
return(pr);
|
||||
if(pr > p)
|
||||
break;
|
||||
}
|
||||
else
|
||||
while(1) {
|
||||
ql -= 0.05;
|
||||
if(ql <= 0) {
|
||||
pl = ql = 0;
|
||||
break;
|
||||
}
|
||||
pl = ibeta(ql, a, b);
|
||||
if(pl == p)
|
||||
return(pl);
|
||||
if(pl < p)
|
||||
break;
|
||||
}
|
||||
|
||||
/* a few steps of bisection */
|
||||
for(i = 0; i < 5; i++) {
|
||||
qm = (ql + qr) / 2;
|
||||
pm = ibeta(qm, a, b);
|
||||
qdiff = qr - ql;
|
||||
pdiff = pm - p;
|
||||
if(fabs(qdiff) < DOUBLE_EPS*qm || fabs(pdiff) < DOUBLE_EPS)
|
||||
return(qm);
|
||||
if(pdiff < 0) {
|
||||
ql = qm;
|
||||
pl = pm;
|
||||
} else {
|
||||
qr = qm;
|
||||
pr = pm;
|
||||
}
|
||||
}
|
||||
|
||||
/* a few steps of secant */
|
||||
for(i = 0; i < 40; i++) {
|
||||
qm = ql + (p-pl)*(qr-ql)/(pr-pl);
|
||||
pm = ibeta(qm, a, b);
|
||||
qdiff = qr - ql;
|
||||
pdiff = pm - p;
|
||||
if(fabs(qdiff) < 2*DOUBLE_EPS*qm || fabs(pdiff) < 2*DOUBLE_EPS)
|
||||
return(qm);
|
||||
if(pdiff < 0) {
|
||||
ql = qm;
|
||||
pl = pm;
|
||||
} else {
|
||||
qr = qm;
|
||||
pr = pm;
|
||||
}
|
||||
}
|
||||
|
||||
/* no convergence */
|
||||
return(qm);
|
||||
}
|
||||
|
||||
/*
|
||||
* Quick approximation to inverse incomplete beta function,
|
||||
* by matching first two moments with the Gaussian distribution.
|
||||
* Assumption: 0 < p < 1, a,b > 0.
|
||||
*/
|
||||
|
||||
static double
|
||||
misc_fmin(a, b)
|
||||
double a, b;
|
||||
{
|
||||
return(a < b ? a : b);
|
||||
}
|
||||
|
||||
static double
|
||||
misc_fmax(a, b)
|
||||
double a, b;
|
||||
{
|
||||
return(a > b ? a : b);
|
||||
}
|
||||
|
||||
double
|
||||
invibeta_quick(p, a, b)
|
||||
double p, a, b;
|
||||
{
|
||||
double x, m, s, invigauss_quick();
|
||||
|
||||
x = a + b;
|
||||
m = a / x;
|
||||
s = sqrt((a*b) / (x*x*(x+1)));
|
||||
return(misc_fmax(0.0, misc_fmin(1.0, invigauss_quick(p)*s + m)));
|
||||
}
|
||||
|
||||
typedef double doublereal;
|
||||
typedef int integer;
|
||||
|
||||
void
|
||||
Recover(a, b)
|
||||
char *a;
|
||||
int *b;
|
||||
{
|
||||
printf(a,b);
|
||||
exit(1);
|
||||
}
|
||||
|
||||
void
|
||||
Warning(a, b)
|
||||
char *a;
|
||||
int *b;
|
||||
{
|
||||
printf(a,b);
|
||||
}
|
||||
|
||||
/* d1mach may be replaced by Fortran code:
|
||||
mail netlib@netlib.bell-labs.com
|
||||
send d1mach from core.
|
||||
*/
|
||||
|
||||
#include <float.h>
|
||||
|
||||
doublereal F77_SUB(d1mach) (i)
|
||||
integer *i;
|
||||
{
|
||||
switch(*i){
|
||||
case 1: return DBL_MIN;
|
||||
case 2: return DBL_MAX;
|
||||
case 3: return DBL_EPSILON/FLT_RADIX;
|
||||
case 4: return DBL_EPSILON;
|
||||
case 5: return log10(FLT_RADIX);
|
||||
default: Recover("Invalid argument to d1mach()", 0L);
|
||||
}
|
||||
}
|
||||
|
||||
3161
pmsco/loess/numpy.i
Normal file
3161
pmsco/loess/numpy.i
Normal file
File diff suppressed because it is too large
Load Diff
175
pmsco/loess/predict.c
Normal file
175
pmsco/loess/predict.c
Normal file
@ -0,0 +1,175 @@
|
||||
#include "S.h"
|
||||
#include "loess.h"
|
||||
|
||||
void
|
||||
predict(eval, m, lo, pre, se)
|
||||
double *eval;
|
||||
int m, se;
|
||||
struct loess_struct *lo;
|
||||
struct pred_struct *pre;
|
||||
{
|
||||
int size_info[3];
|
||||
void pred_();
|
||||
|
||||
pre->fit = (double *) malloc(m * sizeof(double));
|
||||
pre->se_fit = (double *) malloc(m * sizeof(double));
|
||||
pre->residual_scale = lo->out.s;
|
||||
pre->df = (lo->out.one_delta * lo->out.one_delta) / lo->out.two_delta;
|
||||
|
||||
size_info[0] = lo->in.p;
|
||||
size_info[1] = lo->in.n;
|
||||
size_info[2] = m;
|
||||
|
||||
pred_(lo->in.y, lo->in.x, eval, size_info, &lo->out.s,
|
||||
lo->in.weights,
|
||||
lo->out.robust,
|
||||
&lo->model.span,
|
||||
&lo->model.degree,
|
||||
&lo->model.normalize,
|
||||
lo->model.parametric,
|
||||
lo->model.drop_square,
|
||||
&lo->control.surface,
|
||||
&lo->control.cell,
|
||||
&lo->model.family,
|
||||
lo->kd_tree.parameter,
|
||||
lo->kd_tree.a,
|
||||
lo->kd_tree.xi,
|
||||
lo->kd_tree.vert,
|
||||
lo->kd_tree.vval,
|
||||
lo->out.divisor,
|
||||
&se,
|
||||
pre->fit,
|
||||
pre->se_fit);
|
||||
}
|
||||
|
||||
void
|
||||
pred_(y, x_, new_x, size_info, s, weights, robust, span, degree,
|
||||
normalize, parametric, drop_square, surface, cell, family,
|
||||
parameter, a, xi, vert, vval, divisor, se, fit, se_fit)
|
||||
double *y, *x_, *new_x, *weights, *robust, *span, *cell, *fit, *s,
|
||||
*xi, *vert, *vval, *divisor, *se_fit;
|
||||
int *size_info, *degree, *normalize, *parametric, *drop_square,
|
||||
*parameter, *a, *se;
|
||||
char **surface, **family;
|
||||
{
|
||||
double *x, *x_tmp, *x_evaluate, *L, new_cell, z, tmp, *fit_tmp,
|
||||
*temp, sum, mean;
|
||||
int N, D, M, sum_drop_sqr = 0, sum_parametric = 0,
|
||||
nonparametric = 0, *order_parametric, *order_drop_sqr;
|
||||
int i, j, k, p, cut, comp();
|
||||
|
||||
D = size_info[0];
|
||||
N = size_info[1];
|
||||
M = size_info[2];
|
||||
|
||||
x = (double *) malloc(N * D * sizeof(double));
|
||||
x_tmp = (double *) malloc(N * D * sizeof(double));
|
||||
x_evaluate = (double *) malloc(M * D * sizeof(double));
|
||||
L = (double *) malloc(N * M * sizeof(double));
|
||||
order_parametric = (int *) malloc(D * sizeof(int));
|
||||
order_drop_sqr = (int *) malloc(D * sizeof(int));
|
||||
temp = (double *) malloc(N * D * sizeof(double));
|
||||
|
||||
for(i = 0; i < (N * D); i++)
|
||||
x_tmp[i] = x_[i];
|
||||
for(i = 0; i < D; i++) {
|
||||
k = i * M;
|
||||
for(j = 0; j < M; j++) {
|
||||
p = k + j;
|
||||
new_x[p] = new_x[p] / divisor[i];
|
||||
}
|
||||
}
|
||||
if(!strcmp(*surface, "direct") || se) {
|
||||
for(i = 0; i < D; i++) {
|
||||
k = i * N;
|
||||
for(j = 0; j < N; j++) {
|
||||
p = k + j;
|
||||
x_tmp[p] = x_[p] / divisor[i];
|
||||
}
|
||||
}
|
||||
}
|
||||
j = D - 1;
|
||||
for(i = 0; i < D; i++) {
|
||||
sum_drop_sqr = sum_drop_sqr + drop_square[i];
|
||||
sum_parametric = sum_parametric + parametric[i];
|
||||
if(parametric[i])
|
||||
order_parametric[j--] = i;
|
||||
else
|
||||
order_parametric[nonparametric++] = i;
|
||||
}
|
||||
for(i = 0; i < D; i++) {
|
||||
order_drop_sqr[i] = 2 - drop_square[order_parametric[i]];
|
||||
k = i * M;
|
||||
p = order_parametric[i] * M;
|
||||
for(j = 0; j < M; j++)
|
||||
x_evaluate[k + j] = new_x[p + j];
|
||||
k = i * N;
|
||||
p = order_parametric[i] * N;
|
||||
for(j = 0; j < N; j++)
|
||||
x[k + j] = x_tmp[p + j];
|
||||
}
|
||||
for(i = 0; i < N; i++)
|
||||
robust[i] = weights[i] * robust[i];
|
||||
|
||||
if(!strcmp(*surface, "direct")) {
|
||||
if(*se) {
|
||||
loess_dfitse(y, x, x_evaluate, weights, robust,
|
||||
!strcmp(*family, "gaussian"), span, degree,
|
||||
&nonparametric, order_drop_sqr, &sum_drop_sqr,
|
||||
&D, &N, &M, fit, L);
|
||||
}
|
||||
else {
|
||||
loess_dfit(y, x, x_evaluate, robust, span, degree,
|
||||
&nonparametric, order_drop_sqr, &sum_drop_sqr,
|
||||
&D, &N, &M, fit);
|
||||
}
|
||||
}
|
||||
else {
|
||||
loess_ifit(parameter, a, xi, vert, vval, &M, x_evaluate, fit);
|
||||
if(*se) {
|
||||
new_cell = (*span) * (*cell);
|
||||
fit_tmp = (double *) malloc(M * sizeof(double));
|
||||
loess_ise(y, x, x_evaluate, weights, span, degree,
|
||||
&nonparametric, order_drop_sqr, &sum_drop_sqr,
|
||||
&new_cell, &D, &N, &M, fit_tmp, L);
|
||||
free(fit_tmp);
|
||||
}
|
||||
}
|
||||
if(*se) {
|
||||
for(i = 0; i < N; i++) {
|
||||
k = i * M;
|
||||
for(j = 0; j < M; j++) {
|
||||
p = k + j;
|
||||
L[p] = L[p] / weights[i];
|
||||
L[p] = L[p] * L[p];
|
||||
}
|
||||
}
|
||||
for(i = 0; i < M; i++) {
|
||||
tmp = 0;
|
||||
for(j = 0; j < N; j++)
|
||||
tmp = tmp + L[i + j * M];
|
||||
se_fit[i] = (*s) * sqrt(tmp);
|
||||
}
|
||||
}
|
||||
free(x);
|
||||
free(x_tmp);
|
||||
free(x_evaluate);
|
||||
free(L);
|
||||
free(order_parametric);
|
||||
free(order_drop_sqr);
|
||||
free(temp);
|
||||
}
|
||||
|
||||
void
|
||||
pred_free_mem(pre)
|
||||
struct pred_struct *pre;
|
||||
{
|
||||
free(pre->fit);
|
||||
free(pre->se_fit);
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
77
pmsco/loess/predict.m
Normal file
77
pmsco/loess/predict.m
Normal file
@ -0,0 +1,77 @@
|
||||
NAME
|
||||
predict, pointwise, pred_free_mem, pw_free_mem
|
||||
|
||||
SYNOPSIS
|
||||
#include "loess.h"
|
||||
|
||||
double *eval, coverage;
|
||||
long m, se;
|
||||
struct loess_struct *lo;
|
||||
struct predict_struct *pre;
|
||||
struct ci_struct *ci;
|
||||
|
||||
void predict(eval, m, lo, pre, se)
|
||||
|
||||
void pointwise(pre, m, coverage, ci)
|
||||
|
||||
void pred_free_mem(pre)
|
||||
|
||||
void pw_free_mem(ci)
|
||||
|
||||
PARAMETERS
|
||||
|
||||
eval a vector of length m * p specifying the values of the
|
||||
predictors at which the evaluation is to be carried out.
|
||||
The j-th coordinate of the i-th point is in eval[i+m*j],
|
||||
where 0<=j<p, 0<=i<m.
|
||||
|
||||
m number of evaluations.
|
||||
|
||||
lo k-d tree and coefficients.
|
||||
|
||||
pre predicted values; output by predict(), input to pointwise().
|
||||
|
||||
se logical flag for computing standard errors at eval.
|
||||
|
||||
ci pointwise confidence limits.
|
||||
|
||||
coverage (input) confidence level of the limits as a fraction.
|
||||
|
||||
DESCRIPTION
|
||||
|
||||
predict() takes all the loess structures from earlier calls to
|
||||
loess_setup() and loess(), does an evaluation based on
|
||||
eval and m, and stores the results in the pre structure.
|
||||
if se is TRUE, then pre.se_fit are computed along with the
|
||||
surface values, pre.fit. These returned vectors
|
||||
are vectors of the same structural arrangement as that of eval.
|
||||
|
||||
pointwise() computes the pointwise confidence limits from the
|
||||
result of predict().
|
||||
|
||||
pred_free_mem() and pw_free_mem() frees up the allocated memory
|
||||
used by the pre and ci structures respectively.
|
||||
|
||||
loess_struct, pred_struct, and ci_struct are defined in loess.h
|
||||
and documented in struct.m.
|
||||
|
||||
NOTES
|
||||
|
||||
The computations of predict() that produce the component se_fit
|
||||
are much more costly than those that producing the fit,
|
||||
so the number of points at which standard errors are
|
||||
computed should be modest compared to those at which we do
|
||||
evaluations. Often this means calling predict() twice,
|
||||
once at a large number of points, with se = FALSE,
|
||||
to get a thorough description of the surface; and once
|
||||
at a small number of points, with se = TRUE,
|
||||
to get standard-error information.
|
||||
|
||||
Suppose the computation method for loess surfaces is
|
||||
interpolate, the default for the argument surface. Then the
|
||||
evaluation values of a numeric predictor must lie within
|
||||
the range of the values of the predictor used in the fit.
|
||||
|
||||
SEE ALSO
|
||||
|
||||
loess_setup, loess, loess_summary, loess_free_mem
|
||||
55
pmsco/loess/setup.py
Normal file
55
pmsco/loess/setup.py
Normal file
@ -0,0 +1,55 @@
|
||||
#!/usr/bin/env python
|
||||
|
||||
__author__ = 'Matthias Muntwiler'
|
||||
|
||||
"""
|
||||
@package loess.setup
|
||||
setup.py file for LOESS
|
||||
|
||||
the LOESS code included here was developed at Bell Labs by
|
||||
William S. Cleveland, Eric Grosse, Ming-Jen Shyu,
|
||||
and is dated 18 August 1992.
|
||||
the code is available in the public domain
|
||||
from http://www.netlib.org/a/dloess.
|
||||
see the README file for details.
|
||||
|
||||
the Python wrapper was set up by M. Muntwiler
|
||||
with the help of the SWIG toolkit
|
||||
and other incredible goodies available in the Linux world.
|
||||
|
||||
@bug this file is currently not used because
|
||||
distutils does not compile the included Fortran files.
|
||||
|
||||
@author Matthias Muntwiler
|
||||
|
||||
@copyright (c) 2015 by Paul Scherrer Institut @n
|
||||
Licensed under the Apache License, Version 2.0 (the "License"); @n
|
||||
you may not use this file except in compliance with the License.
|
||||
You may obtain a copy of the License at
|
||||
http://www.apache.org/licenses/LICENSE-2.0
|
||||
"""
|
||||
|
||||
from distutils.core import setup, Extension
|
||||
from distutils import sysconfig
|
||||
|
||||
import numpy
|
||||
try:
|
||||
numpy_include = numpy.get_include()
|
||||
except AttributeError:
|
||||
numpy_include = numpy.get_numpy_include()
|
||||
|
||||
loess_module = Extension('_loess',
|
||||
sources=['loess.i', 'loess_wrap.c', 'loess.c', 'loessc.c', 'predict.c', 'misc.c', 'loessf.f',
|
||||
'dqrsl.f', 'dsvdc.f'],
|
||||
include_dirs = [numpy_include],
|
||||
libraries=['blas', 'm', 'f2c'],
|
||||
)
|
||||
|
||||
setup(name='loess',
|
||||
version='0.1',
|
||||
author=__author__,
|
||||
author_email='matthias.muntwiler@psi.ch',
|
||||
description="""LOESS module in Python""",
|
||||
ext_modules=[loess_module],
|
||||
py_modules=["loess"], requires=['numpy']
|
||||
)
|
||||
163
pmsco/loess/struct.m
Normal file
163
pmsco/loess/struct.m
Normal file
@ -0,0 +1,163 @@
|
||||
(All default values mentioned here are set by loess_setup().)
|
||||
|
||||
struct loess_struct *lo;
|
||||
|
||||
in
|
||||
n: number of observations.
|
||||
|
||||
p: number of numeric predictors.
|
||||
|
||||
y: vector of response (length n).
|
||||
|
||||
x: vector of predictors, of length (n * p).
|
||||
The j-th coordinate of the i-th point is in x[i+n*j],
|
||||
where 0<=j<p, 0<=i<n.
|
||||
|
||||
weights: vector of weights to be given to individual
|
||||
observations in the sum of squared residuals that
|
||||
forms the local fitting criterion.
|
||||
By default, an unweighted fit is carried out.
|
||||
If supplied, weights should be a non-negative
|
||||
numeric vector. If the different observations
|
||||
have non-equal variances, weights should be
|
||||
inversely proportional to the variances.
|
||||
|
||||
model
|
||||
span: smoothing parameter. Default is 0.75.
|
||||
|
||||
degree: overall degree of locally-fitted polynomial. 1 is
|
||||
locally-linear fitting and 2 is locally-quadratic
|
||||
fitting. Default is 2.
|
||||
|
||||
normalize: logical that determines if numeric predictors should
|
||||
be normalized. If TRUE (1) - the default - the
|
||||
standard normalization is used. If FALSE (0), no
|
||||
normalization is carried out.
|
||||
|
||||
parametric: for two or more numeric predictors, this argument
|
||||
specifies those variables that should be
|
||||
conditionally-parametric. The argument should be a
|
||||
logical vector of length p, specified in the order
|
||||
of the predictor group ordered in x.
|
||||
Default is a vector of 0's of length p.
|
||||
|
||||
drop_square: for cases with degree = 2, and with two or more
|
||||
numeric predictors, this argument specifies those
|
||||
numeric predictors whose squares should be dropped
|
||||
from the set of fitting variables. The method of
|
||||
specification is the same as for parametric.
|
||||
Default is a vector of 0's of length p.
|
||||
|
||||
family: the assumed distribution of the errors. The values
|
||||
are "gaussian" or "symmetric". The first value is
|
||||
the default. If the second value is specified,
|
||||
a robust fitting procedure is used.
|
||||
|
||||
control
|
||||
surface: determines whether the fitted surface is computed
|
||||
directly at all points ("direct") or whether an
|
||||
interpolation method is used ("interpolate").
|
||||
The latter, the default, is what most users should
|
||||
use unless special circumstances warrant.
|
||||
|
||||
statistics: determines whether the statistical quantities are
|
||||
computed exactly ("exact") or approximately
|
||||
("approximate"). The latter is the default. The former
|
||||
should only be used for testing the approximation in
|
||||
statistical development and is not meant for routine
|
||||
usage because computation time can be horrendous.
|
||||
|
||||
cell: if interpolation is used to compute the surface, this
|
||||
argument specifies the maximum cell size of the k-d
|
||||
tree. Suppose k = floor(n*cell*span) where n is the
|
||||
number of observations. Then a cell is further
|
||||
divided if the number of observations within it
|
||||
is greater than or equal to k.
|
||||
|
||||
trace_hat: when surface is "approximate", determines the
|
||||
computational method used to compute the trace of
|
||||
the hat matrix, which is used in the computation of
|
||||
the statistical quantities. If "exact", an exact
|
||||
computation is done; normally this goes quite fast
|
||||
on the fastest machines until n, the number of
|
||||
observations is 1000 or more, but for very slow
|
||||
machines, things can slow down at n = 300.
|
||||
If "wait.to.decide" is selected, then a default
|
||||
is chosen in loess(); the default is "exact" for
|
||||
n < 500 and "approximate" otherwise. If surface
|
||||
is "exact", an exact computation is always done
|
||||
for the trace. Set trace_hat to "approximate" for
|
||||
large dataset will substantially reduce the
|
||||
computation time.
|
||||
|
||||
iterations: if family is "symmetric", the number of iterations
|
||||
of the robust fitting method. Default is 0 for
|
||||
family being "gaussian" by default.
|
||||
|
||||
kd_tree: k-d tree, an output of loess().
|
||||
|
||||
out
|
||||
fitted_values: fitted values of the local regression model
|
||||
|
||||
fitted_residuals: residuals of the local regression fit
|
||||
|
||||
enp: equivalent number of parameters.
|
||||
|
||||
s: estimate of the scale of the residuals.
|
||||
|
||||
one_delta: a statistical parameter used in the computation of
|
||||
standard errors.
|
||||
|
||||
two_delta: a statistical parameter used in the computation of
|
||||
standard errors.
|
||||
|
||||
pseudovalues: adjusted values of the response when robust
|
||||
estimation is used.
|
||||
|
||||
trace_hat: trace of the operator hat matrix.
|
||||
|
||||
diagonal: diagonal of the operator hat matrix.
|
||||
|
||||
robust: robustness weights for robust fitting.
|
||||
|
||||
divisor: normalization divisor for numeric predictors.
|
||||
|
||||
|
||||
struct pred_struct *pre;
|
||||
|
||||
fit: the evaluated loess surface at eval.
|
||||
|
||||
se_fit: estimates of the standard errors of the surface values.
|
||||
|
||||
residual_scale: estimate of the scale of the residuals.
|
||||
|
||||
df: the degrees of freedom of the t-distribution used to
|
||||
compute pointwise confidence intervals for the
|
||||
evaluated surface.
|
||||
|
||||
|
||||
struct anova_struct *aov;
|
||||
|
||||
dfn: degrees of freedom of the numerator.
|
||||
|
||||
dfd: degrees of freedom of the denominator.
|
||||
|
||||
F_values: F statistic.
|
||||
|
||||
Pr_F: probability F_value is exceeded if null hypothesis
|
||||
is true.
|
||||
|
||||
|
||||
struct ci_struct *ci;
|
||||
|
||||
fit: the evaluated loess surface at eval (see pred_struct).
|
||||
|
||||
upper: upper limits of pointwise confidence intervals.
|
||||
|
||||
lower: lower limits of pointwise confidence intervals.
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
206
pmsco/loess/supp.f
Normal file
206
pmsco/loess/supp.f
Normal file
@ -0,0 +1,206 @@
|
||||
subroutine ehg182(i)
|
||||
integer i
|
||||
if(i.eq.100) print *,'wrong version number in lowesd. Probably ty
|
||||
+po in caller.'
|
||||
if(i.eq.101) print *,'d>dMAX in ehg131. Need to recompile with in
|
||||
+creased dimensions.'
|
||||
if(i.eq.102) print *,'liv too small. (Discovered by lowesd)'
|
||||
if(i.eq.103) print *,'lv too small. (Discovered by lowesd)'
|
||||
if(i.eq.104) print *,'alpha too small. fewer data values than deg
|
||||
+rees of freedom.'
|
||||
if(i.eq.105) print *,'k>d2MAX in ehg136. Need to recompile with i
|
||||
+ncreased dimensions.'
|
||||
if(i.eq.106) print *,'lwork too small'
|
||||
if(i.eq.107) print *,'invalid value for kernel'
|
||||
if(i.eq.108) print *,'invalid value for ideg'
|
||||
if(i.eq.109) print *,'lowstt only applies when kernel=1.'
|
||||
if(i.eq.110) print *,'not enough extra workspace for robustness ca
|
||||
+lculation'
|
||||
if(i.eq.120) print *,'zero-width neighborhood. make alpha bigger'
|
||||
if(i.eq.121) print *,'all data on boundary of neighborhood. make a
|
||||
+lpha bigger'
|
||||
if(i.eq.122) print *,'extrapolation not allowed with blending'
|
||||
if(i.eq.123) print *,'ihat=1 (diag L) in l2fit only makes sense if
|
||||
+ z=x (eval=data).'
|
||||
if(i.eq.171) print *,'lowesd must be called first.'
|
||||
if(i.eq.172) print *,'lowesf must not come between lowesb and lowe
|
||||
+se, lowesr, or lowesl.'
|
||||
if(i.eq.173) print *,'lowesb must come before lowese, lowesr, or l
|
||||
+owesl.'
|
||||
if(i.eq.174) print *,'lowesb need not be called twice.'
|
||||
if(i.eq.180) print *,'nv>nvmax in cpvert.'
|
||||
if(i.eq.181) print *,'nt>20 in eval.'
|
||||
if(i.eq.182) print *,'svddc failed in l2fit.'
|
||||
if(i.eq.183) print *,'didnt find edge in vleaf.'
|
||||
if(i.eq.184) print *,'zero-width cell found in vleaf.'
|
||||
if(i.eq.185) print *,'trouble descending to leaf in vleaf.'
|
||||
if(i.eq.186) print *,'insufficient workspace for lowesf.'
|
||||
if(i.eq.187) print *,'insufficient stack space'
|
||||
if(i.eq.188) print *,'lv too small for computing explicit L'
|
||||
if(i.eq.191) print *,'computed trace L was negative; something is
|
||||
+wrong!'
|
||||
if(i.eq.192) print *,'computed delta was negative; something is wr
|
||||
+ong!'
|
||||
if(i.eq.193) print *,'workspace in loread appears to be corrupted'
|
||||
if(i.eq.194) print *,'trouble in l2fit/l2tr'
|
||||
if(i.eq.195) print *,'only constant, linear, or quadratic local mo
|
||||
+dels allowed'
|
||||
if(i.eq.196) print *,'degree must be at least 1 for vertex influen
|
||||
+ce matrix'
|
||||
if(i.eq.999) print *,'not yet implemented'
|
||||
print *,'Assert failed, error code ',i
|
||||
stop
|
||||
end
|
||||
subroutine ehg183(s,i,n,inc)
|
||||
character*(*) s
|
||||
integer n, inc, i(inc,n), j
|
||||
print *,s,(i(1,j),j=1,n)
|
||||
end
|
||||
subroutine ehg184(s,x,n,inc)
|
||||
character*(*) s
|
||||
integer n, inc, j
|
||||
double precision x(inc,n)
|
||||
print *,s,(x(1,j),j=1,n)
|
||||
end
|
||||
subroutine losave(iunit,iv,liv,lv,v)
|
||||
integer execnt,iunit,liv,lv
|
||||
integer iv(liv)
|
||||
DOUBLE PRECISION v(lv)
|
||||
external ehg167
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
call ehg167(iunit,iv(2),iv(4),iv(5),iv(6),iv(14),v(iv(11)),iv(iv(7
|
||||
+)),v(iv(12)),v(iv(13)))
|
||||
return
|
||||
end
|
||||
subroutine ehg167(iunit,d,vc,nc,nv,nvmax,v,a,xi,vval)
|
||||
integer iunit,d,vc,nc,nv,a(nc),magic,i,j
|
||||
DOUBLE PRECISION v(nvmax,d),xi(nc),vval(0:d,nv)
|
||||
write(iunit,*)d,nc,nv
|
||||
do 10 i=1,d
|
||||
10 write(iunit,*)v(1,i),v(vc,i)
|
||||
j = 0
|
||||
do 20 i=1,nc
|
||||
if(a(i).ne.0)then
|
||||
write(iunit,*)a(i),xi(i)
|
||||
else
|
||||
write(iunit,*)a(i),j
|
||||
end if
|
||||
20 continue
|
||||
do 30 i=1,nv
|
||||
30 write(iunit,*)(vval(j,i),j=0,d)
|
||||
end
|
||||
subroutine lohead(iunit,d,vc,nc,nv)
|
||||
integer iunit,d,vc,nc,nv
|
||||
read(iunit,*)d,nc,nv
|
||||
vc = 2**d
|
||||
end
|
||||
subroutine loread(iunit,d,vc,nc,nv,iv,liv,lv,v)
|
||||
integer bound,d,execnt,iunit,liv,lv,nc,nv,vc
|
||||
integer iv(liv)
|
||||
DOUBLE PRECISION v(lv)
|
||||
external ehg168,ehg169,ehg182
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
iv(28)=173
|
||||
iv(2)=d
|
||||
iv(4)=vc
|
||||
iv(14)=nv
|
||||
iv(17)=nc
|
||||
iv(7)=50
|
||||
iv(8)=iv(7)+nc
|
||||
iv(9)=iv(8)+vc*nc
|
||||
iv(10)=iv(9)+nc
|
||||
bound=iv(10)+nc
|
||||
if(.not.(bound-1.le.liv))then
|
||||
call ehg182(102)
|
||||
end if
|
||||
iv(11)=50
|
||||
iv(13)=iv(11)+nv*d
|
||||
iv(12)=iv(13)+(d+1)*nv
|
||||
bound=iv(12)+nc
|
||||
if(.not.(bound-1.le.lv))then
|
||||
call ehg182(103)
|
||||
end if
|
||||
call ehg168(iunit,d,vc,nc,nv,nv,v(iv(11)),iv(iv(7)),v(iv(12)),v(iv
|
||||
+(13)))
|
||||
call ehg169(d,vc,nc,nc,nv,nv,v(iv(11)),iv(iv(7)),v(iv(12)),iv(iv(8
|
||||
+)),iv(iv(9)),iv(iv(10)))
|
||||
return
|
||||
end
|
||||
subroutine ehg168(iunit,d,vc,nc,nv,nvmax,v,a,xi,vval)
|
||||
integer iunit,d,vc,nc,nv,a(nc),magic,i,j
|
||||
DOUBLE PRECISION v(nvmax,d),xi(nc),vval(0:d,nv)
|
||||
do 10 i=1,d
|
||||
10 read(iunit,*)v(1,i),v(vc,i)
|
||||
do 20 i=1,nc
|
||||
20 read(iunit,*)a(i),xi(i)
|
||||
do 30 i=1,nv
|
||||
30 read(iunit,*)(vval(j,i),j=0,d)
|
||||
end
|
||||
subroutine ehg170(k,d,vc,nv,nvmax,nc,ncmax,a,c,hi,lo,v,vval,xi)
|
||||
integer d,execnt,i,j,nc,ncmax,nv,nvmax,vc
|
||||
integer a(ncmax),c(vc,ncmax),hi(ncmax),lo(ncmax)
|
||||
double precision v(nvmax,d),vval(0:d,nvmax),xi(ncmax)
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
write(k,*)' double precision function loeval(z)'
|
||||
write(k,50)d
|
||||
write(k,*)' integer d,vc,nv,nc'
|
||||
write(k,51)nc,vc,nc
|
||||
write(k,52)nc,nc
|
||||
write(k,53)nv,d
|
||||
write(k,54)d,nv
|
||||
write(k,55)nc
|
||||
write(k,56)
|
||||
write(k,57)d,vc,nv,nc
|
||||
50 format(' double precision z(',i2,')')
|
||||
51 format(' integer a(',i5,'), c(',i3,',',i5,')')
|
||||
52 format(' integer hi(',i5,'), lo(',i5,')')
|
||||
53 format(' double precision v(',i5,',',i2,')')
|
||||
54 format(' double precision vval(0:',i2,',',i5,')')
|
||||
55 format(' double precision xi(',i5,')')
|
||||
56 format(' double precision ehg128')
|
||||
57 format(' data d,vc,nv,nc /',i2,',',i3,',',i5,',',i5,'/')
|
||||
do 3 i=1,nc
|
||||
write(k,58)i,a(i)
|
||||
58 format(' data a(',i5,') /',i5,'/')
|
||||
if(a(i).ne.0)then
|
||||
write(k,59)i,i,i,hi(i),lo(i),xi(i)
|
||||
59 format(' data hi(',i5,'),lo(',i5,'),xi(',i5,') /',
|
||||
$ i5,',',i5,',',1pe15.6,'/')
|
||||
end if
|
||||
do 4 j=1,vc
|
||||
write(k,60)j,i,c(j,i)
|
||||
60 format(' data c(',i3,',',i5,') /',i5,'/')
|
||||
4 continue
|
||||
3 continue
|
||||
do 5 i=1,nv
|
||||
write(k,61)i,vval(0,i)
|
||||
61 format(' data vval(0,',i5,') /',1pe15.6,'/')
|
||||
do 6 j=1,d
|
||||
write(k,62)i,j,v(i,j)
|
||||
62 format(' data v(',i5,',',i2,') /',1pe15.6,'/')
|
||||
write(k,63)j,i,vval(j,i)
|
||||
63 format(' data vval(',i2,',',i5,') /',1pe15.6,'/')
|
||||
6 continue
|
||||
5 continue
|
||||
write(k,*)' loeval=ehg128(z,d,nc,vc,a,xi,lo,hi,c,v,nv,vval)'
|
||||
write(k,*)' end'
|
||||
return
|
||||
end
|
||||
subroutine lofort(iunit,iv,liv,lv,wv)
|
||||
integer execnt,iunit
|
||||
integer iv(*)
|
||||
DOUBLE PRECISION wv(*)
|
||||
external ehg170
|
||||
save execnt
|
||||
data execnt /0/
|
||||
execnt=execnt+1
|
||||
call ehg170(iunit,iv(2),iv(4),iv(6),iv(14),iv(5),iv(17),iv(iv(7)),
|
||||
+iv(iv(8)),iv(iv(9)),iv(iv(10)),wv(iv(11)),wv(iv(13)),wv(iv(12)))
|
||||
return
|
||||
end
|
||||
Reference in New Issue
Block a user