SEXP exactmean(SEXP x){
SEXP ans;
listnode expansion;
size_t n;
expansion.next = NULL;
n = dplRlength(x);
ans = PROTECT(allocVector(REALSXP, 1));
/* Note: x must be a numeric vector */
REAL(ans)[0] = msum(REAL(x), n, &expansion) / n;
UNPROTECT(1);
return ans;
}
SEXP tbrm(SEXP x, SEXP C){
SEXP ans, C2;
Rboolean n_odd;
int i, half, my_count, n;
size_t nlong;
double C_val, this_val, min_val, div_const, x_med, this_wt;
double *x2, *abs_x_dev, *wt, *wtx, *x_p;
listnode tmp;
nlong = dplRlength(x);
/* Long vectors not supported (limitation of rPsort) */
if (nlong > INT_MAX) {
error(_("long vectors not supported"));
}
C2 = PROTECT(coerceVector(C, REALSXP));
if (length(C2) != 1) {
UNPROTECT(1);
error(_("length of 'C' must be 1"));
}
C_val = REAL(C2)[0];
UNPROTECT(1);
n = (int) nlong;
ans = PROTECT(allocVector(REALSXP, 1));
/* Avoid complexity and possible crash in case of empty input
* vector */
if(n == 0){
REAL(ans)[0] = R_NaN;
UNPROTECT(1);
return ans;
}
/* Note: x must be a numeric vector */
x_p = REAL(x);
/* x2 is a copy of the data part of argument x */
x2 = (double *) R_alloc(n, sizeof(double));
for(i = 0; i < n; i++)
x2[i] = x_p[i];
/* Median of x */
if((n & 0x1) == 1){ /* n is odd */
half = ((unsigned int)n) >> 1;
rPsort(x2, n, half); /* Partial sort: */
x_med = x2[half]; /* element at position half is correct.*/
n_odd = TRUE;
} else { /* n is even */
/* Written by Mikko Korpela */
SEXP sens1(SEXP x){
SEXP ans;
size_t i, n;
dplr_double sum, previous, this, term;
double *x_const;
listnode tmp, *tmp_p;
n = dplRlength(x);
ans = PROTECT(allocVector(REALSXP, 1));
if(n < 2){
REAL(ans)[0] = R_NaN;
UNPROTECT(1);
return ans;
}
/* Note: x must be a numeric vector */
x_const = REAL(x);
/* Setup for grow_exp */
tmp.next = NULL;
tmp.valid = FALSE;
tmp_p = &tmp;
for(i = 1; i < n; i++){
previous = x_const[i-1];
this = x_const[i];
term = (this>previous?this-previous:previous-this)/(this+previous);
if(!ISNAN(((double)term)))
grow_exp(tmp_p, term);
}
/* Sum of scaled absolute differences */
sum = 0.0f;
while(tmp_p != NULL && tmp_p->valid == TRUE){
sum += tmp_p->data;
tmp_p = tmp_p->next;
}
REAL(ans)[0] = (sum+sum)/(n-1);
UNPROTECT(1);
return ans;
}
/* Written by Mikko Korpela */
SEXP sens2(SEXP x){
SEXP ans;
size_t i, n;
double previous, this, next;
double *x_const;
dplr_double sum1, sum2;
listnode tmp, *tmp_p;
n = dplRlength(x);
ans = PROTECT(allocVector(REALSXP, 1));
if(n < 2){
REAL(ans)[0] = R_NaN;
UNPROTECT(1);
return ans;
}
/* Note: x must be a numeric vector */
x_const = REAL(x);
/* Setup for grow_exp and msum */
tmp.next = NULL;
tmp.valid = FALSE;
tmp_p = &tmp;
/* In the sum of absolute differences between consecutive elements
of an array, each number will appear multiplied by -2, -1, 0,
1, or 2 (first and last number by -1, 0, or 1) */
this = x_const[0];
next = x_const[1];
if(this > next){
grow_exp(tmp_p, this);
} else if(this < next){
grow_exp(tmp_p, -this);
}
for(i = 1; i < n-1; i++){
previous = x_const[i-1];
this = x_const[i];
next = x_const[i+1];
if(this > previous){
if(this > next){
grow_exp(tmp_p, this);
grow_exp(tmp_p, this);
} else if(this == next){
grow_exp(tmp_p, this);
}
} else if(this < previous){
if(this < next){
grow_exp(tmp_p, -this);
grow_exp(tmp_p, -this);
} else if(this == next){
grow_exp(tmp_p, -this);
}
} else if(this > next){
grow_exp(tmp_p, this);
} else if(this < next){
grow_exp(tmp_p, -this);
}
}
this = x_const[n-1];
previous = x_const[n-2];
if(this > previous){
grow_exp(tmp_p, this);
} else if(this < previous){
grow_exp(tmp_p, -this);
}
/* Sum of absolute differences */
sum1 = 0.0f;
while(tmp_p != NULL && tmp_p->valid == TRUE){
sum1 += tmp_p->data;
tmp_p = tmp_p->next;
}
sum2 = msum(x_const, n, &tmp);
REAL(ans)[0] = sum1/(sum2-sum2/n);
UNPROTECT(1);
return ans;
}
/* Written by Mikko Korpela */
SEXP readloop(SEXP series_index, SEXP decade, SEXP x) {
SEXP ans, dims, rw_mat, prec_rproc;
size_t i, x_nrow, rw_nrow, rw_ncol, x_idx;
int j, x_ncol, yr_idx, rw_idx, this_series, this_val, min_year, max_year;
int span, this_decade, last_valid, nseries;
int *series_index_p, *decade_p, *x_p, *prec_rproc_p, *last_yr;
double stop_marker;
double *dims_p, *rw_vec;
/* Safety checks */
if (!(isInteger(series_index) && isInteger(decade) && isInteger(x))) {
error(_("all arguments must be integers"));
}
/* Dimensions of x */
dims = PROTECT(coerceVector(getAttrib(x, R_DimSymbol), REALSXP));
if (length(dims) != 2) {
UNPROTECT(1);
error(_("'x' must be a matrix"));
}
dims_p = REAL(dims);
/* Nominally max 10 years per row, allow a few more */
if (dims_p[1] > 100) {
UNPROTECT(1);
error(_("too many columns in 'x'"));
}
x_nrow = (size_t) dims_p[0];
x_ncol = (int) dims_p[1];
UNPROTECT(1);
/* More safety checks */
if (!(dplRlength(series_index) == x_nrow &&
dplRlength(decade) == x_nrow)) {
error(_("dimensions of 'x', 'series_index' and 'decade' must match"));
}
series_index_p = INTEGER(series_index);
decade_p = INTEGER(decade);
x_p = INTEGER(x);
/* Calculate dimensions of result matrix */
nseries = 0;
min_year = INT_MAX;
max_year = INT_MIN;
for (i = 0; i < x_nrow; i++) {
if (series_index_p[i] < 1) {
error(_("'series_index' must be positive"));
}
nseries = imax2(nseries, series_index_p[i]);
this_decade = decade_p[i];
j = x_ncol - 1;
x_idx = i + j * x_nrow;
while (j >= 0 && x_p[x_idx] == NA_INTEGER) {
--j;
x_idx -= x_nrow;
}
if (j >= 0) {
min_year = imin2(min_year, this_decade);
max_year = imax2(max_year, this_decade + j);
}
}
if (max_year >= min_year) {
if (max_year >= 0 && min_year < max_year - R_INT_MAX + 1)
error(_("Number of years exceeds integer range"));
span = max_year - min_year + 1;
} else {
min_year = NA_INTEGER;
span = 0;
}
rw_nrow = (size_t) span;
rw_ncol = (size_t) nseries;
/* List for results: rw_mat, min_year, prec_rproc */
ans = PROTECT(allocVector(VECSXP, 3));
rw_mat = SET_VECTOR_ELT(ans, 0, allocMatrix(REALSXP, span, nseries));
rw_vec = REAL(rw_mat);
for (i = 0; i < rw_nrow * rw_ncol; i++) {
rw_vec[i] = NA_REAL;
}
SET_VECTOR_ELT(ans, 1, ScalarInteger(min_year));
prec_rproc = SET_VECTOR_ELT(ans, 2, allocVector(INTSXP, nseries));
prec_rproc_p = INTEGER(prec_rproc);
if (span == 0) {
for(i = 0; i < rw_ncol; i++){
prec_rproc_p[i] = NA_INTEGER;
}
warning(_("no data found in 'x'"));
UNPROTECT(1);
return ans;
}
/* Allocate internal storage */
last_yr = (int *) R_alloc(rw_ncol, sizeof(int));
for (i = 0; i < rw_ncol; i++) {
last_yr[i] = min_year;
}
/* Convert between input and output formats */
for(i = 0; i < x_nrow; i++){
this_decade = decade_p[i];
yr_idx = this_decade - min_year;
this_series = series_index_p[i] - 1;
rw_idx = this_series * rw_nrow + yr_idx;
x_idx = i;
last_valid = last_yr[this_series];
for(j = 0; j < x_ncol; j++){
this_val = x_p[x_idx];
x_idx += x_nrow;
if(this_val != NA_INTEGER){
rw_vec[rw_idx] = this_val;
last_valid = this_decade + j;
}
rw_idx++;
}
/* Needed for keeping track of the stop marker */
if(last_valid > last_yr[this_series])
last_yr[this_series] = last_valid;
}
for(i = 0; i < rw_ncol; i++){
stop_marker = rw_vec[i * rw_nrow + (last_yr[i] - min_year)];
if(stop_marker == 999.0f){
prec_rproc_p[i] = 100;
} else if(stop_marker == -9999.0f){
prec_rproc_p[i] = 1000;
} else {
prec_rproc_p[i] = 1;
}
}
UNPROTECT(1);
return ans;
}
