/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret, n;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
/* if x has names, drop them, since they won't be ordered
if (!isNull(getAttrib(sx, R_NamesSymbol)))
setAttrib(sx, R_NamesSymbol, R_NilValue); */
indx_ret = asLogical(CADR(args));
n = LENGTH(x);
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
int i, *ix;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
PROTECT(indx = allocVector(INTSXP, n));
ix = INTEGER(indx);
for(i = 0; i < n; i++)
ix[i] = i+1;
if(x_int)
R_qsort_int_I(ivx, ix, 1, n);
else
R_qsort_I(vx, ix, 1, n);
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
}
else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
double sn0(double *x, int n, int is_sorted, double *a2)
{
/*
Efficient algorithm for the scale estimator:
S*_n = LOMED_{i} HIMED_{i} |x_i - x_j|
which can equivalently be written as
S*_n = LOMED_{i} LOMED_{j != i} |x_i - x_j|
Arguments :
x : double array (length >= n) containing the observations
n : number of observations (n>=2)
is_sorted: logical indicating if x is already sorted
a2 : to contain a2[i] := LOMED_{j != i} | x_i - x_j |,
for i=1,...,n
*/
/* Local variables */
double medA, medB;
int i, diff, half, Amin, Amax, even, length;
int leftA,leftB, nA,nB, tryA,tryB, rightA,rightB;
int n1_2;
if(!is_sorted)
R_qsort(x, 1, n);
a2[0] = x[n / 2] - x[0];
n1_2 = (n + 1) / 2;
/* first half for() loop : */
for (i = 2; i <= n1_2; ++i) {
nA = i - 1;
nB = n - i;
diff = nB - nA;
leftA = leftB = 1;
rightA = rightB = nB;
Amin = diff / 2 + 1;
Amax = diff / 2 + nA;
while (leftA < rightA) {
length = rightA - leftA + 1;
even = 1 - length % 2;
half = (length - 1) / 2;
tryA = leftA + half;
tryB = leftB + half;
if (tryA < Amin) {
rightB = tryB;
leftA = tryA + even;
}
else {
if (tryA > Amax) {
rightA = tryA;
leftB = tryB + even;
}
else {
medA = x[i - 1] - x[i - tryA + Amin - 2];
medB = x[tryB + i - 1] - x[i - 1];
if (medA >= medB) {
rightA = tryA;
leftB = tryB + even;
} else {
rightB = tryB;
leftA = tryA + even;
}
}
}
} /* while */
if (leftA > Amax) {
a2[i - 1] = x[leftB + i - 1] - x[i - 1];
} else {
medA = x[i - 1] - x[i - leftA + Amin - 2];
medB = x[leftB + i - 1] - x[i - 1];
a2[i - 1] = fmin2(medA,medB);
}
}
/* second half for() loop : */
for (i = n1_2 + 1; i <= n - 1; ++i) {
nA = n - i;
nB = i - 1;
diff = nB - nA;
leftA = leftB = 1;
rightA = rightB = nB;
Amin = diff / 2 + 1;
Amax = diff / 2 + nA;
while (leftA < rightA) {
length = rightA - leftA + 1;
even = 1 - length % 2;
half = (length - 1) / 2;
tryA = leftA + half;
tryB = leftB + half;
if (tryA < Amin) {
rightB = tryB;
leftA = tryA + even;
} else {
if (tryA > Amax) {
rightA = tryA;
leftB = tryB + even;
} else {
medA = x[i + tryA - Amin] - x[i - 1];
medB = x[i - 1] - x[i - tryB - 1];
if (medA >= medB) {
rightA = tryA;
leftB = tryB + even;
} else {
rightB = tryB;
leftA = tryA + even;
}
}
}
} /* while */
if (leftA > Amax) {
a2[i - 1] = x[i - 1] - x[i - leftB - 1];
} else {
medA = x[i + leftA - Amin] - x[i - 1];
medB = x[i - 1] - x[i - leftB - 1];
a2[i - 1] = fmin2(medA,medB);
}
}
a2[n - 1] = x[n - 1] - x[n1_2 - 1];
return pull(a2, n, n1_2);
} /* sn0 */
double qn0(double *x, int n)
{
/*--------------------------------------------------------------------
Efficient algorithm for the scale estimator:
Q*_n = { |x_i - x_j|; i<j }_(k) [= Qn without scaling ]
i.e. the k-th order statistic of the |x_i - x_j|
Parameters of the function Qn :
x : double array containing the observations
n : number of observations (n >=2)
*/
double *y = (double *)R_alloc(n, sizeof(double));
double *work = (double *)R_alloc(n, sizeof(double));
double *a_srt = (double *)R_alloc(n, sizeof(double));
double *a_cand = (double *)R_alloc(n, sizeof(double));
int *left = (int *)R_alloc(n, sizeof(int));
int *right = (int *)R_alloc(n, sizeof(int));
int *p = (int *)R_alloc(n, sizeof(int));
int *q = (int *)R_alloc(n, sizeof(int));
int *weight = (int *)R_alloc(n, sizeof(int));
double trial = R_NaReal;/* -Wall */
Rboolean found;
int h, i, j,jj,jh;
/* Following should be `long long int' : they can be of order n^2 */
int64_t k, knew, nl,nr, sump,sumq;
h = n / 2 + 1;
k = (int64_t)h * (h - 1) / 2;
for (i = 0; i < n; ++i) {
y[i] = x[i];
left [i] = n - i + 1;
right[i] = (i <= h) ? n : n - (i - h);
/* the n - (i-h) is from the paper; original code had `n' */
}
R_qsort(y, 1, n); /* y := sort(x) */
nl = (int64_t)n * (n + 1) / 2;
nr = (int64_t)n * n;
knew = k + nl;/* = k + (n+1 \over 2) */
found = FALSE;
#ifdef DEBUG_qn
REprintf("qn0(): h,k= %2d,%2d; nl,nr= %d,%d\n", h,k, nl,nr);
#endif
/* L200: */
while(!found && nr - nl > n) {
j = 0;
/* Truncation to float :
try to make sure that the same values are got later (guard bits !) */
for (i = 1; i < n; ++i) {
if (left[i] <= right[i]) {
weight[j] = right[i] - left[i] + 1;
jh = left[i] + weight[j] / 2;
work[j] = (float)(y[i] - y[n - jh]);
++j;
}
}
trial = whimed_i(work, weight, j, a_cand, a_srt, /*iw_cand*/ p);
#ifdef DEBUG_qn
REprintf(" ..!found: whimed(");
# ifdef DEBUG_long
REprintf("wrk=c(");
for(i=0; i < j; i++) REprintf("%s%g", (i>0)? ", " : "", work[i]);
REprintf("),\n wgt=c(");
for(i=0; i < j; i++) REprintf("%s%d", (i>0)? ", " : "", weight[i]);
REprintf("), j= %3d) -> trial= %7g\n", j, trial);
# else
REprintf("j=%3d) -> trial= %g:", j, trial);
# endif
#endif
j = 0;
for (i = n - 1; i >= 0; --i) {
while (j < n && ((float)(y[i] - y[n - j - 1])) < trial)
++j;
p[i] = j;
}
#ifdef DEBUG_qn
REprintf(" f_1: j=%2d", j);
#endif
j = n + 1;
for (i = 0; i < n; ++i) {
while ((float)(y[i] - y[n - j + 1]) > trial)
--j;
q[i] = j;
}
sump = 0;
sumq = 0;
for (i = 0; i < n; ++i) {
sump += p[i];
sumq += q[i] - 1;
}
#ifdef DEBUG_qn
REprintf(" f_2 -> j=%2d, sump|q= %lld,%lld", j, sump,sumq);
#endif
if (knew <= sump) {
for (i = 0; i < n; ++i)
right[i] = p[i];
nr = sump;
#ifdef DEBUG_qn
REprintf("knew <= sump =: nr , new right[]\n");
#endif
} else if (knew > sumq) {
for (i = 0; i < n; ++i)
left[i] = q[i];
nl = sumq;
#ifdef DEBUG_qn
REprintf("knew > sumq =: nl , new left[]\n");
#endif
} else { /* sump < knew <= sumq */
found = TRUE;
#ifdef DEBUG_qn
REprintf("sump < knew <= sumq ---> FOUND\n");
#endif
}
} /* while */
if (found)
return trial;
else {
#ifdef DEBUG_qn
REprintf(".. not fnd -> new work[]");
#endif
j = 0;
for (i = 1; i < n; ++i) {
for (jj = left[i]; jj <= right[i]; ++jj) {
work[j] = y[i] - y[n - jj];
j++;
}/* j will be = sum_{i=2}^n (right[i] - left[i] + 1)_{+} */
}
#ifdef DEBUG_qn
REprintf(" of length %d; knew-nl=%d\n", j, knew-nl);
#endif
/* return pull(work, j - 1, knew - nl) : */
knew -= (nl + 1); /* -1: 0-indexing */
rPsort(work, j, knew);
return(work[knew]);
}
} /* qn0 */
/* R function qsort(x, index.return) */
SEXP attribute_hidden do_qsort(SEXP call, SEXP op, SEXP args, SEXP rho)
{
SEXP x, sx;
int indx_ret;
double *vx = NULL;
int *ivx = NULL;
Rboolean x_real, x_int;
checkArity(op, args);
x = CAR(args);
if (!isNumeric(x))
error(_("argument is not a numeric vector"));
x_real= TYPEOF(x) == REALSXP;
x_int = !x_real && (TYPEOF(x) == INTSXP || TYPEOF(x) == LGLSXP);
PROTECT(sx = (x_real || x_int) ? duplicate(x) : coerceVector(x, REALSXP));
SET_ATTRIB(sx, R_NilValue);
SET_OBJECT(sx, 0);
indx_ret = asLogical(CADR(args));
R_xlen_t n = XLENGTH(x);
#ifdef LONG_VECTOR_SUPPORT
Rboolean isLong = n > INT_MAX;
#endif
if(x_int) ivx = INTEGER(sx); else vx = REAL(sx);
if(indx_ret) {
SEXP ans, ansnames, indx;
/* answer will have x = sorted x , ix = index :*/
PROTECT(ans = allocVector(VECSXP, 2));
PROTECT(ansnames = allocVector(STRSXP, 2));
#ifdef LONG_VECTOR_SUPPORT
if (isLong) {
PROTECT(indx = allocVector(REALSXP, n));
double *ix = REAL(indx);
for(R_xlen_t i = 0; i < n; i++) ix[i] = (double) (i+1);
if(x_int) R_qsort_int_R(ivx, ix, 1, n);
else R_qsort_R(vx, ix, 1, n);
} else
#endif
{
PROTECT(indx = allocVector(INTSXP, n));
int *ix = INTEGER(indx);
int nn = (int) n;
for(int i = 0; i < nn; i++) ix[i] = i+1;
if(x_int) R_qsort_int_I(ivx, ix, 1, nn);
else R_qsort_I(vx, ix, 1, nn);
}
SET_VECTOR_ELT(ans, 0, sx);
SET_VECTOR_ELT(ans, 1, indx);
SET_STRING_ELT(ansnames, 0, mkChar("x"));
SET_STRING_ELT(ansnames, 1, mkChar("ix"));
setAttrib(ans, R_NamesSymbol, ansnames);
UNPROTECT(4);
return ans;
} else {
if(x_int)
R_qsort_int(ivx, 1, n);
else
R_qsort(vx, 1, n);
UNPROTECT(1);
return sx;
}
}
void F77_SUB(qsort3)(double *v, int *ii, int *jj)
{
R_qsort(v, *ii, *jj);
}
/* Written by Mikko Korpela */
void gini(double *x_const, int *n_ptr, double *result){
int i;
double *x;
long double sum1, sum2, this_x;
listnode *tmp1, *tmp2;
int n = *n_ptr;
if(n<2){
*result = 0;
return;
}
/* Sort the numbers */
x = (double *) R_alloc(n, sizeof(double));
for(i=0;i<n;i++)
x[i] = x_const[i];
R_qsort(x, 1, n);
/* Setup for grow_exp */
tmp1 = (listnode *) R_alloc(1, sizeof(listnode));
tmp1->next = NULL;
tmp1->data = (long double)x[0];
tmp1->valid = 1;
/* Cumulative sum */
for(i=1;i<n;i++){
grow_exp(tmp1, (long double)x[i]);
tmp2 = tmp1;
sum1 = 0;
while(tmp2 && tmp2->valid){
sum1 += tmp2->data;
tmp2 = tmp2->next;
}
x[i] = (double)sum1;
}
/* Setup for grow_exp */
if(tmp1->next)
tmp1->next->valid = 0;
tmp2 = (listnode *) R_alloc(1, sizeof(listnode));
tmp2->next = NULL;
/* Gini */
tmp1->data = (long double)x[n-1] * (n-1);
tmp2->data = (long double)x[0];
tmp2->valid = 1;
grow_exp(tmp2, (long double)x[0]);
for(i=1;i<n-1;i++){
this_x = (long double)x[i];
grow_exp(tmp1, this_x * i);
grow_exp(tmp2, this_x * (i+2));
}
sum1 = 0;
while(tmp1 && tmp1->valid){
sum1 += tmp1->data;
tmp1 = tmp1->next;
}
sum2 = 0;
while(tmp2 && tmp2->valid){
sum2 += tmp2->data;
tmp2 = tmp2->next;
}
*result = (double)((sum1-sum2)/((long double)x[n-1]*n));
}
