Matrix r5059
Loading...
Searching...
No Matches
perm.c
Go to the documentation of this file.
1#include "Mdefines.h"
2
3int isPerm(const int *p, int n, int off)
4{
5 int ans = 1;
6 if (n <= 0)
7 return ans;
8 int i, j;
9 char *work;
10 Matrix_Calloc(work, n, char);
11 for (i = 0; i < n; ++i) {
12 if (p[i] == NA_INTEGER || (j = p[i] - off) < 0 || j >= n || work[j]) {
13 ans = 0;
14 break;
15 }
16 work[j] = 1;
17 }
18 Matrix_Free(work, n);
19 return ans;
20}
21
22int signPerm(const int *p, int n, int off)
23{
24 if (!isPerm(p, n, off))
25 Rf_error(_("attempt to get sign of non-permutation"));
26 int sign = 1;
27 if (n <= 0)
28 return sign;
29 int i, pos = 0;
30 char *work;
31 Matrix_Calloc(work, n, char);
32 while (pos < n) {
33 work[pos] = 1;
34 i = p[pos] - off;
35 while (!work[i]) { /* transposition */
36 sign = -sign;
37 work[i] = 1;
38 i = p[i] - off;
39 }
40 while (pos < n && work[pos])
41 ++pos;
42 }
43 Matrix_Free(work, n);
44 return sign;
45}
46
47void invertPerm(const int *p, int *ip, int n, int off, int ioff)
48{
49 if (!isPerm(p, n, off))
50 Rf_error(_("attempt to invert non-permutation"));
51 int j;
52 for (j = 0; j < n; ++j)
53 ip[p[j] - off] = j + ioff;
54 return;
55}
56
57void asPerm(const int *p, int *ip, int m, int n, int off, int ioff)
58{
59 int i, j, tmp;
60 for (i = 0; i < n; ++i)
61 ip[i] = i + ioff;
62 for (i = 0; i < m; ++i) {
63 j = p[i] - off;
64 if (j < 0 || j >= n)
65 Rf_error(_("invalid transposition vector"));
66 if (j != i) {
67 tmp = ip[j];
68 ip[j] = ip[i];
69 ip[i] = tmp;
70 }
71 }
72 return;
73}
74
75SEXP R_isPerm(SEXP s_p, SEXP s_off)
76{
77 if (TYPEOF(s_p) != INTSXP)
78 Rf_error(_("'%s' is not of type \"%s\""), "p", "integer");
79 if (TYPEOF(s_off) != INTSXP)
80 Rf_error(_("'%s' is not of type \"%s\""), "off", "integer");
81 if (XLENGTH(s_off) != 1)
82 Rf_error(_("'%s' does not have length %d"), "off", 1);
83 int off = INTEGER(s_off)[0];
84 if (off == NA_INTEGER)
85 Rf_error(_("'%s' is NA"), "off");
86 R_xlen_t n = XLENGTH(s_p);
87 if (n > INT_MAX)
88 return Rf_ScalarLogical(0);
89 return Rf_ScalarLogical(isPerm(INTEGER(s_p), (int) n, off));
90}
91
92SEXP R_signPerm(SEXP s_p, SEXP s_off)
93{
94 if (TYPEOF(s_p) != INTSXP)
95 Rf_error(_("'%s' is not of type \"%s\""), "p", "integer");
96 if (TYPEOF(s_off) != INTSXP)
97 Rf_error(_("'%s' is not of type \"%s\""), "off", "integer");
98 if (XLENGTH(s_off) != 1)
99 Rf_error(_("'%s' does not have length %d"), "off", 1);
100 int off = INTEGER(s_off)[0];
101 if (off == NA_INTEGER)
102 Rf_error(_("'%s' is NA"), "off");
103 R_xlen_t n = XLENGTH(s_p);
104 if (n > INT_MAX)
105 Rf_error(_("attempt to get sign of non-permutation"));
106 return Rf_ScalarInteger(signPerm(INTEGER(s_p), (int) n, off));
107}
108
109SEXP R_invertPerm(SEXP s_p, SEXP s_off, SEXP s_ioff)
110{
111 if (TYPEOF(s_p) != INTSXP)
112 Rf_error(_("'%s' is not of type \"%s\""),
113 "p", "integer");
114 if (TYPEOF(s_off) != INTSXP || TYPEOF(s_ioff) != INTSXP)
115 Rf_error(_("'%s' or '%s' is not of type \"%s\""),
116 "off", "ioff", "integer");
117 if (XLENGTH(s_off) != 1 || XLENGTH(s_ioff) != 1)
118 Rf_error(_("'%s' or '%s' does not have length %d"),
119 "off", "ioff", 1);
120 int off = INTEGER(s_off)[0], ioff = INTEGER(s_ioff)[0];
121 if (off == NA_INTEGER || ioff == NA_INTEGER)
122 Rf_error(_("'%s' or '%s' is NA"),
123 "off", "ioff");
124 R_xlen_t n = XLENGTH(s_p);
125 if (n > INT_MAX)
126 Rf_error(_("attempt to invert non-permutation"));
127 SEXP ip = PROTECT(Rf_allocVector(INTSXP, n));
128 invertPerm(INTEGER(s_p), INTEGER(ip), (int) n, off, ioff);
129 UNPROTECT(1);
130 return ip;
131}
132
133SEXP R_asPerm(SEXP s_p, SEXP s_off, SEXP s_ioff, SEXP s_n)
134{
135 if (TYPEOF(s_p) != INTSXP)
136 Rf_error(_("'%s' is not of type \"%s\""),
137 "p", "integer");
138 R_xlen_t m = XLENGTH(s_p);
139 if (m > INT_MAX)
140 Rf_error(_("'%s' has length exceeding %s"),
141 "p", "2^31-1");
142 if (TYPEOF(s_off) != INTSXP || TYPEOF(s_ioff) != INTSXP)
143 Rf_error(_("'%s' or '%s' is not of type \"%s\""),
144 "off", "ioff", "integer");
145 if (XLENGTH(s_off) != 1 || XLENGTH(s_ioff) != 1)
146 Rf_error(_("'%s' or '%s' does not have length %d"),
147 "off", "ioff", 1);
148 int off = INTEGER(s_off)[0], ioff = INTEGER(s_ioff)[0];
149 if (off == NA_INTEGER || ioff == NA_INTEGER)
150 Rf_error(_("'%s' or '%s' is NA"),
151 "off", "ioff");
152 if (TYPEOF(s_n) != INTSXP)
153 Rf_error(_("'%s' is not of type \"%s\""),
154 "n", "integer");
155 if (XLENGTH(s_n) != 1)
156 Rf_error(_("'%s' does not have length %d"),
157 "n", 1);
158 int n = INTEGER(s_n)[0];
159 if (n == NA_INTEGER || n < m)
160 Rf_error(_("'%s' is NA or less than %s"),
161 "n", "length(p)");
162 SEXP ip = PROTECT(Rf_allocVector(INTSXP, n));
163 asPerm(INTEGER(s_p), INTEGER(ip), (int) m, n, off, ioff);
164 UNPROTECT(1);
165 return ip;
166}
#define Matrix_Calloc(p, n, t)
Definition Mdefines.h:45
#define _(String)
Definition Mdefines.h:66
#define Matrix_Free(p, n)
Definition Mdefines.h:56
#define TYPEOF(s)
Definition Mdefines.h:123
SEXP R_invertPerm(SEXP s_p, SEXP s_off, SEXP s_ioff)
Definition perm.c:109
void asPerm(const int *p, int *ip, int m, int n, int off, int ioff)
Definition perm.c:57
SEXP R_signPerm(SEXP s_p, SEXP s_off)
Definition perm.c:92
SEXP R_asPerm(SEXP s_p, SEXP s_off, SEXP s_ioff, SEXP s_n)
Definition perm.c:133
int isPerm(const int *p, int n, int off)
Definition perm.c:3
void invertPerm(const int *p, int *ip, int n, int off, int ioff)
Definition perm.c:47
SEXP R_isPerm(SEXP s_p, SEXP s_off)
Definition perm.c:75
int signPerm(const int *p, int n, int off)
Definition perm.c:22