[Rd] [macosx] improving quartz & Aqua Tk behaviour outside of RGui

[René J.V. Bertin]

A couple of weeks ago I posted a trick in R-help on improving Quartz
behaviour in the command line version of R:
http://tolstoy.newcastle.edu.au/R/e6/help/09/04/12948.html .

Works with Aqua Tcl/Tk 8.5 too, but I discovered one annoying
side-effect. After having a Tk dialog open (and using it) for a while,
the R process starts eating more than 50% cpu on my PPC G4, using
either the 8.4 or the 8.5 Tcl/Tk libraries. (I'm currently running R
2.8.1 .)

This does NOT happen when running the exact same code in the same
commandline R version with the 8.4 X11 Tcl/Tk libraries, nor when I
run the Quartz version in R-GUI.

For completeness, here's the Tcl/Tk function:

dialog.test <- function(wait=FALSE)
{
	with3 <- function( data1, data2=.GlobalEnv, expr )
	{
		attach(data1)
		attach(data2)
		on.exit( detach(data1), add= FALSE )
		on.exit( detach(data2), add= TRUE )
	
		try( eval( substitute(expr), parent.frame() ) )
	}

	require(tcltk) || stop("tcltk support is absent")

	tt <- tktoplevel()
	tkwm.title(tt,"VG1 tests")
	tt.done <- tclVar("0")

	name <- paste('dialog.test',as.character(tt$ID), sep='')
	assign( name, tt, env=tdialog.env )

	dialogVals<-get("dialogVals", env=RJVB.env)
	data<-tclVar(dialogVals[1])
	crit<-tclVar(dialogVals[2])
	eval1st<-tclVar(dialogVals[9])
	func<-tclVar(dialogVals[3])
	args<-tclVar(dialogVals[4])
	args2<-tclVar(dialogVals[5])
	acomm<-tclVar(dialogVals[8])
	sumvar <- tclVar(dialogVals[7])
	done <- tclVar(0)
	savecmd<-tclVar(dialogVals[6]);
	devvar <- tclVar( dev.cur() )
	theData <- ""

	reset <- function()
	{
		tclvalue(data)<-""
		tclvalue(crit)<-""
		tclvalue(eval1st)<-""
		tclvalue(func)<-""
		tclvalue(args)<-""
		tclvalue(args2)<-""
		tclvalue(acomm)<-""
		tclvalue(sumvar)<-"0"
	}

	doSource <- function()
	{
		fileN <- tclvalue( tkgetOpenFile() )
		if( fileN != "" ){
			try( source(fileN) )
		}
	}

	dfInfo <- function(fnc)
	{
	## notice that tclvalue() is correct here, since it is the
	## string representation of xvar and yvar that is being
	## displayed in the entry fields

		dataf  <- tclvalue(data)
		crit  <- tclvalue(crit)
		eval1st  <- tclvalue(eval1st)

		if( is.null(crit) | !strlen(crit) ){
			theData <- paste( dataf )
			assign( "Selected.Cases", "", env=RJVB.env )
		}
		else{
			theData <- paste( "SelectCases(", dataf, ",\"", crit, "\")" )
		}
		cmd<-paste( fnc, "( ", theData, " )" )
		try(
			cmd<-parse( text=cmd )
		);
		print( paste( "###", cmd ) )
		print( try( eval(cmd, envir=.GlobalEnv) ) )
		cmd
	}

	build <- function()
	{
	## notice that tclvalue() is correct here, since it is the
	## string representation of xvar and yvar that is being
	## displayed in the entry fields

		dataf  <- tclvalue(data)
		crit  <- tclvalue(crit)
		eval1st  <- tclvalue(eval1st)
		func  <- tclvalue(func)
		args  <- tclvalue(args)
		args2  <- tclvalue(args2)
		acomm  <- tclvalue(acomm)
		summ <- as.logical(tclObj(sumvar))

		assign( "dialogVals",
c(dataf,crit,func,args,args2,dialogVals[6],tclvalue(sumvar), acomm,
eval1st ), env=RJVB.env )

		if( is.null(crit) | !strlen(crit) ){
			theData <- paste( dataf )
			assign( "Selected.Cases", "", env=RJVB.env )
		}
		else{
			theData <- paste( "SelectCases(", dataf, ",\"", crit, "\")" )
		}
		if( is.null(acomm) | is.na(acomm) | !strlen(acomm) ){
			acomm <- ""
		}
		else{
			acomm <- paste( ", add.comment=\"", acomm, "\"" )
		}
		if( summ ){
			cmd<-paste( "with3( ", theData, ", tkdial.env, summary(
last.dialog.result<-", func, "(", args, ",", args2, acomm, ") ) )" )
# 			cmd<-paste( "with2( ", theData, ", summary(
last.dialog.result<-", func, "(", args, ",", args2, acomm, ") ) )" )
		}
		else{
			cmd<-paste( "with3( ", theData, ", tkdial.env,
last.dialog.result<-", func, "(", args, ",", args2, acomm, ") )" )
# 			cmd<-paste( "with2( ", theData, ", last.dialog.result<-", func,
"(", args, ",", args2, acomm, ") )" )
		}
		assign( "Selected.Data", theData, env=RJVB.env )
		try(
			cmd<-parse( text=cmd )
		);
		cmd
	}

	saveIt <- function()
	{
		cmd<-savecmd  <- tclvalue(savecmd)

		assign( "dialogVals",
c(dialogVals[1],dialogVals[2],dialogVals[3],dialogVals[4],dialogVals[5],cmd,dialogVals[7],
dialogVals[9]), env=RJVB.env )
		try(
			cmd<-parse( text=savecmd )
		);
		cmd
	}

	doIt <- function(cmd="")
	{
		orgDev <- dev.cur()
		try( dev.set( tclvalue(devvar) ) )
		func  <- tclvalue(func)
		eval1st  <- tclvalue(eval1st)

		eval( parse( text="tkdial.env <- new.env()"), env=.GlobalEnv )

		if( !is.null(eval1st) & strlen(eval1st) ){
			try(
				eval1st <- parse( text=eval1st )
			);
			cat(deparse(eval1st,width=500),sep="\n")
			print(
				try( eval(eval1st, env=tkdial.env) )
			);
			ls( env=tkdial.env )
		}

		cat("### Command executed via Tk ###\n")
		cat(deparse(cmd,width=500),sep="\n")
		cat("### Output:\n")
		dialogVals<-get("dialogVals", env=RJVB.env)
		print( system.time( print( try( res<-eval(cmd, envir=.GlobalEnv) ) ) ) )
		if( func == 'aov' | func == 'aov.VG1' ){
			cat('\n')
			try( print( TukeyHSD(res, ordered=TRUE) ), silent=TRUE)
		}
		cat( paste( "### ----------- (", deparse(tclvalue(data),width=132),
") ----------- ###\n", sep="" ) )

		try( dev.set(orgDev) )

		eval( parse( text="rm(tkdial.env)" ), env=.GlobalEnv )
	}

	doQuit <- function()
	{
		dQ <- function()
		{
			tclvalue(done)<-"cancel"
			tkdestroy(tt)
			tt.done<-"1"
		}

		 # if the window is referenced in the windowlist environment, remove
the reference and then close
		if( exists(name, env=tdialog.env) ){
			w <- get(name, env=tdialog.env)
			if( !is.null(w) && class(w) == "tkwin" ){
				try( assign( name, NULL, env=tdialog.env ) )
				try( rm( list=name, envir=tdialog.env ) )
				dQ()
			}
		}
		else{
		 # if not, close too. Probably means that dQ() can sstill be called
recursively...
			dQ()
		}
		return(0)
	}

	data.entry <- tkentry(tt, textvariable=data, width=100)
	crit.entry <- tkentry(tt, textvariable=crit, width=100)
	eval1st.entry <- tkentry(tt, textvariable=eval1st, width=100)
	func.entry <- tkentry(tt, textvariable=func, width=100)
	args.entry <- tkentry(tt, textvariable=args, width=100)
	args2.entry <- tkentry(tt, textvariable=args2, width=100)
	acomm.entry <- tkentry(tt, textvariable=acomm, width=100)
	dev.entry <- tkentry(tt, textvariable=devvar, width=2)

	summ.cbut <- tkcheckbutton(tt,text="Print summary()", variable=sumvar)

	submit.but <- tkbutton(tt, text="submit",
				 command=function()doIt(build()) )

	savecmd.entry <- tkentry(tt, textvariable=savecmd, width=100)
	save.but <- tkbutton(tt, text="save",
				command=function()doIt(saveIt()) )

	reset.but <- tkbutton(tt, text="Reset", command=reset)
	source.but <- tkbutton(tt, text="Source", command=function()doSource() )
	cancel.but <- tkbutton(tt, text="Cancel", command=doQuit )
	
	names.but <- tkbutton(tt, text="names", command=function()dfInfo("names") )
	summary.but <- tkbutton(tt, text="summary",
command=function()dfInfo("summary") )

	tkgrid(tklabel(tt,text="Dataframe"), data.entry, names.but, columnspan=3 )
	tkgrid(tklabel(tt,text="Sel.Crit"), crit.entry, summary.but, columnspan=3 )
	tkgrid(tklabel(tt,text="Eval.1st"), eval1st.entry, columnspan=3 )
	tkgrid(tklabel(tt,text="Analysis"), func.entry, columnspan=3 )
	tkgrid(tklabel(tt,text="Variables"), args.entry, columnspan=3 )
	tkgrid(tklabel(tt,text="Options"), args2.entry, columnspan=3 )
	tkgrid(tklabel(tt,text="Comment"), acomm.entry, columnspan=3 )
	tkgrid(summ.cbut, tklabel(tt,text="Device"), dev.entry, sticky="e" ,
columnspan=3 )
	tkgrid(tklabel(tt,text="Save cmd"), savecmd.entry, columnspan=3 )
	tkgrid(submit.but, save.but, reset.but, source.but, cancel.but,
columnspan=2, sticky="w")

