1 /*
2 # xts: eXtensible time-series
3 #
4 # Copyright (C) 2008 Jeffrey A. Ryan jeff.a.ryan @ gmail.com
5 #
6 # Contributions from Joshua M. Ulrich
7 #
8 # This program is free software: you can redistribute it and/or modify
9 # it under the terms of the GNU General Public License as published by
10 # the Free Software Foundation, either version 2 of the License, or
11 # (at your option) any later version.
12 #
13 # This program is distributed in the hope that it will be useful,
14 # but WITHOUT ANY WARRANTY; without even the implied warranty of
15 # MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
16 # GNU General Public License for more details.
17 #
18 # You should have received a copy of the GNU General Public License
19 # along with this program. If not, see <http://www.gnu.org/licenses/>.
20 */
21
22
23 #include<R.h>
24 #include<Rdefines.h>
25 #include<Rinternals.h>
26
do_is_ordered(SEXP x,SEXP increasing,SEXP strictly)27 SEXP do_is_ordered (SEXP x, SEXP increasing, SEXP strictly)
28 {
29 int i;
30 int nx = LENGTH(x) - 1;
31 double *real_x;
32 int *int_x;
33
34 /*
35 If length is 0 then it is ordered
36 */
37 if (nx < 0)
38 return ScalarLogical(1);
39
40 if(TYPEOF(x) == REALSXP) {
41 /*
42 Check for increasing order, strict or non-strict
43 */
44 real_x = REAL(x);
45 if(LOGICAL(increasing)[ 0 ] == 1) { /* INCREASING */
46 if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY INCREASING ( > 0 ) */
47 for(i = 0; i < nx; i++) {
48 if( real_x[i+1] <= real_x[i] ) {
49 return ScalarLogical(0);
50 }
51 }
52 } else { /* NOT-STRICTLY ( 0 || > 0 ) */
53 for(i = 0; i < nx; i++) {
54 if( real_x[i+1] < real_x[i] ) {
55 return ScalarLogical(0);
56 }
57 }
58 }
59 /*
60 Check for decreasing order, strict or non-strict
61 */
62 } else {
63 if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY DECREASING ( < 0 ) */
64 for(i = 0; i < nx; i++) {
65 if( real_x[i+1] >= real_x[i] ) {
66 return ScalarLogical(0);
67 }
68 }
69 } else { /* NOT-STRICTLY ( 0 || < 0 ) */
70 for(i = 0; i < nx; i++) {
71 if( real_x[i+1] > real_x[i] ) {
72 return ScalarLogical(0);
73 }
74 }
75 }
76 }
77
78 } else
79 if(TYPEOF(x) == INTSXP) {
80 /*
81 Check for increasing order, strict or non-strict
82 */
83 int_x = INTEGER(x);
84 if(LOGICAL(increasing)[ 0 ] == 1) { /* INCREASING */
85 /* Not increasing order if first element is NA. We know x has at least 1 element. */
86 if( int_x[0] == NA_INTEGER )
87 return ScalarLogical(0);
88
89 if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY INCREASING ( > 0 ) */
90 for(i = 0; i < nx; i++) {
91 if( int_x[i+1] <= int_x[i] ) {
92 if (i == (nx-1) && int_x[i+1] == NA_INTEGER) {
93 continue; /* OK if NA is last element */
94 }
95 return ScalarLogical(0);
96 }
97 }
98 } else { /* NOT-STRICTLY ( 0 || > 0 ) */
99 for(i = 0; i < nx; i++) {
100 if( int_x[i+1] < int_x[i] ) {
101 if (i == (nx-1) && int_x[i+1] == NA_INTEGER) {
102 continue; /* OK if NA is last element */
103 }
104 return ScalarLogical(0);
105 }
106 }
107 }
108 /*
109 Check for decreasing order, strict or non-strict
110 */
111 } else { /* DECREASING */
112 /* Not decreasing order if last element is NA */
113 if( int_x[nx] == NA_INTEGER )
114 return ScalarLogical(0);
115
116 if(LOGICAL(strictly)[ 0 ] == 1) { /* STRICTLY DECREASING ( < 0 ) */
117 for(i = 0; i < nx; i++) {
118 if( int_x[i+1] >= int_x[i] ) {
119 if (i == 0 && int_x[i] == NA_INTEGER) {
120 continue; /* OK if NA is first element */
121 }
122 return ScalarLogical(0);
123 }
124 }
125 } else { /* NOT-STRICTLY ( 0 || < 0 ) */
126 for(i = 0; i < nx; i++) {
127 if( int_x[i+1] > int_x[i] ) {
128 if (i == 0 && int_x[i] == NA_INTEGER) {
129 continue; /* OK if NA is first element */
130 }
131 return ScalarLogical(0);
132 }
133 }
134 }
135 }
136
137 } else {
138 error("'x' must be of type double or integer");
139 }
140
141 return ScalarLogical(1); /* default to true */
142 }
143