SEXP do_hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, h, s, v, gm, a;
double hh, ss, vv, gg, aa, r, g, b;
int i, max, nh, ns, nv, ng, na;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(s = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(v = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(gm = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
nh = LENGTH(h);
ns = LENGTH(s);
nv = LENGTH(v);
ng = LENGTH(gm);
na = LENGTH(a);
if (nh <= 0 || ns <= 0 || nv <= 0 || ng <= 0 || na <= 0) {
UNPROTECT(5);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < ns) max = ns;
if (max < nv) max = nv;
if (max < ng) max = ng;
if (max < na) max = na;
PROTECT(c = allocVector(STRSXP, max));
if(max == 0) return(c);
for (i = 0; i < max; i++) {
hh = REAL(h)[i % nh];
ss = REAL(s)[i % ns];
vv = REAL(v)[i % nv];
gg = REAL(gm)[i % ng];
aa = REAL(a)[i % na];
if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
aa < 0 || aa > 1)
errorcall(call, _("invalid HSV color"));
hsv2rgb(hh, ss, vv, &r, &g, &b);
r = pow(r, gg);
g = pow(g, gg);
b = pow(b, gg);
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r),
ScaleColor(g),
ScaleColor(b),
ScaleAlpha(aa))));
}
UNPROTECT(6);
return c;
}
SEXP do_hcl(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP h, c, l, a, ans;
double H, C, L, A, r, g, b;
int nh, nc, nl, na, max, i;
int ir, ig, ib;
int fixup;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(c = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(l = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
fixup = asLogical(CAR(args));
nh = LENGTH(h);
nc = LENGTH(c);
nl = LENGTH(l);
na = LENGTH(a);
if (nh <= 0 || nc <= 0 || nl <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < nc) max = nc;
if (max < nl) max = nl;
if (max < na) max = na;
PROTECT(ans = allocVector(STRSXP, max));
for (i = 0; i < max; i++) {
H = REAL(h)[i % nh];
C = REAL(c)[i % nc];
L = REAL(l)[i % nl];
A = REAL(a)[i % na];
if (!finite(A)) A = 1;
if (L < 0 || L > WHITE_Y || C < 0 || A < 0 || A > 1)
errorcall(call, _("invalid hcl color"));
hcl2rgb(H, C, L, &r, &g, &b);
ir = 255 * r + .5;
ig = 255 * g + .5;
ib = 255 * b + .5;
if (FixupColor(&ir, &ig, &ib) && !fixup)
SET_STRING_ELT(ans, i, NA_STRING);
else
SET_STRING_ELT(ans, i, mkChar(RGBA2rgb(ir, ig, ib,
ScaleAlpha(A))));
}
UNPROTECT(5);
return ans;
}
SEXP attribute_hidden do_hsv(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, h, s, v, a;
double hh, ss, vv, aa, r=0., g=0., b=0.; /* -Wall */
int i, max, nh, ns, nv, na;
checkArity(op, args);
PROTECT(h = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(s = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(v = coerceVector(CAR(args),REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args),REALSXP)); args = CDR(args);
nh = LENGTH(h);
ns = LENGTH(s);
nv = LENGTH(v);
na = LENGTH(a);
if (nh <= 0 || ns <= 0 || nv <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
max = nh;
if (max < ns) max = ns;
if (max < nv) max = nv;
if (max < na) max = na;
PROTECT(c = allocVector(STRSXP, max));
if(max == 0) return(c);
for (i = 0; i < max; i++) {
hh = REAL(h)[i % nh];
ss = REAL(s)[i % ns];
vv = REAL(v)[i % nv];
aa = REAL(a)[i % na];
if (hh < 0 || hh > 1 || ss < 0 || ss > 1 || vv < 0 || vv > 1 ||
aa < 0 || aa > 1)
error(_("invalid hsv color"));
hsv2rgb(hh, ss, vv, &r, &g, &b);
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(ScaleColor(r),
ScaleColor(g),
ScaleColor(b),
ScaleAlpha(aa))));
}
UNPROTECT(5);
return c;
}
SEXP do_rgb(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP c, r, g, b, a, nam;
int OP, i, l_max, nr, ng, nb, na;
Rboolean max_1 = FALSE;
double mV = 0.0; /* -Wall */
checkArity(op, args);
OP = PRIMVAL(op);
if(OP) {/* op == 1: rgb256() :*/
PROTECT(r = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), INTSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), INTSXP)); args = CDR(args);
}
else {
PROTECT(r = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(g = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(b = coerceVector(CAR(args), REALSXP)); args = CDR(args);
PROTECT(a = coerceVector(CAR(args), REALSXP)); args = CDR(args);
mV = asReal(CAR(args)); args = CDR(args);
max_1 = (mV == 1.);
}
nr = LENGTH(r); ng = LENGTH(g); nb = LENGTH(b); na = LENGTH(a);
if (nr <= 0 || ng <= 0 || nb <= 0 || na <= 0) {
UNPROTECT(4);
return(allocVector(STRSXP, 0));
}
l_max = nr;
if (l_max < ng) l_max = ng;
if (l_max < nb) l_max = nb;
if (l_max < na) l_max = na;
PROTECT(nam = coerceVector(CAR(args), STRSXP)); args = CDR(args);
if (length(nam) != 0 && length(nam) != l_max)
errorcall(call, _("invalid names vector"));
PROTECT(c = allocVector(STRSXP, l_max));
#define _R_set_c_RGBA(_R,_G,_B,_A) \
for (i = 0; i < l_max; i++) \
SET_STRING_ELT(c, i, mkChar(RGBA2rgb(_R,_G,_B,_A)))
if(OP) { /* OP == 1: rgb256() :*/
_R_set_c_RGBA(CheckColor(INTEGER(r)[i%nr]),
CheckColor(INTEGER(g)[i%ng]),
CheckColor(INTEGER(b)[i%nb]),
CheckAlpha(INTEGER(a)[i%na]));
}
else if(max_1) {
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr]),
ScaleColor(REAL(g)[i%ng]),
ScaleColor(REAL(b)[i%nb]),
ScaleAlpha(REAL(a)[i%na]));
}
else { /* maxColorVal not in {1, 255} */
_R_set_c_RGBA(ScaleColor(REAL(r)[i%nr] / mV),
ScaleColor(REAL(g)[i%ng] / mV),
ScaleColor(REAL(b)[i%nb] / mV),
ScaleAlpha(REAL(a)[i%na] / mV));
}
if (length(nam) != 0)
setAttrib(c, R_NamesSymbol, nam);
UNPROTECT(6);
return c;
}
