/* nag_pls_orth_scores_fit (g02lcc) Example Program.
*
* Copyright 2014 Numerical Algorithms Group.
*
* Mark 9, 2009.
*/
/* Pre-processor includes */
#include <stdio.h>
#include <math.h>
#include <string.h>
#include <nag.h>
#include <nag_stdlib.h>
#include <nagg02.h>
#include <nagx04.h>
int main(void)
{
/*Integer scalar and array declarations */
Integer exit_status = 0;
Integer i, ip, ip1, j, maxfac, my, nfact, vipopt;
Integer pdb, pdc, pdob, pdp, pdvip, pdw, pdycv;
/*Double scalar and array declarations */
double rcond;
double *b = 0, *c = 0, *ob = 0, *p = 0, *vip = 0, *w = 0;
double *xbar = 0, *xstd = 0, *ybar = 0, *ycv = 0, *ystd = 0;
/*Character scalar and array declarations */
char siscale[40], sorig[40];
/*NAG Types */
Nag_OrderType order;
Nag_ScalePredictor iscale;
Nag_EstimatesOption orig;
NagError fail;
INIT_FAIL(fail);
printf("nag_pls_orth_scores_fit (g02lcc) Example Program Results\n");
/* Skip header in data file*/
scanf("%*[^\n] ");
/* Read data values*/
scanf("%ld%ld%ld%ld%39s "
"%39s %ld%*[^\n] ", &ip, &my, &maxfac, &nfact, sorig, siscale,
&vipopt);
orig = (Nag_EstimatesOption) nag_enum_name_to_value(sorig);
iscale = (Nag_ScalePredictor) nag_enum_name_to_value(siscale);
#ifdef NAG_COLUMN_MAJOR
pdb = ip;
#define B(I, J) b[(J-1)*pdb + I-1]
pdc = my;
#define C(I, J) c[(J-1)*pdc + I-1]
pdob = ip+1;
#define OB(I, J) ob[(J-1)*pdob + I-1]
pdp = ip;
#define P(I, J) p[(J-1)*pdp + I-1]
pdvip = ip;
#define VIP(I, J) vip[(J-1)*pdvip + I-1]
pdw = ip;
#define W(I, J) w[(J-1)*pdw + I-1]
pdycv = maxfac;
#define YCV(I, J) ycv[(J-1)*pdycv + I-1]
order = Nag_ColMajor;
#else
pdb = my;
#define B(I, J) b[(I-1)*pdb + J-1]
pdc = maxfac;
#define C(I, J) c[(I-1)*pdc + J-1]
pdob = my;
#define OB(I, J) ob[(I-1)*pdob + J-1]
pdp = maxfac;
#define P(I, J) p[(I-1)*pdp + J-1]
pdvip = vipopt;
#define VIP(I, J) vip[(I-1)*pdvip + J-1]
pdw = maxfac;
#define W(I, J) w[(I-1)*pdw + J-1]
pdycv = my;
#define YCV(I, J) ycv[(I-1)*pdycv + J-1]
order = Nag_RowMajor;
#endif
if (!(b = NAG_ALLOC(pdb*(order == Nag_RowMajor?ip:my), double)) ||
!(c = NAG_ALLOC(pdc*(order == Nag_RowMajor?my:maxfac), double)) ||
!(ob = NAG_ALLOC(pdob*(order == Nag_RowMajor?(ip+1):my),
double)) ||
!(p = NAG_ALLOC(pdp*(order == Nag_RowMajor?ip:maxfac), double)) ||
!(vip = NAG_ALLOC(pdvip*(order == Nag_RowMajor?ip:vipopt),
double)) ||
!(w = NAG_ALLOC(pdw*(order == Nag_RowMajor?ip:maxfac), double)) ||
!(xbar = NAG_ALLOC(ip, double)) ||
!(xstd = NAG_ALLOC(ip, double)) ||
!(ybar = NAG_ALLOC(my, double)) ||
!(ycv = NAG_ALLOC(pdycv*(order == Nag_RowMajor?maxfac:my),
double)) ||
!(ystd = NAG_ALLOC(my, double)))
{
printf("Allocation failure\n");
exit_status = -1;
goto END;
}
/* Read P*/
for (i = 1; i <= ip; i++)
{
for (j = 1; j <= maxfac; j++)
scanf("%lf ", &P(i, j));
}
scanf("%*[^\n] ");
/* Read C*/
for (i = 1; i <= my; i++)
{
for (j = 1; j <= maxfac; j++)
scanf("%lf ", &C(i, j));
}
scanf("%*[^\n] ");
/* Read W*/
for (i = 1; i <= ip; i++)
{
for (j = 1; j <= maxfac; j++)
scanf("%lf ", &W(i, j));
}
scanf("%*[^\n] ");
/* Read YCV*/
for (i = 1; i <= maxfac; i++)
{
for (j = 1; j <= my; j++)
scanf("%lf ", &YCV(i, j));
}
scanf("%*[^\n] ");
/* Read means*/
if (orig == Nag_EstimatesOrig)
{
for (j = 0; j < ip; j++)
scanf("%lf ", &xbar[j]);
scanf("%*[^\n] ");
for (j = 0; j < my; j++)
scanf("%lf ", &ybar[j]);
scanf("%*[^\n] ");
if (iscale != Nag_PredNoScale)
{
for (j = 0; j < ip; j++)
scanf("%lf ", &xstd[j]);
scanf("%*[^\n] ");
for (j = 0; j < my; j++)
scanf("%lf ", &ystd[j]);
scanf("%*[^\n] ");
}
}
/* Calculate predictions*/
rcond = -1.00e0;
ip1 = ip+1;
/*
* nag_pls_orth_scores_fit (g02lcc)
* Partial least-squares
*/
nag_pls_orth_scores_fit(order, ip, my, maxfac, nfact, p, pdp, c, pdc, w,
pdw, rcond, b, pdb, orig, xbar, ybar, iscale, xstd,
ystd, ob, pdob, vipopt, ycv, pdycv, vip,
pdvip, &fail);
if (fail.code != NE_NOERROR)
{
printf("Error from nag_pls_orth_scores_fit (g02lcc).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
/*
* nag_gen_real_mat_print (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip, my,
b, pdb, "B ", 0, &fail);
if (fail.code != NE_NOERROR)
{
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
if (orig == Nag_EstimatesOrig)
{
/*
* nag_gen_real_mat_print (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip1,
my, ob, pdob, "OB", 0, &fail);
if (fail.code != NE_NOERROR)
{
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
}
if (vipopt != 0)
{
/*
* nag_gen_real_mat_print (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip,
vipopt, vip, pdvip, "VIP", 0, &fail);
if (fail.code != NE_NOERROR)
{
printf("Error from nag_gen_real_mat_print (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
}
END:
NAG_FREE(b);
NAG_FREE(c);
NAG_FREE(ob);
NAG_FREE(p);
NAG_FREE(vip);
NAG_FREE(w);
NAG_FREE(xbar);
NAG_FREE(xstd);
NAG_FREE(ybar);
NAG_FREE(ycv);
NAG_FREE(ystd);
return exit_status;
}