SCM

SCM Repository

[matrix] Diff of /pkg/src/lmeRep.c
ViewVC logotype

Diff of /pkg/src/lmeRep.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 256, Fri Aug 20 16:27:56 2004 UTC revision 257, Tue Aug 24 02:08:08 2004 UTC
# Line 17  Line 17 
17      return ans;      return ans;
18  }  }
19    
20    static
21    SEXP lmeRep_alloc3Darray(int TYP, int nr, int nc, int nf)
22    {
23        SEXP val, dd = PROTECT(allocVector(INTSXP, 3));
24    
25        INTEGER(dd)[0] = nr; INTEGER(dd)[1] = nc; INTEGER(dd)[2] = nf;
26        val = allocArray(TYP, dd);
27        UNPROTECT(1);
28        return val;
29    }
30    
31  SEXP lmeRep_validate(SEXP x)  SEXP lmeRep_validate(SEXP x)
32  {  {
33      /* FIXME: add checks for correct dimensions, modes, etc. */      /* FIXME: add checks for correct dimensions, modes, etc. */
34      return ScalarLogical(1);      return ScalarLogical(1);
35  }  }
36    
37  static  SEXP
38  SEXP lmeRep_alloc3Darray(int TYP, int nr, int nc, int nf)  lmeRep_crosstab(SEXP facs)
39  {  {
40      SEXP val, dd = PROTECT(allocVector(INTSXP, 3));      int I = length(facs), nobs, pos = 0;
41        int Ic2 = (I * (I - 1))/2;  /* I choose 2 */
42        SEXP fac, levs, val = PROTECT(allocVector(VECSXP, Ic2));
43    
44      INTEGER(dd)[0] = nr; INTEGER(dd)[1] = nc; INTEGER(dd)[2] = nf;      if (!isNewList(facs))
45      val = allocArray(TYP, dd);          error("Argument facs must be a list");
46        nobs = length(VECTOR_ELT(facs, 0));
47    
48        if (Ic2 > 0) {
49            int i, j, k, *nlevs = Calloc(I, int), *itmp = Calloc(nobs, int),
50                *zb = Calloc(nobs * I, int); /* zero-based indices */
51            double *xtmp = Calloc(nobs, double), *atmp = Calloc(nobs, double);
52    
53            for (i = 0; i < nobs; i++) xtmp[i] = 1.;
54            for (i = 0; i < I; i++) {
55                fac = VECTOR_ELT(facs, i);
56                if (!isFactor(fac) || length(fac) <= 0)
57                    error("All elements of facs must be nonnull factors");
58                if (length(fac) != nobs)
59                    error("All elements of facs must have the same length");
60                nlevs[i] = length(getAttrib(fac, R_LevelsSymbol));
61                for (k = 0; k < nobs; k++) zb[i * nobs + k] = INTEGER(fac)[k] - 1;
62                for (j = 0; j < i; j++) {
63                    SEXP mm;
64                    int *Dims, *mp, *mi, nz;
65                    double *mx;
66    
67                    SET_VECTOR_ELT(val, pos, NEW_OBJECT(MAKE_CLASS("cscMatrix")));
68                    mm = VECTOR_ELT(val, pos);
69                    SET_SLOT(mm, Matrix_DimSym, allocVector(INTSXP, 2));
70                    Dims = INTEGER(GET_SLOT(mm, Matrix_DimSym));
71                    Dims[0] = nlevs[i]; Dims[1] = nlevs[j];
72                    SET_SLOT(mm, Matrix_pSym, allocVector(INTSXP, nlevs[j] + 1));
73                    mp = INTEGER(GET_SLOT(mm, Matrix_pSym));
74                    triplet_to_col(nlevs[i], nlevs[j], nobs,
75                                   zb + i * nobs, zb + j * nobs,
76                                   xtmp, mp, itmp, atmp);
77                    nz = mp[nlevs[j]];
78                    SET_SLOT(mm, Matrix_iSym, allocVector(INTSXP, nz));
79                    mi = INTEGER(GET_SLOT(mm, Matrix_iSym));
80                    SET_SLOT(mm, Matrix_xSym, allocVector(REALSXP, nz));
81                    mx = REAL(GET_SLOT(mm, Matrix_xSym));
82                    for (k = 0; k < nz; k++) {
83                        mx[k] = atmp[k];
84                        mi[k] = itmp[k];
85                    }
86                    pos++;
87                }
88            }
89            Free(nlevs); Free(itmp); Free(xtmp); Free(atmp); Free(zb);
90        }
91      UNPROTECT(1);      UNPROTECT(1);
92      return val;      return val;
93  }  }

Legend:
Removed from v.256  
changed lines
  Added in v.257

root@r-forge.r-project.org
ViewVC Help
Powered by ViewVC 1.0.0  
Thanks to:
Vienna University of Economics and Business Powered By FusionForge