void FLQuant_pointer::Init(SEXP x)
{
SEXP Quant = GET_SLOT(x, install(".Data")),
dims = GET_DIM(Quant),
dimnames = GET_DIMNAMES(Quant);
data = NUMERIC_POINTER(AS_NUMERIC(Quant));
int dim[6], n = length(dims);
dim[0] = INTEGER(dims)[0];
dim[1] = INTEGER(dims)[1];
dim[2] = INTEGER(dims)[2];
dim[3] = INTEGER(dims)[3];
dim[4] = INTEGER(dims)[4];
dim[5] = n>=6 ? INTEGER(dims)[5] : 1;
if (((int)dim[0]) < 1 || ((int)dim[1]) < 1 ||
((int)dim[2]) < 1 || ((int)dim[3]) < 1 || ((int)dim[4]) < 1 || ((int)dim[5]) < 1)
{
UNPROTECT(1);
return;
}
minquant() = 0;
minyr() = 0;
maxquant() = (int)dim[0] -1;
maxyr() = (int)dim[1] -1;
nunits() = (int)dim[2];
nseasons() = (int)dim[3];
nareas() = (int)dim[4];
niters() = (int)dim[5];
if (dimnames != R_NilValue)
if (TYPEOF(dimnames) == VECSXP)
{
int t = 0;
const char *c;
if (n >= 1 && INTEGER(dims)[0] >= 1)
{
c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 0), 0));
//check that name is not a text string
for (int i=0; i<=(signed)strlen(c); i++)
if (isalpha(c[i])) t=1;
if (t !=1)
t = atoi(c);
minquant() += t;
maxquant() += t;
}
if (n >= 2 && INTEGER(dims)[1] >= 1)
{
t = 0;
c = CHAR(STRING_ELT(VECTOR_ELT(dimnames, 1), 0));
//check that name is not a text string
for (int i=0; i<=(signed)strlen(c); i++)
if (isalpha(c[i])) t=1;
if (t !=1)
t = atoi(c);
minyr() += t;
maxyr() += t;
}
}
InitFlag() = true;
UNPROTECT(1);
}
bool fwd::run(SEXP xTrgt, SEXP xAryTrgt, SEXP xCtrl, SEXP xAryCtrl, SEXP xYrs)
{
if (!Trgt.Init(xTrgt,xAryTrgt,niters())) return false;
if (!Ctrl.Init(xCtrl,xAryTrgt,niters())) return false;
MinProjYear = (int)REAL(xYrs)[0];
MaxProjYear = (int)REAL(xYrs)[0];
int i;
for (i=1; i<LENGTH(xYrs); i++)
{
if (MinProjYear>REAL(xYrs)[i]) MinProjYear=(int)REAL(xYrs)[i];
if (MaxProjYear<REAL(xYrs)[i]) MaxProjYear=(int)REAL(xYrs)[i];
}
//ADol-C stuff
int n=1;
double *depen, *indep, *r, **jac;
adouble *depen_ad, *indep_ad;
int iter = 0;
//get N at start of year
double x=1.0;
for (iter=1; iter<=niters(); iter++)
project(&x, MinProjYear-1 ,iter, TRUE, TRUE);
int tag = 0;
for (int iYr=MinProjYear; iYr<=MaxProjYear; iYr++)
{
int _tag = 0; //(tag % 6 + 1);
n = (int)Trgt.n(iYr);
//n of independent variables MUST = n of equations
if (Ctrl.n(iYr) == n)
{
depen = new double[n];
indep = new double[n];
r = new double[n];
jac = new double*[n];
depen_ad = new adouble[n];
indep_ad = new adouble[n];
for (i=0; i<n; i++)
jac[i] = new double[n];
for (iter=1; iter<=niters(); iter++)
{
// set independent variables to estimaate
int j=0;
for (int iFleet=1; iFleet<=nfleet(); iFleet++)
for (int iMetier=1; iMetier<=nmetier(); iMetier++)
if (Ctrl.fit(iYr, iFleet, iMetier))
indep[j++] = 1.0;
// Taping the computation of the jacobian
trace_on(_tag);
// marking independent variables
for (i=0; i<n; i++)
indep_ad[i] <<= indep[i];
project(indep_ad,depen_ad,iYr,iter);
// marking dependent variables
for (i=0; i<n; i++)
depen_ad[i] >>= depen[i];
trace_off(_tag);
//jacobian(tag,m,n,indep,jac);
r[0]=1.0;
function(_tag,n,n,indep,r);
int NIters=0;
while (norm(r,n) > 1e-10 && NIters++<50)
{
jac_solv(_tag,n,indep,r,0,2);
for (i=0; i<n; i++)
indep[i] -= r[i];
function(_tag,n,n,indep,r);
}
project(indep, iYr, iter);
}
delete[] depen;
delete[] indep;
delete[] r;
delete[] depen_ad;
delete[] indep_ad;
for (i=0; i<n; i++)
delete[] jac[i];
delete[] jac;
}
tag++;
}
SEXP FLQuant_pointer::Return(void)
{
SEXP Quant, v,
d1, d2, d3, d4, d5, d6,
dim, dimnames, names;
int j, iAge, iYear, iUnit, iArea, iSeason, iIter;
//Create new S4 object
PROTECT(Quant = NEW_OBJECT(MAKE_CLASS("FLQuant")));
//Create array for slot
//Set dimensions of array
PROTECT(dim = allocVector(INTSXP, 6));
INTEGER(dim)[0] = maxquant()-minquant() +1;
INTEGER(dim)[1] = maxyr() -minyr() +1;
INTEGER(dim)[2] = nunits();
INTEGER(dim)[3] = nseasons();
INTEGER(dim)[4] = nareas();
INTEGER(dim)[5] = niters();
//allocate memory
PROTECT(v = Rf_allocArray(REALSXP, dim));
//Create dimension names
PROTECT(dimnames = allocVector(VECSXP, 6));
PROTECT(d1 = allocVector(INTSXP, maxquant()-minquant() +1));
for (iAge=minquant(),j=0; iAge<=maxquant(); iAge++, j++)
INTEGER(d1)[j] = iAge;
SET_VECTOR_ELT(dimnames, 0, d1);
PROTECT(d2 = allocVector(INTSXP, maxyr()-minyr()+1));
for (iYear=minyr(), j=0; iYear<=maxyr(); iYear++, j++)
INTEGER(d2)[j] = iYear;
SET_VECTOR_ELT(dimnames, 1, d2);
if (nunits()==1)
{
PROTECT(d3 = allocVector(STRSXP, nunits()));
SET_STRING_ELT(d3, 0, mkChar("unique"));
}
else
{
PROTECT(d3 = allocVector(INTSXP, nunits()));
for (iUnit=1, j=0; iUnit<=nunits(); iUnit++, j++)
INTEGER(d3)[j] = iUnit;
}
SET_VECTOR_ELT(dimnames, 2, d3);
if (nseasons()==1)
{
PROTECT(d4 = allocVector(STRSXP, nseasons()));
SET_STRING_ELT(d4, 0, mkChar("all"));
}
else
{
PROTECT(d4 = allocVector(INTSXP, nseasons()));
for (iSeason=1, j=0; iSeason<=nseasons(); iSeason++, j++)
INTEGER(d4)[j] = iSeason;
}
SET_VECTOR_ELT(dimnames, 3, d4);
if (nareas()==1)
{
PROTECT(d5 = allocVector(STRSXP, nareas()));
SET_STRING_ELT(d5, 0, mkChar("unique"));
}
else
{
PROTECT(d5 = allocVector(INTSXP, nareas()));
for (iArea=1, j=0; iArea<=nareas(); iArea++, j++)
INTEGER(d5)[j] = iArea;
}
SET_VECTOR_ELT(dimnames, 4, d5);
PROTECT(d6 = allocVector(INTSXP, niters()));
for (iIter=1, j=0; iIter<=niters(); iIter++, j++)
INTEGER(d6)[j] = iIter;
SET_VECTOR_ELT(dimnames, 5, d6);
//Create names for dimensions
PROTECT(names = allocVector(STRSXP, 6));
SET_STRING_ELT(names, 0, mkChar("age"));
SET_STRING_ELT(names, 1, mkChar("year"));
SET_STRING_ELT(names, 2, mkChar("unit"));
SET_STRING_ELT(names, 3, mkChar("season"));
SET_STRING_ELT(names, 4, mkChar("area"));
SET_STRING_ELT(names, 5, mkChar("iter"));
setAttrib(dimnames, R_NamesSymbol, names);
setAttrib(v, R_DimNamesSymbol, dimnames);
//Set data
j=0;
for(iIter = 1; iIter <= niters(); iIter++)
for (iArea = 1; iArea <= nareas(); iArea++)
for (iSeason = 1; iSeason <= nseasons(); iSeason++)
for (iUnit = 1; iUnit <= nunits(); iUnit++)
for (iYear = minyr(); iYear <= maxyr(); iYear++)
for (iAge = minquant(); iAge <= maxquant(); iAge++)
REAL(v)[j++] = data[i(iAge,iYear,iUnit,iSeason,iArea,iIter)];
//Set slot
Quant = R_do_slot_assign(Quant, install(".Data"), v);
UNPROTECT(11);
return Quant;
}
