double FSigLevel(double var1, double var2, long nu1, long nu2)
/* return the probability that F will exceed F0=Max(var1,var2)/Min(var1,var2)
for nu1 and nu2 degrees of freedom */
{
if (var1<var2) {
SWAP_DOUBLE(var1, var2);
SWAP_LONG(nu1, nu2);
}
return betaInc(nu2/2.0, nu1/2.0, nu2/(nu2+nu1*var1/var2));
}
int matout(char *fullname,char *varname,void *data,int nrows,int ncols,char vartype, char *mode, char endianess)
{
int size;
long nelem;
int type,namelen;
int mrows,mcols,imagf;
int i;
FILE *fs;
mrows = nrows;
mcols = ncols;
nelem = mrows*mcols;
switch (vartype) {
case 'd': /* 8-byte doubles */
type=00;
size=8;
double *vard=data;
if (endianess=='B') { for (i=0;i<nelem;i++) SWAP_DOUBLE(vard[i]); };
break;
case 'r': /* 4-byte reals */
type=10;
size=4;
float *varf=data;
if (endianess=='B') { for (i=0;i<nelem;i++) SWAP_FLOAT(varf[i]); };
break;
case 'l': /* 4-byte int, row-wise */
type=20;
size=4;
int *varl=data;
if (endianess=='B') { for (i=0;i<nelem;i++) SWAP_INT(varl[i]); };
break;
case 's': /* 2-byte signed shorts */
type=30;
size=2;
short *vars=data;
if (endianess=='B') { for (i=0;i<nelem;i++) SWAP_SHORT(vars[i]); };
break;
case 'u': /* 2-byte unsigned shorts */
type=40;
size=2;
short *varus=data;
if (endianess=='B') { for (i=0;i<nelem;i++) SWAP_SHORT(varus[i]); };
break;
// case 't': /* 2-byte unsigned shorts saved as "text" */
// type=41;
// nbytes = mrows*mcols*2;
case 't': /* 1-byte unsigned shorts saved as "text" */
type=51;
size=1;
break;
case 'b': /* 1-byte unsigned chars */
case 'c': /* 1-byte signed chars */
type=50;
size=1;
break;
default:
return (-1);
}
if (disable_disk_writing) return (0);
for (i=0 ; i<nfiles ; i++) {
if (! *matfile[i]) break;
if (!strcmp(fullname,matfile[i])) break;
}
if (i<nfiles) {
fs = fd[i];
} else {
fs = NULL;
}
if (fs == NULL) {
if ((fs=fopen(fullname,mode))==NULL) {
sprintf(message,"%s could not be opened because of reason %d",fullname,errno);;
warn(message);
return (-1);
}
strcpy(matfile[i],fullname);
fd[i] = fs;
if ((i==nfiles) && (nfiles<MAXFILES-1)) nfiles++;
}
imagf=0;
if (endianess=='B') SWAP_INT(type);
if (fwrite(&type,sizeof(int),1,fs) != 1) {
writerr();
return (-1);
}
if (endianess=='B') SWAP_INT(mrows);
if (fwrite(&mrows,sizeof(int),1,fs) != 1) {
writerr();
return (-1);
}
if (endianess=='B') SWAP_INT(mcols);
if (fwrite(&mcols,sizeof(int),1,fs) != 1) {
writerr();
return (-1);
}
if (endianess=='B') SWAP_INT(imagf);
if (fwrite(&imagf,sizeof(int),1,fs) != 1) {
writerr();
return (-1);
}
namelen=strlen(varname)+1;
if (endianess=='B') SWAP_INT(namelen);
if (fwrite(&namelen,sizeof(int),1,fs) != 1) {
writerr();
return (-1);
}
if (endianess=='B') SWAP_INT(namelen);
if (fwrite(varname,(unsigned int)namelen,1,fs) != 1) {
writerr();
return (-1);
}
if (fwrite(data,size,nelem,fs) != nelem) {
writerr();
return (-1);
}
matclose(fullname);
return (0);
}
void Y_ml4read(int nArgs)
{
char *filename="";
char *varname="";
int leave_open = 0;
if (nArgs==2) {
filename=YGetString(sp-nArgs+1);
varname=YGetString(sp-nArgs+2);
leave_open = 0;
} else if (nArgs==3) {
filename=YGetString(sp-nArgs+1);
varname=YGetString(sp-nArgs+2);
leave_open=YGetInteger(sp-nArgs+3);
}
unsigned long bytes_read;
int type,namelen;
unsigned long nElements,nBytesToRead;
int mrows,mcols,imagf;
FILE *fs;
int fileptr;
int endian = 'L';
int size=0,i;
fs = openmat(filename);
if (fs == NULL) YError(p_strncat("Can't open file ",filename,0));
if (!matfind(fs,varname,50000)) YError(p_strncat("No Such variable ",varname,0));
fileptr = ftell(fs);
if (DEBUG) printf("@ position %d\n",fileptr);
bytes_read = fread(&type,sizeof(int),1,fs);
if (bytes_read==0) {
matclose(filename);
YError("Premature end of file");; // end of file
}
fread(&mrows,sizeof(int),1,fs);
fread(&mcols,sizeof(int),1,fs);
fread(&imagf,sizeof(int),1,fs);
fread(&namelen,sizeof(int),1,fs);
if (namelen & 0xffff0000) {
if (DEBUG) printf("Big endian file\n");
endian = 'B';
SWAP_INT(type);
SWAP_INT(mrows);
SWAP_INT(mcols);
SWAP_INT(imagf);
SWAP_INT(namelen);
}
type = type%1000;
if (DEBUG) printf("rows,cols,namelen= %d %d %d\n",mrows,mcols,namelen);
if (namelen>255) {
fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable
matclose(filename);
YError("Variable name too long!");
}
fread(tempvarname,(unsigned int)namelen,1,fs);
// if ((*varname!='*') && strcmp(varname,tempvarname)) { // error if not same varname
if (!matchvarname(tempvarname,varname)) { // error if not same varname
fseek(fs,fileptr,SEEK_SET); // leave file ptr at begginning of this variable
matclose(filename);
YError(p_strncat("Can't find variable",varname,0));
}
nElements = (unsigned)mrows*(unsigned)mcols;
Dimension *tmp=tmpDims;
tmpDims=0;
FreeDimension(tmp);
if (mrows<=1) {
tmpDims= NewDimension(mcols, 1L, (Dimension *)0);
} else if (mcols<=1) {
tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
} else {
tmpDims= NewDimension(mrows, 1L, (Dimension *)0);
tmpDims= NewDimension(mcols, 1L, tmpDims);
}
if (type==0) {
// 8-byte doubles
size = 8;
Array *a= PushDataBlock(NewArray(&doubleStruct, tmpDims));
double *data = a->value.d;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_DOUBLE(data[i]); }
} else if (type==10) {
// 4-byte reals
size = 4;
Array *a= PushDataBlock(NewArray(&floatStruct, tmpDims));
float *data = a->value.f;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_FLOAT(data[i]); }
} else if ((type==120) || (type==20)) {
// 4-byte int
size = 4;
Array *a= PushDataBlock(NewArray(&intStruct, tmpDims));
int *data = a->value.l;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_INT(data[i]); }
} else if (type==30) {
// 2-byte signed (30) shorts
size = 2;
Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
short *data = a->value.s;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }
} else if (type==40) {
// 2-byte unsigned (40) shorts
size = 2;
Array *a= PushDataBlock(NewArray(&shortStruct, tmpDims));
short *data = a->value.s;
Array *b= PushDataBlock(NewArray(&longStruct, tmpDims));
long *data2 = b->value.l;
bytes_read = fread((void *)data,size,nElements,fs);
if (endian=='B') { for (i=0;i<nElements;i++) SWAP_SHORT(data[i]); }
for (i=1;i<=nElements;i++) *(data2++) = (((long)*(data++))|0xFFFF0000)+65535;
} else if (type==50) {
// 1-byte signed or unsigned chars (50)
size = 1;
Array *a= PushDataBlock(NewArray(&charStruct, tmpDims));
char *data = a->value.c;
bytes_read = fread((void *)data,size,nElements,fs);
} else if (type==51) {
// text (51)
size = 1;
Array *a= PushDataBlock(NewArray(&stringStruct, (Dimension *)0));
char *buf;
a->value.q[0] = buf = p_malloc(nElements+1);
if (DEBUG) printf("strlen: %d\n",(int)strlen((void *)a->value.q[0]));
// bytes_read = fread(a->value.q[0],1,nElements,fs);
bytes_read = fread(buf,1,nElements,fs);
*((char *)buf + nElements) = 0; // append a NULL to text string
} else {
matclose(filename);
sprintf(message,"Unknown type %d",type);
YError(message);
}
if (bytes_read!=nElements) {
fseek(fs,nElements*size,SEEK_CUR);
matclose(filename);
if (DEBUG) printf("read:%ld expected:%ld\n",bytes_read,nBytesToRead);
YError("Premature end of file");
}
if (!leave_open) matclose(filename);
}
long OneDParabolicOptimization(double *yReturn, double *xGuess, double dx,
double xLower, double xUpper,
double (*func)(double x, long *invalid),
long maxCycles, double dxLimit,
double tolerance, long maximize)
{
double maxFactor, fBest, xBest;
long invalid, cycle;
double x0, x1=0, x2, f0, f1=0, f2;
maxFactor = maximize?-1:1;
invalid = 0;
x0 = *xGuess;
f0 = maxFactor*(*func)(x0, &invalid);
xBest = x0;
fBest = f0;
*yReturn = maxFactor*f0;
if (invalid)
return -1;
/* find direction in which function decreases */
for (cycle=0; cycle<2*maxCycles; cycle++) {
x1 = x0 + dx;
if (x1==x0)
break;
if (x1>xUpper || x1<xLower)
return -2;
f1 = maxFactor*(*func)(x1, &invalid);
if (invalid)
return -1;
#ifdef DEBUG
fprintf(stderr, "cycle = %ld, maxCycles=%ld, f1 = %21.15e, fBest = %21.15e\n",
cycle, 2*maxCycles, f1, fBest);
#endif
if (f1<fBest) {
#ifdef DEBUG
fprintf(stderr, "f1<fBest\n");
#endif
fBest = f1;
xBest = x1;
}
if (f1<f0) {
#ifdef DEBUG
fprintf(stderr, "f1<f0, breaking\n");
#endif
break;
}
dx = dx*(cycle%2==0 ? -1 : -0.5);
}
if (x1==x0)
return 1;
if (cycle==2*maxCycles) {
if (fabs(dx)<dxLimit)
return 1;
return -3;
}
#ifdef DEBUG
fprintf(stderr, "Function decreases with dx=%e, f0=%21.15e, f1=%21.15e, cycle=%ld\n", dx, f0, f1, cycle);
#endif
/* take steps until passing through minimum */
while (1) {
x2 = x1 + dx;
if (x2>xUpper || x2<xLower)
return -4;
f2 = maxFactor*(*func)(x2, &invalid);
if (invalid)
return -1;
if (f2<fBest) {
fBest = f2;
xBest = x2;
}
#ifdef DEBUG
fprintf(stderr, "fBest = %21.15e, f1 = %21.15e, f2 = %21.15e\n",
fBest, f1, f2);
#endif
if (f2>f1)
break;
if (x1==x2)
break;
x0 = x1; f0 = f1;
x1 = x2; f1 = f2;
}
if (x0>x2) {
/* arrange in increasing order */
SWAP_DOUBLE(x0, x2);
SWAP_DOUBLE(f0, f2);
}
/* now f0 > f1 and f2 > f1 */
for (cycle=0; cycle<maxCycles; cycle++) {
double numer, denom, x3, f3, scale;
long failed;
#ifdef DEBUG
fprintf(stderr, "Cycle %ld: f(%e)=%e, f(%e)=%e, f(%e)=%e\n",
cycle, x0, f0, x1, f1, x2, f2);
#endif
if (x2==x0 || (x2-x0)<dxLimit || (MAX(f2,f0)-f1)<tolerance)
break;
/* try parabolic interpolation */
numer = sqr(x1-x0)*(f1-f2) - sqr(x1-x2)*(f1-f0);
denom = (x1-x0)*(f1-f2) - (x1-x2)*(f1-f0);
x3 = x1 - numer/denom/2.0;
failed = 1;
scale = x2-x0;
#ifdef DEBUG
fprintf(stderr,"parabolic parameters: x3 = %e, f3 = %e, scale=%e, x0=%e, x2=%e\n",
x3,
isinf(x3)?DBL_MAX:maxFactor*(*func)(x3, &invalid), scale, x0, x2);
#endif
if (!isinf(x3) && x0<x3 && x3<x2 &&
fabs(x3-x0)>1e-6*scale && fabs(x3-x1)>1e-6*scale &&
fabs(x3-x2)>1e-6*scale) {
/* evaluate at parabolic interpolation point */
failed = 0;
f3 = maxFactor*(*func)(x3, &invalid);
if (invalid)
failed = 1;
else {
if (f3<fBest) {
fBest = f3;
xBest = x3;
}
if (f3<f1) {
/* replace point 1 */
f1 = f3;
x1 = x3;
} else if (f2>f0 && f3<f2) {
/* replace point 2 */
f2 = f3;
x2 = x3;
if (x2<x1) {
SWAP_DOUBLE(x1, x2);
SWAP_DOUBLE(f1, f2);
}
} else if (f2<f0 && f3<f0) {
/* replace point 0 */
f0 = f3;
x0 = x3;
if (x0>x1) {
SWAP_DOUBLE(x0, x1);
SWAP_DOUBLE(f0, f1);
}
} else
failed = 1;
}
}
#ifdef DEBUG
if (!failed)
fprintf(stderr, "Parabolic interpolation succeeded\n");
#endif
if (failed) {
long right, other;
for (other=0; other<2; other++) {
/* try dividing one of the intervals */
if (fabs(x0-x1)<fabs(x1-x2)) {
if (!other) {
x3 = (x1+x2)/2;
right = 1;
} else {
x3 = (x0+x1)/2;
right = 0;
}
} else {
if (!other) {
x3 = (x0+x1)/2;
right = 0;
} else {
x3 = (x1+x2)/2;
right = 1;
}
}
f3 = maxFactor*(*func)(x3, &invalid);
if (invalid)
return -1;
if (f3<fBest) {
fBest = f3;
xBest = x3;
}
#ifdef DEBUG
fprintf(stderr, "f3 = %e at x3=%e\n", f3, x3);
#endif
if (f3<f1) {
#ifdef DEBUG
fprintf(stderr, "Replacing point 1\n");
#endif
f1 = f3;
x1 = x3;
break;
}
if (right && f3<f2) {
/* replace point 2 */
#ifdef DEBUG
fprintf(stderr, "Replacing point 2\n");
#endif
f2 = f3;
x2 = x3;
if (x2<x1) {
SWAP_DOUBLE(x1, x2);
SWAP_DOUBLE(f1, f2);
}
break;
} else if (!right && f3<f0) {
/* replace point 0 */
#ifdef DEBUG
fprintf(stderr, "Replacing point 0\n");
#endif
f0 = f3;
x0 = x3;
if (x0>x1) {
SWAP_DOUBLE(x0, x1);
SWAP_DOUBLE(f0, f1);
}
break;
}
}
#ifdef DEBUG
fprintf(stderr, "Sectioning succeeded\n");
#endif
}
}
#ifdef DEBUG
fprintf(stderr, "Returning: x=%21.15e, y=%21.15e\n",
xBest, maxFactor*fBest);
#endif
*yReturn = maxFactor*fBest;
*xGuess = xBest;
return 1;
}
