Allow ComputeIterate to test maximum absolute change
[openmx:openmx.git] / src / omxMatrix.h
1 /*
2  *  Copyright 2007-2013 The OpenMx Project
3  *
4  *  Licensed under the Apache License, Version 2.0 (the "License");
5  *  you may not use this file except in compliance with the License.
6  *  You may obtain a copy of the License at
7  *
8  *       http://www.apache.org/licenses/LICENSE-2.0
9  *
10  *   Unless required by applicable law or agreed to in writing, software
11  *   distributed under the License is distributed on an "AS IS" BASIS,
12  *   WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
13  *  See the License for the specific language governing permissions and
14  *  limitations under the License.
15  *
16  */
17
18 /***********************************************************
19  *
20  *  omxMatrix.h
21  *
22  *  Created: Timothy R. Brick   Date: 2008-11-13 12:33:06
23  *
24  *      Contains header information for the omxMatrix class
25  *   omxDataMatrices hold necessary information to simplify
26  *      dealings between the OpenMX back end and BLAS.
27  *
28  **********************************************************/
29
30 #ifndef _OMXMATRIX_H_
31 #define _OMXMATRIX_H_
32
33 #include <R.h>
34 #include <Rinternals.h>
35 #include <Rdefines.h>
36 #include <R_ext/Rdynload.h>
37 #include <R_ext/BLAS.h>
38 #include <R_ext/Lapack.h>
39 #include "omxDefines.h"
40 #include "omxBLAS.h"
41
42 #include "types.h"
43
44 #include "omxAlgebra.h"
45 #include "omxFitFunction.h"
46 #include "omxExpectation.h"
47 #include "omxState.h"
48
49
50 struct omxMatrix {                                              // A matrix
51                                                                                 //TODO: Improve encapsulation
52 /* Actually Useful Members */
53         int rows, cols;                                         // Matrix size  (specifically, its leading edge)
54         double* data;                                           // Actual Data Pointer
55         unsigned short colMajor;                        // and column-majority.
56         unsigned short hasMatrixNumber;         // is this object in the matrix or algebra arrays?
57         int matrixNumber;                                       // the offset into the matrices or algebras arrays
58
59         SEXP owner;     // The R object owning data or NULL if we own it.
60
61 /* For aliased matrices */                              // Maybe this should be a subclass, as well.
62         omxMatrix* aliasedPtr;                          // For now, assumes outside data if aliased.
63         unsigned short originalColMajor;        // Saved for reset of aliased matrix.
64         unsigned short originalRows;            // Saved for reset of aliased matrix.
65         unsigned short originalCols;            // Saved for reset of aliased matrix.
66
67 /* For BLAS Multiplication Speedup */   // TODO: Replace some of these with inlines or macros.
68         const char* majority;                           // Filled by compute(), included for speed
69         const char* minority;                           // Filled by compute(), included for speed
70         int leading;                                            // Leading edge; depends on original majority
71         int lagging;                                            // Non-leading edge.
72
73 /* Curent State */
74         omxState* currentState;                         // Optimizer State
75         int cleanVersion;
76         int version;
77         unsigned short isTemporary;                     // Whether or not to destroy the omxMatrix Structure when omxFreeAllMatrixData is called.
78
79 /* For Algebra Functions */                             // At most, one of these may be non-NULL.
80         omxAlgebra* algebra;                            // If it's not an algebra, this is NULL.
81         omxFitFunction* fitFunction;            // If it's not a fit function, this is NULL.
82
83 /* For inclusion in(or of) other matrices */
84         int numPopulateLocations;
85         int *populateFrom;
86         int *populateFromRow, *populateFromCol;
87         int *populateToRow, *populateToCol;
88
89         const char* name;
90 };
91
92 /* Initialize and Destroy */
93         omxMatrix* omxInitMatrix(omxMatrix* om, int nrows, int ncols, unsigned short colMajor, omxState* os);                   // Set up matrix 
94         omxMatrix* omxInitTemporaryMatrix(omxMatrix* om, int nrows, int ncols, unsigned short colMajor, omxState* os);  // Set up matrix that can be freed
95         void omxFreeMatrixData(omxMatrix* om);                                                  // Release any held data.
96         void omxFreeAllMatrixData(omxMatrix* om);                                               // Ditto, traversing argument trees
97
98 /* Matrix Creation Functions */
99         omxMatrix* omxNewMatrixFromRPrimitive(SEXP rObject, omxState *state,
100         unsigned short hasMatrixNumber, int matrixNumber);                                                      // Create an omxMatrix from an R object
101         omxMatrix* omxNewIdentityMatrix(int nrows, omxState* state);                            // Creates an Identity Matrix of a given size
102         extern omxMatrix* omxMatrixLookupFromState1(SEXP matrix, omxState* os); // Create a matrix/algebra from a matrix pointer
103
104         omxMatrix* omxDuplicateMatrix(omxMatrix* src, omxState* newState);
105         SEXP omxExportMatrix(omxMatrix *om);
106
107 /* Getters 'n Setters (static functions declared below) */
108         // static OMXINLINE double omxMatrixElement(omxMatrix *om, int row, int col);
109         // static OMXINLINE double omxVectorElement(omxMatrix *om, int index);
110         // static OMXINLINE void omxSetMatrixElement(omxMatrix *om, int row, int col, double value);
111         // static OMXINLINE void omxSetVectorElement(omxMatrix *om, int index, double value);
112
113         double omxAliasedMatrixElement(omxMatrix *om, int row, int col);                        // Element from unaliased form of the same matrix
114         double* omxLocationOfMatrixElement(omxMatrix *om, int row, int col);
115         void omxMarkDirty(omxMatrix *om);
116         void omxMarkClean(omxMatrix *om);
117
118 /* Matrix Modification Functions */
119         void omxZeroByZeroMatrix(omxMatrix *source);
120         void omxResizeMatrix(omxMatrix *source, int nrows, int ncols,
121                                                         unsigned short keepMemory);                                                                     // Resize, with or without re-initialization
122         omxMatrix* omxFillMatrixFromRPrimitive(omxMatrix* om, SEXP rObject, omxState *state,
123                 unsigned short hasMatrixNumber, int matrixNumber);                                                              // Populate an omxMatrix from an R object
124         void omxProcessMatrixPopulationList(omxMatrix *matrix, SEXP matStruct);
125         void omxCopyMatrix(omxMatrix *dest, omxMatrix *src);                                                            // Copy across another matrix.
126         void omxTransposeMatrix(omxMatrix *mat);                                                                                                // Transpose a matrix in place.
127         void omxToggleRowColumnMajor(omxMatrix *mat);                                                                           // Transform row-major into col-major and vice versa 
128
129 /* Function wrappers that switch based on inclusion of algebras */
130         void omxPrint(omxMatrix *source, const char* d);
131         unsigned short int omxNeedsUpdate(omxMatrix *matrix);                                                           // Does this need to be recomputed?
132         void omxRecompute(omxMatrix *matrix);                                                                                           // Recompute the matrix if needed.
133         void omxForceCompute(omxMatrix *matrix);
134
135 /* Aliased Matrix Functions */
136         void omxAliasMatrix(omxMatrix *alias, omxMatrix* const source);         // Allows aliasing for faster reset.
137         void omxResetAliasedMatrix(omxMatrix *matrix);                                          // Reset to the original matrix
138         void omxRemoveElements(omxMatrix *om, int numRemoved, int removed[]);
139         void omxRemoveRowsAndColumns(omxMatrix* om, int numRowsRemoved, int numColsRemoved, int rowsRemoved[], int colsRemoved[]);
140
141 /* Matrix-Internal Helper functions */
142         void omxMatrixLeadingLagging(omxMatrix *matrix);
143 void omxPrintMatrix(omxMatrix *source, const char* header);
144
145 /* OMXINLINE functions and helper functions */
146
147 void setMatrixError(omxMatrix *om, int row, int col, int numrow, int numcol);
148 void setVectorError(int index, int numrow, int numcol);
149 void matrixElementError(int row, int col, int numrow, int numcol);
150 void vectorElementError(int index, int numrow, int numcol);
151
152 OMXINLINE static bool omxMatrixIsDirty(omxMatrix *om) { return om->cleanVersion != om->version; }
153 OMXINLINE static bool omxMatrixIsClean(omxMatrix *om) { return om->cleanVersion == om->version; }
154 OMXINLINE static int omxGetMatrixVersion(omxMatrix *om) { return om->version; }
155
156 static OMXINLINE int omxIsMatrix(omxMatrix *mat) {
157     return (mat->algebra == NULL && mat->fitFunction == NULL);
158 }
159
160 /* BLAS Wrappers */
161
162 static OMXINLINE void omxSetMatrixElement(omxMatrix *om, int row, int col, double value) {
163         if((row < 0) || (col < 0) || (row >= om->rows) || (col >= om->cols)) {
164                 setMatrixError(om, row + 1, col + 1, om->rows, om->cols);
165                 return;
166         }
167         int index = 0;
168         if(om->colMajor) {
169                 index = col * om->rows + row;
170         } else {
171                 index = row * om->cols + col;
172         }
173         om->data[index] = value;
174 }
175
176 static OMXINLINE void omxAccumulateMatrixElement(omxMatrix *om, int row, int col, double value) {
177         if((row < 0) || (col < 0) || (row >= om->rows) || (col >= om->cols)) {
178                 setMatrixError(om, row + 1, col + 1, om->rows, om->cols);
179                 return;
180         }
181         int index = 0;
182         if(om->colMajor) {
183                 index = col * om->rows + row;
184         } else {
185                 index = row * om->cols + col;
186         }
187         om->data[index] += value;
188 }
189
190 static OMXINLINE double omxMatrixElement(omxMatrix *om, int row, int col) {
191         int index = 0;
192         if((row < 0) || (col < 0) || (row >= om->rows) || (col >= om->cols)) {
193                 matrixElementError(row + 1, col + 1, om->rows, om->cols);
194         return (NA_REAL);
195         }
196         if(om->colMajor) {
197                 index = col * om->rows + row;
198         } else {
199                 index = row * om->cols + col;
200         }
201         return om->data[index];
202 }
203
204 static OMXINLINE double *omxMatrixColumn(omxMatrix *om, int col) {
205   if (!om->colMajor) error("omxMatrixColumn requires colMajor order");
206   if (col < 0 || col >= om->cols) error(0, col, om->rows, om->cols);
207   return om->data + col * om->rows;
208 }
209
210 static OMXINLINE void omxAccumulateVectorElement(omxMatrix *om, int index, double value) {
211         if (index < 0 || index >= (om->rows * om->cols)) {
212                 setVectorError(index + 1, om->rows, om->cols);
213                 return;
214         } else {
215                 om->data[index] += value;
216     }
217 }
218
219 static OMXINLINE void omxSetVectorElement(omxMatrix *om, int index, double value) {
220         if (index < 0 || index >= (om->rows * om->cols)) {
221                 setVectorError(index + 1, om->rows, om->cols);
222                 return;
223         } else {
224                 om->data[index] = value;
225     }
226 }
227
228 static OMXINLINE double omxVectorElement(omxMatrix *om, int index) {
229         if (index < 0 || index >= (om->rows * om->cols)) {
230                 vectorElementError(index + 1, om->rows, om->cols);
231         return (NA_REAL);
232         } else {
233                 return om->data[index];
234     }
235 }
236
237 static OMXINLINE void omxUnsafeSetVectorElement(omxMatrix *om, int index, double value) {
238         om->data[index] = value;
239 }
240
241 static OMXINLINE double omxUnsafeVectorElement(omxMatrix *om, int index) {
242         return om->data[index];
243 }
244
245
246 static OMXINLINE void omxDGEMM(unsigned short int transposeA, unsigned short int transposeB,            // result <- alpha * A %*% B + beta * C
247                                 double alpha, omxMatrix* a, omxMatrix *b, double beta, omxMatrix* result) {
248         int nrow = (transposeA?a->cols:a->rows);
249         int nmid = (transposeA?a->rows:a->cols);
250         int ncol = (transposeB?b->rows:b->cols);
251
252         F77_CALL(omxunsafedgemm)((transposeA?a->minority:a->majority), (transposeB?b->minority:b->majority), 
253                                                         &(nrow), &(ncol), &(nmid),
254                                                         &alpha, a->data, &(a->leading), 
255                                                         b->data, &(b->leading),
256                                                         &beta, result->data, &(result->leading));
257
258         if(!result->colMajor) omxToggleRowColumnMajor(result);
259 }
260
261 static OMXINLINE void omxDGEMV(unsigned short int transposeMat, double alpha, omxMatrix* mat,   // result <- alpha * A %*% B + beta * C
262                                 omxMatrix* vec, double beta, omxMatrix*result) {                                                        // where B is treated as a vector
263         int onei = 1;
264         int nrows = mat->rows;
265         int ncols = mat->cols;
266         if(OMX_DEBUG_DEVELOPER) {
267                 int nVecEl = vec->rows * vec->cols;
268                 // mxLog("DGEMV: %c, %d, %d, %f, 0x%x, %d, 0x%x, %d, 0x%x, %d\n", *(transposeMat?mat->minority:mat->majority), (nrows), (ncols), 
269                 // alpha, mat->data, (mat->leading), vec->data, onei, beta, result->data, onei); //:::DEBUG:::
270                 if((transposeMat && nrows != nVecEl) || (!transposeMat && ncols != nVecEl)) {
271                         error("Mismatch in vector/matrix multiply: %s (%d x %d) * (%d x 1).\n", (transposeMat?"transposed":""), mat->rows, mat->cols, nVecEl); // :::DEBUG:::
272                 }
273         }
274         F77_CALL(omxunsafedgemv)((transposeMat?mat->minority:mat->majority), &(nrows), &(ncols), 
275                 &alpha, mat->data, &(mat->leading), vec->data, &onei, &beta, result->data, &onei);
276         if(!result->colMajor) omxToggleRowColumnMajor(result);
277 }
278
279 static OMXINLINE void omxDSYMV(double alpha, omxMatrix* mat,            // result <- alpha * A %*% B + beta * C
280                                 omxMatrix* vec, double beta, omxMatrix* result) {       // only A is symmetric, and B is a vector
281         char u='U';
282     int onei = 1;
283
284         if(OMX_DEBUG_DEVELOPER) {
285                 int nVecEl = vec->rows * vec->cols;
286                 // mxLog("DSYMV: %c, %d, %f, 0x%x, %d, 0x%x, %d, %f, 0x%x, %d\n", u, (mat->cols),alpha, mat->data, (mat->leading), 
287                             // vec->data, onei, beta, result->data, onei); //:::DEBUG:::
288                 if(mat->cols != nVecEl) {
289                         error("Mismatch in symmetric vector/matrix multiply: %s (%d x %d) * (%d x 1).\n", "symmetric", mat->rows, mat->cols, nVecEl); // :::DEBUG:::
290                 }
291         }
292
293     F77_CALL(dsymv)(&u, &(mat->cols), &alpha, mat->data, &(mat->leading), 
294                     vec->data, &onei, &beta, result->data, &onei);
295
296     // if(!result->colMajor) omxToggleRowColumnMajor(result);
297 }
298
299 static OMXINLINE void omxDSYMM(unsigned short int symmOnLeft, double alpha, omxMatrix* symmetric,               // result <- alpha * A %*% B + beta * C
300                                 omxMatrix *other, double beta, omxMatrix* result) {                                 // One of A or B is symmetric
301
302         char r='R', l = 'L';
303         char u='U';
304         F77_CALL(dsymm)((symmOnLeft?&l:&r), &u, &(result->rows), &(result->cols),
305                                         &alpha, symmetric->data, &(symmetric->leading),
306                                         other->data, &(other->leading),
307                                         &beta, result->data, &(result->leading));
308
309         if(!result->colMajor) omxToggleRowColumnMajor(result);
310 }
311
312 static OMXINLINE int omxDGETRF(omxMatrix* mat, int* ipiv) {                                                                             // LUP decomposition of mat
313         int info = 0;
314         F77_CALL(dgetrf)(&(mat->rows), &(mat->cols), mat->data, &(mat->leading), ipiv, &info);
315         return info;
316 }
317
318 static OMXINLINE int omxDGETRI(omxMatrix* mat, int* ipiv, double* work, int lwork) {                            // Invert mat from LUP decomposition
319         int info = 0;
320         F77_CALL(dgetri)(&(mat->rows), mat->data, &(mat->leading), ipiv, work, &lwork, &info);
321         return info;
322 }
323
324 static OMXINLINE void omxDAXPY(double alpha, omxMatrix* lhs, omxMatrix* rhs) {              // RHS += alpha*lhs  
325     // N.B.  Not fully tested.                                                              // Assumes common majority or vectordom.
326     if(lhs->colMajor != rhs->colMajor) { omxToggleRowColumnMajor(rhs);}
327     int len = lhs->rows * lhs->cols;
328     int onei = 1;
329     F77_CALL(daxpy)(&len, &alpha, lhs->data, &onei, rhs->data, &onei);
330
331 }
332
333 static OMXINLINE double omxDDOT(omxMatrix* lhs, omxMatrix* rhs) {              // returns dot product, as if they were vectors
334     // N.B.  Not fully tested.                                                  // Assumes common majority or vectordom.
335     if(lhs->colMajor != rhs->colMajor) { omxToggleRowColumnMajor(rhs);}
336     int len = lhs->rows * lhs->cols;
337     int onei = 1;
338     return(F77_CALL(ddot)(&len, lhs->data, &onei, rhs->data, &onei));
339 }
340
341 static OMXINLINE void omxDPOTRF(omxMatrix* mat, int* info) {                                                                            // Cholesky decomposition of mat
342         // TODO: Add error checking, and/or adjustments for row vs. column majority.
343         // N.B. Not fully tested.
344         char u = 'U'; //l = 'L'; //U for storing upper triangle
345         F77_CALL(dpotrf)(&u, &(mat->rows), mat->data, &(mat->cols), info);
346 }
347 static OMXINLINE void omxDPOTRI(omxMatrix* mat, int* info) {                                                                            // Invert mat from Cholesky
348         // TODO: Add error checking, and/or adjustments for row vs. column majority.
349         // N.B. Not fully tested.
350         char u = 'U'; //l = 'L'; // U for storing upper triangle
351         F77_CALL(dpotri)(&u, &(mat->rows), mat->data, &(mat->cols), info);
352 }
353
354 void omxShallowInverse(int numIters, omxMatrix* A, omxMatrix* Z, omxMatrix* Ax, omxMatrix* I );
355
356 double omxMaxAbsDiff(omxMatrix *m1, omxMatrix *m2);
357
358 #endif /* _OMXMATRIX_H_ */