R/tk.modelize.R

# Interactive Tcl-Tk copy number modelization
# Author : Sylvain Mareschal <[email protected]>

tk.modelize = function(
		compress = "gzip",
		compression_level = 9,
		exclude = c("X", "Y", "Xp", "Xq", "Yp", "Yq"),
		globalTopLevel,
		localTopLevel,
		render = c("auto", "png", "tkrplot"),
		tkrplot.scale = 1,
		png.res = 100,
		png.file = tempfile(fileext=".png")
		)
	{
	# Check renderer
	render <- match.arg(render)
	tcltkVer <- as.double(sub("^([0-9]+\\.[0-9]+).+$", "\\1", tcltk::tclVersion()))
	if(tcltkVer >= 8.6) {
		# PNG is not compatible
		if(render == "auto") render <- "png"
	} else {
		# PNG is compatible
		if(render == "auto")       { render <- "tkrplot"
		} else if(render == "png") { stop("PNG rendering requires tcltk 8.6 or above")
		}
	}
	
	# Check if tkrplot is installed
	if(length(find.package("tkrplot", quiet=TRUE)) == 0L) {
		tcltk::tkmessageBox(
			icon = "info",
			type = "ok",
			title = "tkrplot package missing",
			message = "The optional 'tkrplot' package is required to use tk.browse(), please install it and try again."
		)
	}
	
	# Current file
	arrayFiles <- character(0)
	extension <- as.character(NA)
	index <- 0L
	
	# Regions storage
	segStarts <- NULL
	segEnds <- NULL
	segChroms <- NULL
	segLogRatios <- NULL
	segProbes <- NULL
	
	# Model storage
	model <- NA
	
	# cghRA.regions storage
	regions <- NULL
	
	
	## FUNCTIONS ##
	
	savePar <- list()
	xConvert = function(x) {
		x <- as.integer(x)
		
		# Plot area coordinates in pixels
		xMin <- savePar$plt[1] * width
		xMax <- savePar$plt[2] * width
		
		# From pixel area to x range
		return((x - xMin) / (xMax - xMin) * (savePar$usr[2] - savePar$usr[1]) + savePar$usr[1])
	}
	yConvert = function(y) {
		y <- as.integer(y)
		
		# Plot area coordinates in pixels
		yMin <- (1-savePar$plt[3]) * height
		yMax <- (1-savePar$plt[4]) * height
		
		# From pixel area to x range
		return((y - yMin) / (yMax - yMin) * (savePar$usr[4] - savePar$usr[3]) + savePar$usr[3])
	}
	
	closest <- function(x, y, all.x, all.y) {
		distances <- abs((all.x - x) / max(all.x)) + abs((all.y - y) / max(all.y))
		return(which.min(distances))
	}
	
	click.x <- NULL
	click.y <- NULL
	click.id <- 0
	mousePress = function(x, y) {
		if(index != 0L) {
			# Nearest point on the plot
			target <- closest(xConvert(x), yConvert(y), LCN(segLogRatios, exact=TRUE), segProbes)
			if(target == click.id) {
				# Deselect
				click.x <<- NULL
				click.y <<- NULL
				click.id <<- 0
				
				# Update plot
				replot()
			} else {		
				# Copy number, if available
				if(!is.na(model['center']) && !is.na(model['width'])) {
					copies <- copies(segLogRatios[target], model=model)
				} else {
					copies <- NA
				}
				
				# Retain click coordinates
				click.x <<- LCN(segLogRatios, exact=TRUE)[ target ]
				click.y <<- segProbes[ target ]
				click.id <<- target
				
				# Update plot
				replot()
				
				# Info box
				tcltk::tkmessageBox(
					parent = localTopLevel,
					icon = "info",
					type = "ok",
					title = "Nearest segment",
					message = sprintf(
						"logRatio :\t%.5f\nCopies :\t%.2f\n\nProbes :\t%d\nChrom :\t%s\nStart :\t%.6f Mb\nEnd :\t%.6f Mb",
						segLogRatios[target],
						copies,
						segProbes[target],
						segChroms[target],
						segStarts[target] / 1e6,
						segEnds[target] / 1e6		
					)
				)
			}
		}
	}
	
	arrayFilesBrowse <- function() {
		# Update file list
		tmpArrayFiles <- tk.file(
			title = "Choose a region list",
			typeNames = c("cghRA region file", "Tab-separated region list"),
			typeExt = c(".regions.rdt", ".txt"),
			multiple = TRUE,
			mandatory = FALSE,
			type = "open",
			parent = localTopLevel
		)
		
		if(length(tmpArrayFiles) > 0) {
			# Data update
			arrayFiles <<- tmpArrayFiles
			
			# Interface update
			tcltk::tclvalue(arrayFilesValue) <- sprintf("1/%i selected files", length(arrayFiles))
			
			# Start with the new first
			index <<- 1L
			importFile()
		}
	}
	
	updateSliders = function() {
		# bandwidth
		if(is.na(model['bw'])) {
			tcltk::tclvalue(bwSliderValue) <- 0
			tcltk::tclvalue(bwSliderText) <- "NA"
		} else {
			tcltk::tclvalue(bwSliderValue) <- model['bw']
			tcltk::tclvalue(bwSliderText) <- as.character(round(model['bw'], 3))
		}
		
		# center
		if(is.na(model['center'])) {
			tcltk::tclvalue(centerSliderValue) <- 0
			tcltk::tclvalue(centerSliderText) <- "NA"
		} else {
			tcltk::tclvalue(centerSliderValue) <- model['center']
			tcltk::tclvalue(centerSliderText) <- as.character(round(model['center'], 3))
		}
		
		# width
		if(is.na(model['width'])) {
			tcltk::tclvalue(widthSliderValue) <- 0
			tcltk::tclvalue(widthSliderText) <- "NA"
		} else {
			tcltk::tclvalue(widthSliderValue) <- model['width']
			tcltk::tclvalue(widthSliderText) <- as.character(round(model['width'], 3))
		}
		
		# peakFrom
		if(is.na(model['peakFrom'])) {
			tcltk::tclvalue(fromSliderValue) <- -10
			tcltk::tclvalue(fromSliderText) <- "NA"
		} else {
			tcltk::tclvalue(fromSliderValue) <- model['peakFrom']
			tcltk::tclvalue(fromSliderText) <- as.character(round(model['peakFrom'], 2))
		}
		
		# peakTo
		if(is.na(model['peakTo'])) {
			tcltk::tclvalue(toSliderValue) <- 1.5
			tcltk::tclvalue(toSliderText) <- "NA"
		} else {
			tcltk::tclvalue(toSliderValue) <- model['peakTo']
			tcltk::tclvalue(toSliderText) <- as.character(round(model['peakTo'], 2))
		}
	}
	
	updateBw <- function(...) {
		if(index > 0) {
			newValue <- as.double(list(...)[[1]])
			if(newValue == 0) {
				model['bw'] <<- NA
				tcltk::tclvalue(bwSliderText) <- "NA"
			} else {
				model['bw'] <<- newValue
				tcltk::tclvalue(bwSliderText) <- as.character(newValue)
			}
			replot()
		}
	}
	
	updateCenter <- function(...) {
		if(index > 0) {
			newValue <- as.double(list(...)[[1]])
			if(newValue == 0) {
				model['center'] <<- NA
				tcltk::tclvalue(centerSliderText) <- "NA"
			} else {
				model['center'] <<- newValue
				tcltk::tclvalue(centerSliderText) <- as.character(newValue)
			}
			replot()
		}
	}
	
	updateWidth <- function(...) {
		if(index > 0) {
			newValue <- as.double(list(...)[[1]])
			if(newValue == 0) {
				model['width'] <<- NA
				tcltk::tclvalue(widthSliderText) <- "NA"
			} else {
				model['width'] <<- newValue
				tcltk::tclvalue(widthSliderText) <- as.character(newValue)
			}
			replot()
		}
	}
	
	updateFrom <- function(...) {
		if(index > 0) {
			newValue <- as.double(list(...)[[1]])
			if(newValue == -10) {
				model['peakFrom'] <<- NA
				tcltk::tclvalue(fromSliderText) <- "NA"
			} else {
				model['peakFrom'] <<- newValue
				tcltk::tclvalue(fromSliderText) <- as.character(newValue)
			}
			replot()
		}
	}
	
	updateTo <- function(...) {
		if(index > 0) {
			newValue <- as.double(list(...)[[1]])
			if(newValue == 1.5) {
				model['peakTo'] <<- NA
				tcltk::tclvalue(toSliderText) <- "NA"
			} else {
				model['peakTo'] <<- newValue
				tcltk::tclvalue(toSliderText) <- as.character(newValue)
			}
			replot()
		}
	}
	
	# Compute current plot area height, in pixels
	autoHeight <- function() {
		out <- as.integer(tcltk::tclvalue(tcltk::tkwinfo("height", plotFrame))) - 30L
		return(out)
	}
	
	# Compute current plot area width, in pixels
	autoWidth <- function() {
		out <- as.integer(tcltk::tclvalue(tcltk::tkwinfo("width", plotFrame))) - 10L
		return(out)
	}
	
	# model.test() call to produce the plot
	plot.core <- function() {
		graphics::par(bg="#FFFFFF", cex=1)
		savePar <<- model.test(
			segLogRatios = segLogRatios,
			segChroms = segChroms,
			segLengths = segProbes,
			minDensity = as.double(tcltk::tclvalue(minDensityValue)),
			model = model,
			returnPar = TRUE,
			exclude = exclude,
			title = basename(arrayFiles[index])
		)
		if(!is.null(click.x)) graphics::points(x=click.x, y=click.y, pch=1, col="#FF0000")
	}
	
	# Welcome screen
	plot.empty <- function() {
		graphics::par(bg="#FFFFFF", mar=c(0,0,0,0))
		graphics::plot(x=NA, y=NA, xlim=0:1, ylim=0:1, xlab="", ylab="", xaxt="n", yaxt="n", bty="n")
		graphics::text(x=0.5, y=0.5, labels="Welcome to cghRA !\n\nClick \"Select files\" and select *.regions.rdt files to begin.")
	}
	
	# Replot using 'png' rendered
	plot.png <- function(empty) {
		# Produce image file
		grDevices::png(png.file, width=width, height=height, res=png.res)
		if(isTRUE(empty)) { plot.empty()
		} else            { plot.core()
		}
		grDevices::dev.off()
		
		# Refresh image
		tcltk::tkconfigure(plotImage, file=png.file, width=width, height=height)
		tcltk::tkconfigure(plotWidget, width=width, height=height)
	}
	
	# Replot using 'tkrplot' rendered
	plot.tkrplot <- function(empty) {
		tkrplot::tkrreplot(
			lab = plotWidget,
			fun = if(isTRUE(empty)) { plot.empty } else { plot.core },
			hscale = hscale * tkrplot.scale,
			vscale = vscale * tkrplot.scale
		)
	}
	
	# Correct tkrplot scale factor
	changeScale <- function() {
		tkrplot.scale <<- tk.value(
			parent = NULL,
			type = "double",
			title = "Expansion factor (1 = 100%)",
			default = tkrplot.scale,
			allowEmpty = FALSE
		)
		replot()
	}
	
	# Pixel / tkrplot "scale" unit conversion factor
	scaleFactor <- NA
	
	# Replot common workflow
	replot <- function(empty=FALSE) {
		# Check coordinates
		if(!isTRUE(empty)) empty <- index == 0L
		
		# Guess scale factor from 2 x 1 empty plot (1 scale unit = x un-resized pixels)
		if(render == "tkrplot" && is.na(scaleFactor)) {
			scaleFactor <<- as.integer(tcltk::tclvalue(tcltk::tkwinfo("width", plotWidget))) / 2
			if(scaleFactor < 100) stop("Scale factor detection seems to have failed (", scaleFactor, ")")
		}
		
		# Adjust size
		height <<- autoHeight()
		width <<- autoWidth()
		if(render == "tkrplot") {
			vscale <<- height / scaleFactor
			hscale <<- width / scaleFactor
		}
		
		# Grab focus to avoid keyboard shortcuts quirks
		tcltk::tkfocus(plotWidget)
		
		# Replot
		handle(
			expr = {
				if(render == "png")            { plot.png(empty=empty)
				} else if(render == "tkrplot") { plot.tkrplot(empty=empty)
				}
			},
			# Silently ignore message()
			messageHandler = NULL,
			# Pass warning() but continue execution
			warningHandler = function(w) {
				tcltk::tkmessageBox(
					parent = localTopLevel,
					icon = "warning",
					type = "ok",
					title = "Warning in model.test()",
					message = conditionMessage(w)
				)
			},
			# Pass stop() and stop execution
			errorHandler = function(e) {
				tcltk::tkmessageBox(
					parent = localTopLevel, 
					icon = "error",
					type = "ok",
					title = "Error in model.test()",
					message = conditionMessage(e)
				)
			}					
		)
		
		# Adjust for Windows's magnifying factor
		if(render == "tkrplot" && tkrplot.scale > 1) {
			tcltk::tcl("update", "idletasks")
			tcltk::tkconfigure(plotWidget, width=width - 10L)
			tcltk::tkconfigure(plotWidget, height=height)
		}
	
		# Model was updated
		enableUpdate()
	}
	
	autoAction <- function() {
		model <<- model.auto(
			segLogRatios = segLogRatios,
			segChroms = segChroms,
			segLengths = segProbes,
			from = as.double(tcltk::tclvalue(fromValue)),
			to = as.double(tcltk::tclvalue(toValue)),
			by = as.double(tcltk::tclvalue(byValue)),
			precision = as.integer(tcltk::tclvalue(precisionValue)),
			maxPeaks = as.integer(tcltk::tclvalue(maxPeaksValue)),
			minWidth = as.double(tcltk::tclvalue(minWidthValue)),
			maxWidth = as.double(tcltk::tclvalue(maxWidthValue)),
			minDensity = as.double(tcltk::tclvalue(minDensityValue)),
			peakFrom = model['peakFrom'],
			peakTo = model['peakTo'],
			ploidy = as.double(tcltk::tclvalue(ploidyValue)),
			method = tcltk::tclvalue(methodValue),
			discreet = TRUE,
			exclude = exclude
		)
		updateSliders()
		replot()
	}
	
	importRdt = function() {
		if(length(find.package("cghRA", quiet=TRUE)) > 0) {
			# File loading
			regions <<- Rgb::readRDT(arrayFiles[index])
			if(is(regions, "cghRA.regions")) {
				if(regions$rowCount > 0) {
					# Data extraction
					segStarts <<- regions$extract(, "start")
					segEnds <<- regions$extract(, "end")
					segChroms <<- regions$extract(, "chrom")
					segLogRatios <<- regions$extract(, "logRatio")
					segProbes <<- regions$extract(, "probes")
					model <<- regions$model
					
					# Interface update
					updateSliders()
					replot()
					
					return(TRUE)
				} else {
					tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message="The cghRA.regions object contains no region")
					return(FALSE)
				}
			} else {
				tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message="The .rdt file does not contain a valid cghRA.regions object")
				return(FALSE)
			}
		} else {
			tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message=".rdt files need the 'cghRA' package")
			return(FALSE)
		}
	}
	
	exportRdt <- function() {
		if(!is.null(regions)) {
			# Model update
			regions$model <<- model
			
			# Save regions to file
			saveRDT(regions, arrayFiles[index])
			
			# Save copies to file
			if(regions$modelized()) {
				copies <- regions$model.apply()
				saveRDT(copies, sub("\\.regions\\.rdt$", ".copies.rdt", arrayFiles[index]))
			} else {
				unlink(sub("\\.regions\\.rdt$", ".copies.rdt", arrayFiles[index]))
			}
			
			return(TRUE)
		} else {
			tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Exportation error", message="No valid cghRA.regions object in memory")
			return(FALSE)
		}
	}
	
	importTxt <- function() {
		tab <- try(utils::read.table(file=arrayFiles[index], sep="\t", dec=".", header=TRUE, stringsAsFactors=FALSE, comment.char="#"), silent=TRUE)
		if(!is(tab, "try-error")) {
			if(identical(names(tab), c("chrom", "start", "end", "probes", "logRatio"))) {
				# Region extraction
				segChroms <<- tab$chrom
				segStarts <<- tab$start
				segEnds <<- tab$end
				segLogRatios <<- tab$logRatio
				segProbes <<- tab$probes
				
				# Model extraction
				modelLine <- scan(file=arrayFiles[index], what="", sep="\n", n=1, quiet=TRUE)
				if(grepl("^#[A-Za-z]+=(([0-9\\.e-]+)|(NA))(, [A-Za-z]+=(([0-9\\.e-]+)|(NA)))*$", modelLine)) {
					modelLine <- substr(modelLine, 2, nchar(modelLine))
					modelLine <- strsplit(strsplit(modelLine, split=", ")[[1]], split="=")
					newModel <- suppressWarnings(as.numeric(sapply(modelLine, "[", 2)))
					names(newModel) <- sapply(modelLine, "[", 1)
					model <<- newModel
				} else {
					model <<- NA
				}
				
				# Interface update
				updateSliders()
				replot()
				
				return(TRUE)
			} else {
				tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message="Columns in tab-separated file must be :\n\nchrom\nstart\nend\nlogRatio\nprobes")
				return(FALSE)
			}
		} else {
			tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message=sprintf("Unable to read tab-separated file :\n\n%s", conditionMessage(attr(tab, "condition"))))
			return(FALSE)
		}
	}
	
	exportTxt <- function() {
		# Model
		modelLine <- sprintf("#%s", paste(sprintf("%s=%g", names(model), model), collapse=", "))
		
		# Save regions to file
		write(modelLine, file=arrayFiles[index], append=FALSE)
		suppressWarnings(
			utils::write.table(
				data.frame(
					chrom = segChroms,
					start = segStarts,
					end = segEnds,
					logRatio = segLogRatios,
					probes = segProbes,
					stringsAsFactors = FALSE
				),
				file = arrayFiles[index],
				sep = "\t",
				dec = ".",
				col.names = TRUE,
				row.names = FALSE,
				append = TRUE
			)
		)
		
		# Save copies to file
		if(!is.na(model['center']) && !is.na(model['width'])) {
			fileName <- sub("\\.txt$", ".copies.txt", arrayFiles[index])
			write(modelLine, file=fileName, append=FALSE)
			suppressWarnings(
				utils::write.table(
					model.apply(
						segStarts = segStarts,
						segEnds = segEnds,
						segChroms = segChroms,
						segLogRatios = segLogRatios,
						segLengths = segProbes,
						model = model,
						exact = FALSE,
						merge = TRUE
					),
					file = fileName,
					sep = "\t",
					dec = ".",
					col.names = TRUE,
					row.names = FALSE,
					append = TRUE
				)
			)
		}
		
		return(TRUE)
	}	
	
	importFile = function() {
		# File type
		extension <<- sub("^.*(\\.[^\\.]+)$", "\\1", arrayFiles[index])
		if(extension == ".rdt")        { status <- importRdt()
		} else if(extension == ".txt") { status <- importTxt()
		} else                         { tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message=sprintf("Unknown file extension \"%s\" (.rdt or .txt expected)", extension))
		}
		
		# Status
		if(status) { disableUpdate()
		} else     { tcltk::tkmessageBox(parent=localTopLevel, icon="error", type="ok", title="Importation error", message="Unable to import file, may be corrupted or with a wrong file extension")
		}
	}
	
	exportFile <- function() {
		# Cursor
		tcltk::tkconfigure(localTopLevel, cursor="watch")
		
		# Export
		if(extension == ".rdt")        { exportRdt()
		} else if(extension == ".txt") { exportTxt()
		} else                         { stop("Unexpected error in exportFile()")
		}
		
		# No need to update again
		disableUpdate()
		
		# Cursor
		tcltk::tkconfigure(localTopLevel, cursor="arrow")
	}
	
	nextFile <- function() {
		# Index update
		if(index >= length(arrayFiles)) {
			tcltk::tkmessageBox(parent=localTopLevel, icon="info", type="ok", title="Series complete", message="There is no next file to load")
		} else {
			# Deselect
			click.x <<- NULL
			click.y <<- NULL
			click.id <<- 0
			
			# Update
			index <<- index + 1L
			tcltk::tclvalue(arrayFilesValue) <- sprintf("%i/%i selected files", index, length(arrayFiles))
			importFile()
		}
	}
	
	previousFile <- function() {
		# Index update
		if(index <= 1) {
			tcltk::tkmessageBox(parent=localTopLevel, icon="info", type="ok", title="Series complete", message="There is no previous file to load")
		} else {
			# Deselect
			click.x <<- NULL
			click.y <<- NULL
			click.id <<- 0
			
			# Update
			index <<- index - 1L
			tcltk::tclvalue(arrayFilesValue) <- sprintf("%i/%i selected files", index, length(arrayFiles))
			importFile()
		}
	}
	
	enableUpdate <- function() {
		tcltk::tkconfigure(updateFileButton, background="#CC6666")
	}
	
	disableUpdate <- function() {
		tcltk::tkconfigure(updateFileButton, background=defaultBackground)
	}
	
	
	## INTERFACE ##
	
	embedded <- !missing(globalTopLevel) && !missing(localTopLevel)
	if(!embedded) {
		# Linux default style
		if(.Platform$OS.type == "unix") try(tcltk::tcl("ttk::style", "theme", "use", "clam"), silent=TRUE)
		
		# Top level
		globalTopLevel <- localTopLevel <- tcltk::tktoplevel(class="cghRA")
		tcltk::tktitle(localTopLevel) <- "cghRA - Modelization"
		icon16 <- tcltk::tcl("image", "create", "photo", file=system.file("cghRA_16x16.gif", package="cghRA"))
		icon32 <- tcltk::tcl("image", "create", "photo", file=system.file("cghRA_32x32.gif", package="cghRA"))
		tcltk::tcl("wm", "iconphoto", localTopLevel, "-default", icon16, icon32)
	}
	
	# Evolutive width
	tcltk::tkgrid.columnconfigure(localTopLevel, 1, weight=1)
	tcltk::tkgrid.rowconfigure(localTopLevel, 1, weight=1)
		
		# Plot frame
		plotFrame <- tcltk::ttklabelframe(parent=localTopLevel, relief="groove", borderwidth=2, text="Graphical representation")
		tcltk::tkgrid(plotFrame, column=1, columnspan=2, row=1, padx=5, pady=5, sticky="nsew")
		
			# R-Plot widget (wait for maximization to apply and propagate)
			tcltk::.Tcl("update idletasks")
			
			# Default size
			height <- 300L
			width <- autoWidth()
			
			if(render == "png") {
				# Display (empty) PNG image
				plotImage <- tcltk::tkimage.create("photo", width=width, height=height)
				plotWidget <- tcltk::tkcanvas(plotFrame, width=width, height=height)
				tcltk::tkcreate(plotWidget, "image", 0, 0, anchor="nw", image=plotImage)
			} else if(render == "tkrplot") {
				# tkrplot widget (fixed size image to guess scaleFactor)
				hscale <- 2
				vscale <- 0.6
				plotWidget <- tkrplot::tkrplot(parent=plotFrame, fun=plot.empty, hscale=hscale, vscale=vscale)
			}
			
			tcltk::tkgrid(plotWidget, column=1, row=1, padx=5, pady=5)
			
		# Slider frame
		sliderFrame <- tcltk::ttklabelframe(parent=localTopLevel, relief="groove", borderwidth=2, text="Model parameters")
			
			# Bandwidth slider
			bwSliderValue <- tcltk::tclVar("0")
			bwSliderText <- tcltk::tclVar("NA")
			bwSliderLabel1 <- tcltk::tklabel(sliderFrame, text="bandwidth", width=10)
			bwSliderLabel2 <- tcltk::tklabel(sliderFrame, textvariable=bwSliderText, width=10)
			bwSliderScale <- tcltk::tkscale(sliderFrame, from=0, to=0.5, showvalue=FALSE, variable=bwSliderValue, resolution=0.001, orient="horizontal", sliderlength=30, length=400, command=updateBw)
			tcltk::tkgrid(bwSliderLabel1, column=1, row=1, padx=2, pady=c(2,1))
			tcltk::tkgrid(bwSliderLabel2, column=2, row=1, padx=2, pady=1)
			tcltk::tkgrid(bwSliderScale, column=3, row=1, padx=2, pady=c(1,2), sticky="we")

			# Center slider
			centerSliderValue <- tcltk::tclVar("0")
			centerSliderText <- tcltk::tclVar("NA")
			centerSliderLabel1 <- tcltk::tklabel(sliderFrame, text="center", width=10)
			centerSliderLabel2 <- tcltk::tklabel(sliderFrame, textvariable=centerSliderText, width=10)
			centerSliderScale <- tcltk::tkscale(sliderFrame, from=0, to=4, showvalue=FALSE, variable=centerSliderValue, resolution=0.001, orient="horizontal", sliderlength=30, length=400, command=updateCenter)
			tcltk::tkgrid(centerSliderLabel1, column=1, row=2, padx=2, pady=c(2,1))
			tcltk::tkgrid(centerSliderLabel2, column=2, row=2, padx=2, pady=1)
			tcltk::tkgrid(centerSliderScale, column=3, row=2, padx=2, pady=c(1,2), sticky="we")
		
			# Width slider
			widthSliderValue <- tcltk::tclVar("0")
			widthSliderText <- tcltk::tclVar("NA")
			widthSliderLabel1 <- tcltk::tklabel(sliderFrame, text="width", width=10)
			widthSliderLabel2 <- tcltk::tklabel(sliderFrame, textvariable=widthSliderText, width=10)
			widthSliderScale <- tcltk::tkscale(sliderFrame, from=0, to=2, showvalue=FALSE, variable=widthSliderValue, resolution=0.001, orient="horizontal", sliderlength=30, length=400, command=updateWidth)
			tcltk::tkgrid(widthSliderLabel1, column=1, row=3, padx=2, pady=c(2,1))
			tcltk::tkgrid(widthSliderLabel2, column=2, row=3, padx=2, pady=1)
			tcltk::tkgrid(widthSliderScale, column=3, row=3, padx=2, pady=c(1,2), sticky="we")
		
		tcltk::tkgrid(sliderFrame, column=1, row=2, padx=5, pady=5, sticky="nsew")
		tcltk::tkgrid.columnconfigure(sliderFrame, 3, weight=1)
		
		# Peak range frame
		peakFrame <- tcltk::ttklabelframe(parent=localTopLevel, relief="groove", borderwidth=2, text="Peak range")
			
			# PeakFrom slider
			default <- paste(as.character(formals(model.auto)$peakFrom), collapse="")
			fromSliderValue <- tcltk::tclVar(default)
			fromSliderText <- tcltk::tclVar(default)
			fromSliderLabel1 <- tcltk::tklabel(peakFrame, text="peakFrom", width=10)
			fromSliderLabel2 <- tcltk::tklabel(peakFrame, textvariable=fromSliderText, width=10)
			fromSliderScale <- tcltk::tkscale(peakFrame, from=-10, to=1.5, showvalue=FALSE, variable=fromSliderValue, resolution=0.01, orient="horizontal", sliderlength=30, length=400, command=updateFrom)
			tcltk::tkgrid(fromSliderLabel1, column=1, row=1, padx=2, pady=c(2,1))
			tcltk::tkgrid(fromSliderLabel2, column=2, row=1, padx=2, pady=1)
			tcltk::tkgrid(fromSliderScale, column=3, row=1, padx=2, pady=c(1,2), sticky="we")
			
			# PeakTo slider
			default <- paste(as.character(formals(model.auto)$peakTo), collapse="")
			toSliderValue <- tcltk::tclVar(default)
			toSliderText <- tcltk::tclVar(default)
			toSliderLabel1 <- tcltk::tklabel(peakFrame, text="peakTo", width=10)
			toSliderLabel2 <- tcltk::tklabel(peakFrame, textvariable=toSliderText, width=10)
			toSliderScale <- tcltk::tkscale(peakFrame, from=-10, to=1.5, showvalue=FALSE, variable=toSliderValue, resolution=0.01, orient="horizontal", sliderlength=30, length=400, command=updateTo)
			tcltk::tkgrid(toSliderLabel1, column=1, row=2, padx=2, pady=c(2,1))
			tcltk::tkgrid(toSliderLabel2, column=2, row=2, padx=2, pady=1)
			tcltk::tkgrid(toSliderScale, column=3, row=2, padx=2, pady=c(1,2), sticky="we")
		
		tcltk::tkgrid(peakFrame, column=1, row=3, padx=5, pady=5, sticky="nsew")
		tcltk::tkgrid.columnconfigure(peakFrame, 3, weight=1)
		
		# Auto frame
		autoFrame <- tcltk::ttklabelframe(parent=localTopLevel, relief="groove", borderwidth=2, text="Auto model")
			
			# Auto model
			autoButton <- tcltk::tkbutton(parent=autoFrame, text="Modelize", command=autoAction, width=10)
			tcltk::tkgrid(autoButton, column=1, columnspan=3, row=1, padx=5, pady=c(10,15))
			
			# From
			fromValue <- tcltk::tclVar(formals(model.auto)$from)
			fromLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="bandwidth (from, to)")
			fromEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=fromValue)
			tcltk::tkgrid(fromLabel, column=1, row=2)
			tcltk::tkgrid(fromEntry, column=2, row=2)
			
			# To
			toValue <- tcltk::tclVar(formals(model.auto)$to)
			toEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=toValue)
			tcltk::tkgrid(toEntry, column=3, row=2, padx=c(0,5))
			
			# By
			byValue <- tcltk::tclVar(formals(model.auto)$by)
			byLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="bandwidth (by)")
			byEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=byValue)
			tcltk::tkgrid(byLabel, column=1, row=3)
			tcltk::tkgrid(byEntry, column=2, row=3)
			
			# Precision
			precisionValue <- tcltk::tclVar(formals(model.auto)$precision)
			precisionLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="precision")
			precisionEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=precisionValue)
			tcltk::tkgrid(precisionLabel, column=1, row=4)
			tcltk::tkgrid(precisionEntry, column=2, row=4)
			
			# Min density
			minDensityValue <- tcltk::tclVar(formals(model.auto)$minDensity)
			minDensityLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="minDensity*")
			minDensityEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=minDensityValue)
			tcltk::tkgrid(minDensityLabel, column=1, row=5)
			tcltk::tkgrid(minDensityEntry, column=2, row=5)
			
			# maxPeaks
			maxPeaksValue <- tcltk::tclVar(formals(model.auto)$maxPeaks)
			maxPeaksLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="maxPeaks")
			maxPeaksEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=maxPeaksValue)
			tcltk::tkgrid(maxPeaksLabel, column=1, row=6)
			tcltk::tkgrid(maxPeaksEntry, column=2, row=6)
			
			# minWidth
			minWidthValue <- tcltk::tclVar(formals(model.auto)$minWidth)
			minWidthLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="width (min, max)")
			minWidthEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=minWidthValue)
			tcltk::tkgrid(minWidthLabel, column=1, row=7)
			tcltk::tkgrid(minWidthEntry, column=2, row=7)
			
			# maxWidth
			maxWidthValue <- tcltk::tclVar(formals(model.auto)$maxWidth)
			maxWidthEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=maxWidthValue)
			tcltk::tkgrid(maxWidthEntry, column=3, row=7, padx=c(0,5))
			
			# Method
			methodValue <- tcltk::tclVar("stm")
			methodLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="method")
			methodEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=methodValue)
			tcltk::tkgrid(methodLabel, column=1, row=8)
			tcltk::tkgrid(methodEntry, column=2, row=8)
			
			# Ploidy
			ploidyValue <- tcltk::tclVar(formals(model.auto)$ploidy)
			ploidyLabel <- tcltk::tklabel(parent=autoFrame, padx=5, text="ploidy")
			ploidyEntry <- tcltk::tkentry(parent=autoFrame, width=6, textvariable=ploidyValue)
			tcltk::tkgrid(ploidyLabel, column=1, row=9)
			tcltk::tkgrid(ploidyEntry, column=2, row=9)
			
		tcltk::tkgrid(autoFrame, column=2, row=2, rowspan=3, padx=5, pady=5, sticky="nsew")
		
		# File frame
		fileFrame <- tcltk::ttklabelframe(parent=localTopLevel, relief="groove", borderwidth=2, text="Actions")
		tcltk::tkgrid.columnconfigure(fileFrame, 2, weight=1)
		tcltk::tkgrid.columnconfigure(fileFrame, 6, weight=1)
			
			# Resize button
			resizeButton <- tcltk::tkbutton(parent=fileFrame, text="Adjust plot size", command=changeScale)
			tcltk::tkgrid(resizeButton, column=1, row=1, padx=5, pady=5)
			
			# Previous file
			previousFileButton <- tcltk::tkbutton(parent=fileFrame, text="Previous", command=previousFile)
			tcltk::tkgrid(previousFileButton, column=3, row=1, padx=5, pady=5)
			
			# Array files
			arrayFilesValue <- tcltk::tclVar("Select files")
			arrayFilesButton <- tcltk::tkbutton(parent=fileFrame, textvariable=arrayFilesValue, command=arrayFilesBrowse, width=15)
			tcltk::tkgrid(arrayFilesButton, column=4, row=1, padx=5, pady=5)
			
			# Next file
			nextFileButton <- tcltk::tkbutton(parent=fileFrame, text="Next", command=nextFile)
			tcltk::tkgrid(nextFileButton, column=5, row=1, padx=5, pady=5)
			
			# Update file
			updateFileButton <- tcltk::tkbutton(parent=fileFrame, text="Update files", command=exportFile)
			tcltk::tkgrid(updateFileButton, column=7, row=1, padx=5, pady=5)
			defaultBackground <- as.character(tcltk::tkcget(updateFileButton, "-background"))
		
		tcltk::tkgrid(fileFrame, column=1, row=4, padx=5, pady=5, sticky="nsew")
	
	# Events
	tcltk::tkbind(plotWidget, "<ButtonPress-1>", mousePress)
}

Try the cghRA package in your browser

Any scripts or data that you put into this service are public.

cghRA documentation built on May 2, 2019, 3:34 a.m.