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; }