https://github.com/cran/RandomFields
Tip revision: b0fe233a1b9fafb53435b43cdeaa116b9ec02517 authored by Martin Schlather on 01 November 2009, 00:00:00 UTC
version 1.3.41
version 1.3.41
Tip revision: b0fe233
MPP.cc
/*
Authors
Martin Schlather, martin.schlather@math.uni-goettingen.de
Copyright (C) 2001 -- 2006 Martin Schlather,
This program is free software; you can redistribute it and/or
modify it under the terms of the GNU General Public License
as published by the Free Software Foundation; either version 2
of the License, or (at your option) any later version.
This program is distributed in the hope that it will be useful,
but WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
GNU General Public License for more details.
You should have received a copy of the GNU General Public License
along with this program; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
*/
/* TO DO
* noch fast alles auf key->x programmiert statt s->x
* time component: aenderungen siehe TBM !
*/
#include <math.h>
#include <assert.h>
#include "RFsimu.h"
#include "MPPFcts.h"
double MPP_RADIUS =0.0;
double MPP_APPROXZERO =0.001;
double ADDMPP_REALISATIONS = 100.0; // logically an integer, implementation
// allows for positive real !
void SetMPP(int *action, double *approxzero, double *realisations,
double *radius)
{
if (*action) {
if (*approxzero<=0.0) {
if (GENERAL_PRINTLEVEL>0)
PRINTF("\nWARNING! `approx.zero' not a positive number. Ignored.\n");
} else MPP_APPROXZERO = *approxzero;
if (*realisations<=0.0) {
if (GENERAL_PRINTLEVEL>0)
PRINTF("\nWARNING! `realisation' not a positive number. Ignored.\n");
} else ADDMPP_REALISATIONS = *realisations;
MPP_RADIUS = *radius;
if ((MPP_RADIUS>0.0) && (GENERAL_PRINTLEVEL>1))
PRINTF("\nWARNING! Positive, but too small values of `MPP.radius' may result in wrong simulations that are difficult to detect.\n");
} else {
*approxzero = MPP_APPROXZERO;
*realisations = ADDMPP_REALISATIONS;
*radius = MPP_RADIUS;
}
}
void mpp_destruct(void **S) {
// mpp_storage in RFsimu.h !!
if (*S!=NULL) {
free(*S);
*S = NULL;
}
}
void MPP_NULL(mpp_storage* s) {
int i;
s->integral = s->integralsq = s->integralpos = s->factor = s->maxheight =
s->effectiveRadius = s->effectivearea = s->addradius = RF_NAN;
for (i=0; i<MAXDIM; i++) s->min[i] = s->length[i] = RF_NAN;
for (i=0; i<6; i++) s->c[i] = RF_NAN;
s->MppFct = NULL;
s->dim = 0; // otherwise error possible in InternalGetKeyInfo
}
int init_mpp(key_type * key, int m) {
methodvalue_type *meth;
int error, d, i, v, reduceddim, actcov;
double max[MAXDIM];
mpp_storage *s;
covinfo_type *kc;
error = NOERROR;
meth = &(key->meth[m]);
SET_DESTRUCT(mpp_destruct, m);
assert(meth->S==NULL);
if ((meth->S=malloc(sizeof(mpp_storage)))==0){
error=ERRORMEMORYALLOCATION; goto ErrorHandling;
}
s = (mpp_storage*) meth->S;
MPP_NULL(s);
kc = NULL;
for (actcov=v=0; v<key->ncov; v++) {
ERRORMODELNUMBER = v;
kc = &(key->cov[v]);
if ((kc->method==AdditiveMpp) && kc->left
&& (kc->param[VARIANCE]>0)) {
cov_fct *cov;
assert(kc->nr>=0 && kc->nr<currentNrCov);
meth->covlist[actcov] = v;
cov = &(CovList[kc->nr]);
if (key->Time && !kc->genuine_last_dimension &&
(cov->type==SPACEISOTROPIC)) {// unclear whether this is too cautious
error= ERRORWITHOUTTIME; goto ErrorHandling;}
if ((error=cov->check(kc->param, kc->reduceddim, kc->dim,
AdditiveMpp)) != NOERROR) {
ERRORMODELNUMBER = v;
goto ErrorHandling;
}
if (cov->add_mpp_scl==NULL) {error=ERRORNOTDEFINED; goto ErrorHandling;}
if (cov->type==ISOHYPERMODEL || cov->type==ANISOHYPERMODEL) {
error=ERRORHYPERNOTALLOWED; goto ErrorHandling;}
if ((v<key->ncov-1 && kc->op)) {
// no multiplicative models are allowed
error=ERRORNOMULTIPLICATION; goto ErrorHandling;}
if ((error=Transform2NoGrid(key, v)) != NOERROR) goto ErrorHandling;
kc->left=false;
actcov++;
// do not pile up more than 1 elementary covariance function.
// creating max-stable fields may cause difficulties!
break;
}
}
ERRORMODELNUMBER = -1;
if (actcov==0) {
if (error==NOERROR) error=NOERROR_ENDOFLIST;
goto ErrorHandling;
} else assert(actcov==1);
assert(kc != NULL);
if (v>key->ncov) {
error=ERRORFAILED; goto ErrorHandling;
}
meth->actcov = actcov;
// kc = &(key->cov[0]); -- passt nicht waere v
// determine the minimum area where random field values are to be generated
reduceddim = kc->reduceddim;
if (kc->simugrid) {
for (d=0; d<key->timespacedim; d++) {
// printf("%d, %d %d %f %f\n", d, kc->idx[d],
// XSTARTD[d], kc->xsimugr[XSTARTD[d]], s->integralpos);
s->min[kc->idx[d]] = kc->xsimugr[XSTARTD[d]];
s->length[kc->idx[d]]= kc->xsimugr[XSTEPD[d]] *
(double) (key->length[d] - 1);
// x[XSTARTD[d]] and x[XSTEPD[d]] are assumed to be precise, but
// not x[XENDD[d]]
}
} else {
int ix;
for (d=0; d<reduceddim; d++) {
s->min[d]=RF_INF;
max[d]=RF_NEGINF;
}
v = 0;
kc = &(key->cov[meth->covlist[v]]);
for (ix=i=0; i<key->totalpoints; i++, ix+=reduceddim) {
for (d=0; d<reduceddim; d++) {
if (kc->x[ix+d] < s->min[d]) s->min[d] = kc->x[ix+d];
if (kc->x[ix+d] > max[d]) max[d] = kc->x[ix+d];
}
}
for (d=0; d<reduceddim; d++)
s->length[d] = max[d] - s->min[d];
}
v = 0;
kc = &(key->cov[meth->covlist[v]]);
s->addradius = MPP_RADIUS; // must be set BEFORE the next command!!
CovList[kc->nr].add_mpp_scl(s, reduceddim, kc->param);
s->MppFct = CovList[kc->nr].add_mpp_rnd;
if ((MPP_RADIUS>0.0) && (GENERAL_PRINTLEVEL>=2))
PRINTF("Note: window has been enlarged by fixed value (%f)\n",s->addradius);
if (key->anisotropy) return NOERROR_REPEAT;
else return 0;
ErrorHandling:
return error;
}
void do_addmpp(key_type *key, int m, double *res )
{
methodvalue_type *meth;
covinfo_type *kc;
int i, d, v, timespacedim;
double lambda, //[MAXDIM],
min[MAXDIM], max[MAXDIM],
factor, average, poisson;
long segment[MAXDIM+1];
mpp_storage *s;
mppmodel model;
meth = &(key->meth[m]);
assert(meth->actcov==1);
{
long i;
for (i=key->totalpoints - 1; i>=0; res[i--]=0.0);
}
s = (mpp_storage*) meth->S;
v = 0; // NOTE !
switch (key->distribution) {
case DISTR_GAUSS :
kc = &(key->cov[meth->covlist[v]]);
lambda = ADDMPP_REALISATIONS * s->effectivearea;
factor = sqrt(kc->param[VARIANCE] /
(ADDMPP_REALISATIONS * s->integralsq));
average = ADDMPP_REALISATIONS * s->integral;
break;
case DISTR_POISSON :
// not done yet -- it is only a fragment
// on the R level, it is excluded that the program runs
// into this part
//
// only actcov==1 is possible!!
//
// maybe nice to switch MPPFcts back to actcov=1
kc = &(key->cov[meth->covlist[v]]);
lambda = kc->param[VARIANCE] * s->effectivearea;
factor = average = 0.0 /* replace by true value !! */;
assert(false);
if (key->mean!=0) {
// do not compare mean against VARIANCE since
// VARIANCEs may differ with v
// if (GENERAL_PRINTLEVEL>0)
ErrorMessage(AdditiveMpp,ERRORVARMEAN); assert(false); // print it always
assert(false); // for debugging -- delete this later on
// finally, the value of MEAN is ignored, and that of VARIANCE
// is used for simulating the random field
}
break;
default : assert(false);
}
segment[0] = 1; // only used if simugrid
for (d=0; d<key->timespacedim; d++)
segment[d+1] = segment[d] * key->length[d];
for (i=0; i<key->totalpoints; i++) res[i]=0.0;
kc = &(key->cov[meth->covlist[v]]);
timespacedim = kc->simugrid ? key->timespacedim : kc->reduceddim;
for (poisson = rexp(1.0); poisson < lambda; poisson += rexp(1.0)) {
(s->MppFct)(s, min, max, &model);
if (kc->simugrid) {
int start[MAXDIM], end[MAXDIM], resindex, index[MAXDIM],
segmentdelta[MAXDIM], dimM1;
double coord[MAXDIM], startcoord[MAXDIM];
resindex = 0;
for (d=0; d<timespacedim; d++) {
// determine rectangle of indices, where the mpp function
// is different from zero
if (kc->genuine_dim[d]) {
if (min[kc->idx[d]]< kc->xsimugr[XSTARTD[d]]) {start[d]=0;}
else start[d] = (int) ((min[kc->idx[d]] - kc->xsimugr[XSTARTD[d]]) /
kc->xsimugr[XSTEPD[d]]);
// "end[d] = 1 + *" since inequalities are "* < end[d]"
// not "* <= end[d]" !
end[d] = 1 + (int) ((max[kc->idx[d]] - kc->xsimugr[XSTARTD[d]]) /
kc->xsimugr[XSTEPD[d]]);
if (end[d] > key->length[d]) end[d] = key->length[d];
} else {
start[d] = 0;
end[d] = key->length[d];
}
// prepare coord starting value and the segment vectors for res
index[d] = start[d];
segmentdelta[d] = segment[d] * (end[d]-start[d]);
resindex += segment[d] * start[d];
coord[kc->idx[d]] = startcoord[d] =
kc->xsimugr[XSTARTD[d]] + (double) start[d] * kc->xsimugr[XSTEPD[d]];
}
// add mpp function to res
dimM1 = timespacedim -1;
d = 0; // only needed for assert(d<dim)
while (index[dimM1] < end[dimM1]) {
assert(d<timespacedim);
res[resindex] += model(coord);
d=0;
index[d]++;
coord[kc->idx[d]] += kc->xsimugr[XSTEPD[d]];
resindex++;
while (d<dimM1 && index[d] >= end[d]) {
// loop never entered if dim=1
index[d] = start[d];
coord[kc->idx[d]] = startcoord[d];
resindex -= segmentdelta[d];
d++; // if (d>=dim) break;
index[d]++;
coord[kc->idx[d]] += kc->xsimugr[XSTEPD[d]];
resindex += segment[d];
}
}
} else { // !key->simugrid
double y[MAXDIM];
long j;
// the following algorithm can greatly be improved !
// but for ease, just the stupid algorithm
for (j=i=0; i<key->totalpoints; i++) {
for (d=0; d<timespacedim; d++, j++) y[d] = kc->x[j];
res[i] += model(y);
}
}
}
if (key->distribution==DISTR_GAUSS) {
for (i=0; i<key->totalpoints;i++) {
res[i] = factor * (res[i] - average);
}
}
}