/* assemble call as string in C code */
void menu_ttest2()
{
char cmd[256];
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
Rconsolecmd(cmd);
}
hide(win);
delobj(bApply);
delobj(win);
}
static int
ThreadedReadConsole(const char *prompt, char *buf, int len, int addtohistory)
{
sighandler_t oldint,oldbreak;
/*
* SIGINT/SIGBREAK when ESS is waiting for output are a real pain:
* they get processed after user hit <return>.
* The '^C\n' in raw Rterm is nice. But, do we really need it ?
*/
oldint = signal(SIGINT, SIG_IGN);
oldbreak = signal(SIGBREAK, SIG_IGN);
mainThreadId = GetCurrentThreadId();
lineavailable = 0;
tprompt = prompt;
tbuf = buf;
tlen = len;
thist = addtohistory;
SetEvent(EhiWakeUp);
while (1) {
R_WaitEvent();
if (lineavailable) break;
doevent();
if(R_Tcl_do) R_Tcl_do();
}
lineavailable = 0;
/* restore handler */
signal(SIGINT, oldint);
signal(SIGBREAK, oldbreak);
return tlen;
}
static void eventloop(editor c)
{
while (fix_editor_up) {
/* avoid consuming 100% CPU time here */
R_WaitEvent();
R_ProcessEvents();
}
}
SEXP menu_ttest3()
{
char cmd[256];
SEXP cmdSexp, cmdexpr, ans = R_NilValue;
int i;
ParseStatus status;
done = 0;
create_dialog();
setaction(bCancel, cancel2);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
if(done == 1) {
sprintf(cmd, "t.test(x=%s, y=%s, alternative=\"%s\",\n paired=%s, var.equal=%s, conf.level=%s)\n", v[0], v[1],
alts[getlistitem(alt)],
ischecked(paired) ? "TRUE" : "FALSE",
ischecked(varequal) ? "TRUE" : "FALSE",
GA_gettext(lvl));
}
hide(win);
delobj(bApply);
delobj(win);
if(done == 1) {
PROTECT(cmdSexp = allocVector(STRSXP, 1));
SET_STRING_ELT(cmdSexp, 0, mkChar(cmd));
cmdexpr = PROTECT(R_ParseVector(cmdSexp, -1, &status, R_NilValue));
if (status != PARSE_OK) {
UNPROTECT(2);
error("invalid call %s", cmd);
}
/* Loop is needed here as EXPSEXP will be of length > 1 */
for(i = 0; i < length(cmdexpr); i++)
ans = eval(VECTOR_ELT(cmdexpr, i), R_GlobalEnv);
UNPROTECT(2);
}
return ans;
}
/* just retrieve values from the dialog box and assemble call in
interpreted code
*/
void menu_ttest(char **vars, int ints[], double level[])
{
done = 0;
create_dialog();
setaction(bCancel, cancel);
show(win);
for(;;) {
R_WaitEvent();
R_ProcessEvents();
if(done > 0) break;
}
vars[0] = v[0]; vars[1] = v[1];
ints[0] = getlistitem(alt);
ints[1] = ischecked(paired);
ints[2] = ischecked(varequal);
ints[3] = done;
level[0] = R_atof(GA_gettext(lvl));
hide(win);
delobj(bApply);
delobj(win);
}
SEXP
do_getGraphicsEvent(SEXP call, SEXP op, SEXP args, SEXP env)
{
SEXP result = R_NilValue, prompt;
pDevDesc dd;
pGEDevDesc gd;
int i, count=0, devNum;
checkArity(op, args);
prompt = CAR(args);
if (!isString(prompt) || !length(prompt)) error(_("invalid prompt"));
/* NB: cleanup of event handlers must be done by driver in onExit handler */
if (!NoDevices()) {
/* Initialize all devices */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->gettingEvent)
error(_("recursive use of 'getGraphicsEvent' not supported"));
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 1);
dd->gettingEvent = TRUE;
defineVar(install("result"), R_NilValue, dd->eventEnv);
count++;
}
devNum = nextDevice(devNum);
}
if (!count)
error(_("no graphics event handlers set"));
Rprintf("%s\n", CHAR(asChar(prompt)));
R_FlushConsole();
/* Poll them */
while (result == R_NilValue) {
/* make sure we still have at least one device listening for events, and throw an error if not*/
if(!haveListeningDev())
return R_NilValue;
#ifdef Win32
R_WaitEvent();
#endif
R_ProcessEvents();
R_CheckUserInterrupt();
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 2);
result = findVar(install("result"), dd->eventEnv);
if (result != R_NilValue && result != R_UnboundValue) {
break;
}
}
devNum = nextDevice(devNum);
}
}
/* clean up */
i = 1;
devNum = curDevice();
while (i++ < NumDevices()) {
gd = GEgetDevice(devNum);
dd = gd->dev;
if (dd->eventEnv != R_NilValue) {
if (dd->eventHelper) dd->eventHelper(dd, 0);
dd->gettingEvent = FALSE;
}
devNum = nextDevice(devNum);
}
}
return(result);
}
SEXP Win_selectlist(SEXP args)
{
SEXP choices, preselect, ans = R_NilValue;
const char **clist;
int i, j = -1, n, mw = 0, multiple, nsel = 0;
int xmax, ymax, ylist, fht, h0;
Rboolean haveTitle;
choices = CAR(args);
if(!isString(choices)) error(_("invalid '%s' argument"), "choices");
preselect = CADR(args);
if(!isNull(preselect) && !isString(preselect))
error(_("invalid '%s' argument"), "preselect");
multiple = asLogical(CADDR(args));
if(multiple == NA_LOGICAL) multiple = 0;
haveTitle = isString(CADDDR(args));
if(!multiple && isString(preselect) && LENGTH(preselect) != 1)
error(_("invalid '%s' argument"), "preselect");
n = LENGTH(choices);
clist = (const char **) R_alloc(n + 1, sizeof(char *));
for(i = 0; i < n; i++) {
clist[i] = translateChar(STRING_ELT(choices, i));
mw = max(mw, gstrwidth(NULL, SystemFont, clist[i]));
}
clist[n] = NULL;
fht = getSysFontSize().height;
xmax = max(170, mw+60); /* allow for scrollbar */
if(ismdi()) {
RECT *pR = RgetMDIsize();
h0 = pR->bottom;
} else {
h0 = deviceheight(NULL);
}
ymax = min(80+fht*n, h0-100); /* allow for window widgets, toolbar */
ylist = ymax - 60;
wselect = newwindow(haveTitle ? translateChar(STRING_ELT(CADDDR(args), 0)):
(multiple ? _("Select one or more") : _("Select one")),
rect(0, 0, xmax, ymax),
Titlebar | Centered | Modal | Floating);
setbackground(wselect, dialog_bg());
if(multiple)
f_list = newmultilist(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
else
f_list = newlistbox(clist, rect(10, 10, xmax-25, ylist), NULL, finish);
if(!isNull(preselect) && LENGTH(preselect)) {
for(i = 0; i < n; i++)
for(j = 0; j < LENGTH(preselect); j++)
if(strcmp(clist[i], translateChar(STRING_ELT(preselect, j))) == 0) {
setlistitem(f_list, i);
break;
}
}
bFinish = newbutton(G_("OK"), rect(xmax-160, ymax-40, 70, 25), finish);
bCancel = newbutton(G_("Cancel"), rect(xmax-80, ymax-40, 70, 25), cancel);
setkeydown(wselect, key1);
show(wselect);
done = 0;
while(!done) {
R_WaitEvent();
R_ProcessEvents();
}
if(multiple) {
if (done == 1) { /* Finish */
for(i = 0; i < n; i++) if(isselected(f_list, i)) nsel++;
PROTECT(ans = allocVector(STRSXP, nsel));
for(i = 0, j = 0; i < n; i++)
if(isselected(f_list, i))
SET_STRING_ELT(ans, j++, mkChar(clist[i]));
} else { /* cancel */
PROTECT(ans = allocVector(STRSXP, 0));
}
} else
PROTECT(ans = mkString(selected));
cleanup();
show(RConsole);
R_ProcessEvents();
UNPROTECT(1);
return ans;
}