/* nag_correg_pls_wold (g02lbc) Example Program.
*
* Copyright 2024 Numerical Algorithms Group.
*
* Mark 30.0, 2024.
*/
/* Pre-processor includes */
#include <math.h>
#include <nag.h>
#include <stdio.h>
int main(void) {
/*Integer scalar and array declarations */
Integer exit_status = 0;
Integer i, ip, j, maxfac, maxit, mx, my, n;
Integer pdc, pdp, pdt, pdu, pdw, pdx, pdxres, pdy, pdycv, pdyres;
Integer *isx = 0;
/*Double scalar and array declarations */
double tau;
double *c = 0, *p = 0, *t = 0, *u = 0, *w = 0, *x = 0, *xbar = 0;
double *xcv = 0, *xres = 0, *xstd = 0, *y = 0, *ybar = 0;
double *ycv = 0, *yres = 0, *ystd = 0;
/*Character scalar and array declarations */
char siscale[40];
/*NAG Types */
Nag_OrderType order;
Nag_ScalePredictor iscale;
NagError fail;
INIT_FAIL(fail);
printf("nag_correg_pls_wold (g02lbc) Example Program Results\n");
/* Skip header in data file. */
scanf("%*[^\n] ");
/* Read data values. */
scanf("%" NAG_IFMT "%" NAG_IFMT "%" NAG_IFMT "%39s %" NAG_IFMT "%*[^\n] ", &n,
&mx, &my, siscale, &maxfac);
iscale = (Nag_ScalePredictor)nag_enum_name_to_value(siscale);
if (!(isx = NAG_ALLOC(mx, Integer))) {
printf("Allocation failure\n");
exit_status = -1;
goto END;
}
for (j = 0; j < mx; j++)
scanf("%" NAG_IFMT " ", &isx[j]);
scanf("%*[^\n] ");
ip = 0;
for (j = 0; j < mx; j++) {
if (isx[j] == 1)
ip = ip + 1;
}
#ifdef NAG_COLUMN_MAJOR
pdc = my;
pdp = ip;
pdt = n;
pdu = n;
pdw = ip;
pdx = n;
#define X(I, J) x[(J - 1) * pdx + I - 1]
pdxres = n;
pdy = n;
#define Y(I, J) y[(J - 1) * pdy + I - 1]
pdycv = maxfac;
#define YCV(I, J) ycv[(J - 1) * pdycv + I - 1]
pdyres = n;
order = Nag_ColMajor;
#else
pdc = maxfac;
pdp = maxfac;
pdt = maxfac;
pdu = maxfac;
pdw = maxfac;
pdx = mx;
#define X(I, J) x[(I - 1) * pdx + J - 1]
pdxres = ip;
pdy = my;
#define Y(I, J) y[(I - 1) * pdy + J - 1]
pdycv = my;
#define YCV(I, J) ycv[(I - 1) * pdycv + J - 1]
pdyres = my;
order = Nag_RowMajor;
#endif
if (!(c = NAG_ALLOC(pdc * (order == Nag_RowMajor ? my : maxfac), double)) ||
!(p = NAG_ALLOC(pdp * (order == Nag_RowMajor ? ip : maxfac), double)) ||
!(t = NAG_ALLOC(pdt * (order == Nag_RowMajor ? n : maxfac), double)) ||
!(u = NAG_ALLOC(pdu * (order == Nag_RowMajor ? n : maxfac), double)) ||
!(w = NAG_ALLOC(pdw * (order == Nag_RowMajor ? ip : maxfac), double)) ||
!(x = NAG_ALLOC(pdx * (order == Nag_RowMajor ? n : mx), double)) ||
!(xbar = NAG_ALLOC(ip, double)) || !(xcv = NAG_ALLOC(maxfac, double)) ||
!(xres = NAG_ALLOC(pdxres * (order == Nag_RowMajor ? n : ip), double)) ||
!(xstd = NAG_ALLOC(ip, double)) ||
!(y = NAG_ALLOC(pdy * (order == Nag_RowMajor ? n : my), double)) ||
!(ybar = NAG_ALLOC(my, double)) ||
!(ycv =
NAG_ALLOC(pdycv * (order == Nag_RowMajor ? maxfac : my), double)) ||
!(yres = NAG_ALLOC(pdyres * (order == Nag_RowMajor ? n : my), double)) ||
!(ystd = NAG_ALLOC(my, double))) {
printf("Allocation failure\n");
exit_status = -1;
goto END;
}
maxit = 200;
tau = 1.00e-4;
/* Read data values. */
for (i = 1; i <= n; i++) {
for (j = 1; j <= mx; j++)
scanf("%lf ", &X(i, j));
for (j = 1; j <= my; j++)
scanf("%lf ", &Y(i, j));
}
scanf("%*[^\n] ");
/* Fit a PLS model. */
/*
* nag_correg_pls_wold (g02lbc)
* Partial least squares
*/
nag_correg_pls_wold(order, n, mx, x, pdx, isx, ip, my, y, pdy, xbar, ybar,
iscale, xstd, ystd, maxfac, maxit, tau, xres, pdxres,
yres, pdyres, w, pdw, p, pdp, t, pdt, c, pdc, u, pdu, xcv,
ycv, pdycv, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_correg_pls_wold (g02lbc).\n%s\n", fail.message);
exit_status = 1;
goto END;
}
/*
* nag_file_print_matrix_real_gen (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_file_print_matrix_real_gen(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip,
maxfac, p, pdp, "x-loadings, P", 0, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_file_print_matrix_real_gen (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
/*
* nag_file_print_matrix_real_gen (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_file_print_matrix_real_gen(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n,
maxfac, t, pdt, "x-scores, T", 0, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_file_print_matrix_real_gen (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
/*
* nag_file_print_matrix_real_gen (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_file_print_matrix_real_gen(order, Nag_GeneralMatrix, Nag_NonUnitDiag, my,
maxfac, c, pdc, "y-loadings, C", 0, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_file_print_matrix_real_gen (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
/*
* nag_file_print_matrix_real_gen (x04cac)
* Print real general matrix (easy-to-use)
*/
fflush(stdout);
nag_file_print_matrix_real_gen(order, Nag_GeneralMatrix, Nag_NonUnitDiag, n,
maxfac, u, pdu, "y-scores, U", 0, &fail);
if (fail.code != NE_NOERROR) {
printf("Error from nag_file_print_matrix_real_gen (x04cac).\n%s\n",
fail.message);
exit_status = 1;
goto END;
}
printf("\n");
printf("%s\n", "Explained Variance");
printf("%12s %21s\n", "Model effects", "Dependent variable(s)");
for (i = 1; i <= maxfac; i++) {
printf("%12.6f", xcv[i - 1]);
for (j = 1; j <= my; j++)
printf(" %12.6f%s", YCV(i, j), j % 9 ? " " : "\n");
printf("\n");
}
END:
NAG_FREE(c);
NAG_FREE(p);
NAG_FREE(t);
NAG_FREE(u);
NAG_FREE(w);
NAG_FREE(x);
NAG_FREE(xbar);
NAG_FREE(xcv);
NAG_FREE(xres);
NAG_FREE(xstd);
NAG_FREE(y);
NAG_FREE(ybar);
NAG_FREE(ycv);
NAG_FREE(yres);
NAG_FREE(ystd);
NAG_FREE(isx);
return exit_status;
}