/** WMin operator
*
* @param x numeric
* @param w numeric
* @return numeric of length 1
*/
SEXP wmin(SEXP x, SEXP w)
{
x = prepare_arg_numeric(x, "x");
w = prepare_arg_numeric(w, "w");
R_len_t x_length = LENGTH(x);
R_len_t w_length = LENGTH(w);
double* w_tab = REAL(w);
double* x_tab = REAL(x);
if (w_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "w");
if (x_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "x");
if (ISNA(w_tab[0]) || ISNA(x_tab[0]))
return Rf_ScalarReal(NA_REAL);
if (x_length != w_length)
Rf_error(MSG__ARGS_EXPECTED_EQUAL_SIZE, "x", "w");
double ret_val = DBL_MAX;
for (R_len_t i=0; i<x_length; ++i) {
double tmp = max(w_tab[i], x_tab[i]);
if (ret_val > tmp) ret_val = tmp;
}
return Rf_ScalarReal(ret_val);
}
/** WAM operator
*
* @param x numeric
* @param w numeric
* @return numeric of length 1
*/
SEXP wam(SEXP x, SEXP w)
{
x = prepare_arg_numeric(x, "x");
w = prepare_arg_numeric(w, "w");
R_len_t x_length = LENGTH(x);
R_len_t w_length = LENGTH(w);
double* w_tab = REAL(w);
double* x_tab = REAL(x);
if (w_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "w");
if (x_length <= 0) Rf_error(MSG_ARG_TOO_SHORT, "x");
if (ISNA(w_tab[0]) || ISNA(x_tab[0]))
return Rf_ScalarReal(NA_REAL);
if (x_length != w_length)
Rf_error(MSG__ARGS_EXPECTED_EQUAL_SIZE, "x", "w");
double w_sum = 0.0;
double ret_val = 0.0;
for (R_len_t i=0; i<x_length; ++i) {
if (w_tab[i] < 0)
Rf_error(MSG__ARG_NOT_GE_A, "w", 0.0);
w_sum = w_sum + w_tab[i];
ret_val += w_tab[i]*x_tab[i];
}
if (w_sum > 1.0+EPS || w_sum < 1.0-EPS)
Rf_warning("elements of `w` does not sum up to 1. correcting.");
ret_val /= w_sum;
return Rf_ScalarReal(ret_val);
}
/** Check if two vectors are comonotonic
*
* @param x numeric vector
* @param y numeric vector
* @param incompatible_lengths single logical value
* @return logical scalar
*
* @version 0.2-1 (Marek Gagolewski)
*
* @version 0.2-1 (Marek Gagolewski, 2014-11-19)
* incompatible_lenghts arg added
*/
SEXP check_comonotonicity(SEXP x, SEXP y, SEXP incompatible_lengths)
{
x = prepare_arg_numeric(x, "x");
y = prepare_arg_numeric(y, "y");
incompatible_lengths = prepare_arg_logical_1(incompatible_lengths, "incompatible_lengths");
R_len_t x_length = LENGTH(x);
R_len_t y_length = LENGTH(y);
if (x_length != y_length)
return incompatible_lengths;
double* x_tab = REAL(x);
double* y_tab = REAL(y);
for (R_len_t i=0; i<x_length; ++i) {
if (ISNA(x_tab[i]) || ISNA(y_tab[i]))
return Rf_ScalarLogical(NA_LOGICAL);
for (R_len_t j=i; j<x_length; ++j) {
if ((x_tab[i]-x_tab[j])*(y_tab[i]-y_tab[j]) < 0.0)
return Rf_ScalarLogical(FALSE);
}
}
return Rf_ScalarLogical(TRUE);
}