## capture destroy (e.g. from window controls
## otherwise the tkwait hangs with nowhere to go)
#	tkbind(tt, "<Destroy>", function()tclvalue(done)<-"quit")
	tkbind(tt, "<Destroy>", function()doQuit())
	tkbind(tt, "<Return>", function()doIt(build()) )
	tkbind(tt, "<Control-s>", function()doIt(saveIt()) )
	tkbind(tt, "<Control-S>", function()doSource() )

	.Tcl("update idletasks")

	if( wait ){
		while( tclvalue(done) != "cancel" ){
			tkwait.variable(done)
			doQuit()
		}
	}
# 	else{
# 		return(tt)
# 	}

## not necessary: button handlers do all the work, until tkdestroy().
# 	tkwait.variable(done)
#
# 	while( tclvalue(done)!= "cancel" ){
# 		if(tclvalue(done)=="quit") stop("aborted")
#
# 		if( tclvalue(done)=="save"){
# 			cmd <- saveIt()
# 		}
# 		else{
# 			cmd <- build()
# 		}
# 		cat("### Command executed via Tk ###\n")
# 		cat(deparse(cmd,width=132),sep="\n")
# 		cat("### Output:\n")
# 		dialogVals<-get("dialogVals", env=RJVB.env)
# 		print( try( eval.parent(cmd) ) )
# 		cat("### ----------------------- ###\n")
#
# 		tkwait.variable(done)
# 	}

# 	return(NULL)

}

On 2009-04-28, René J.V. Bertin <rjvbertin at gmail.com> wrote:

>  mkApp /Library/Frameworks/R.framework/Resources/bin/exec/R
<snip>
>  improves the behaviour of Quartz graphics windows, and of dialogs made
>  with TclTk (Aqua version 8.4), which for me now behave like under X11.
>  (i.e. as if controlled by a separate thread while the prompt remains
>  usable.)