/* nag_pls_orth_scores_fit (g02lcc) Example Program. * * Copyright 2008, Numerical Algorithms Group. * * Mark 9, 2009. */ /* Pre-processor includes */ #include #include #include #include #include #include #include int main(int argc, char *argv[]) { FILE *fpin, *fpout; char *outfile = 0; /*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[18], sorig[24]; /*NAG Types */ Nag_OrderType order; Nag_ScalePredictor iscale; Nag_EstimatesOption orig; NagError fail; INIT_FAIL(fail); /* Check for command-line IO options */ fpin = nag_example_file_io(argc, argv, "-data", NULL); fpout = nag_example_file_io(argc, argv, "-results", NULL); (void) nag_example_file_io(argc, argv, "-nag_write", &outfile); fprintf(fpout, "%s\n", "nag_pls_orth_scores_fit (g02lcc) Example Program Results"); /* Skip header in data file*/ fscanf(fpin, "%*[^\n] "); /* Read data values*/ fscanf(fpin, "%ld%ld%ld%ld%s " "%s %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))) { fprintf(fpout, "Allocation failure\n"); exit_status = -1; goto END; } /* Read P*/ for (i = 1; i <= ip; i++) { for (j = 1; j <= maxfac; j++) fscanf(fpin, "%lf ", &P(i, j)); } fscanf(fpin, "%*[^\n] "); /* Read C*/ for (i = 1; i <= my; i++) { for (j = 1; j <= maxfac; j++) fscanf(fpin, "%lf ", &C(i, j)); } fscanf(fpin, "%*[^\n] "); /* Read W*/ for (i = 1; i <= ip; i++) { for (j = 1; j <= maxfac; j++) fscanf(fpin, "%lf ", &W(i, j)); } fscanf(fpin, "%*[^\n] "); /* Read YCV*/ for (i = 1; i <= maxfac; i++) { for (j = 1; j <= my; j++) fscanf(fpin, "%lf ", &YCV(i, j)); } fscanf(fpin, "%*[^\n] "); /* Read means*/ if (orig == Nag_EstimatesOrig) { for (j = 0; j < ip; j++) fscanf(fpin, "%lf ", &xbar[j]); fscanf(fpin, "%*[^\n] "); for (j = 0; j < my; j++) fscanf(fpin, "%lf ", &ybar[j]); fscanf(fpin, "%*[^\n] "); if (iscale != Nag_PredNoScale) { for (j = 0; j < ip; j++) fscanf(fpin, "%lf ", &xstd[j]); fscanf(fpin, "%*[^\n] "); for (j = 0; j < my; j++) fscanf(fpin, "%lf ", &ystd[j]); fscanf(fpin, "%*[^\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) { fprintf(fpout, "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) */ if (outfile) fclose(fpout); nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip, my, b, pdb, "B ", outfile, &fail); if (outfile && !(fpout = fopen(outfile, "a"))) { exit_status = 2; goto END; } if (fail.code != NE_NOERROR) { fprintf(fpout, "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) */ if (outfile) fclose(fpout); nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip1, my, ob, pdob, "OB", outfile, &fail); if (outfile && !(fpout = fopen(outfile, "a"))) { exit_status = 2; goto END; } if (fail.code != NE_NOERROR) { fprintf(fpout, "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) */ if (outfile) fclose(fpout); nag_gen_real_mat_print(order, Nag_GeneralMatrix, Nag_NonUnitDiag, ip, vipopt, vip, pdvip, "VIP", outfile, &fail); if (outfile && !(fpout = fopen(outfile, "a"))) { exit_status = 2; goto END; } if (fail.code != NE_NOERROR) { fprintf(fpout, "Error from nag_gen_real_mat_print (x04cac).\n%s\n", fail.message); exit_status = 1; goto END; } } END: if (fpin != stdin) fclose(fpin); if (fpout != stdout) fclose(fpout); if (b) NAG_FREE(b); if (c) NAG_FREE(c); if (ob) NAG_FREE(ob); if (p) NAG_FREE(p); if (vip) NAG_FREE(vip); if (w) NAG_FREE(w); if (xbar) NAG_FREE(xbar); if (xstd) NAG_FREE(xstd); if (ybar) NAG_FREE(ybar); if (ycv) NAG_FREE(ycv); if (ystd) NAG_FREE(ystd); return exit_status; }