1### 2### This demonstration script creates a canvas widget showing a 2-D 3### plot with data points that can be dragged with the mouse. 4### 5### It is a ripoff of the plot.tcl demo from the tk 8.0 distribution 6### All I did was to add the code to plot the fitted regression line. 7 8# Copyright (C) 2000-2008 The R Core Team 9 10require(tcltk) || stop("tcl/tk library not available") 11require(graphics); require(stats) 12local({ 13 have_ttk <- as.character(tcl("info", "tclversion")) >= "8.5" 14 if(have_ttk) { 15 tkbutton <- ttkbutton 16 tkframe <- ttkframe 17 tklabel <- ttklabel 18 } 19 tclServiceMode(FALSE) # don't display until complete 20 top <- tktoplevel() 21 tktitle(top) <- "Plot Demonstration" 22 23 msg <- tklabel(top, 24 font="helvetica", 25 wraplength="4i", 26 justify="left", 27 text="This window displays a canvas widget containing a simple 2-dimensional plot. You can doctor the data by dragging any of the points with mouse button 1.") 28 29 tkpack(msg, side="top") 30 31 buttons <- tkframe(top) 32 tkpack(buttons, side="bottom", fill="x", pady="2m") 33 dismiss <- tkbutton(buttons, text="Dismiss", 34 command=function()tkdestroy(top)) 35 tkpack(dismiss, side="left", expand=TRUE) 36 37 canvas <- tkcanvas(top, relief="raised", width=450, height=300) 38 tkpack(canvas, side="top", fill="x") 39 40 plotFont <- "Helvetica 18" 41 42 tkcreate(canvas, "line", 100, 250, 400, 250, width=2) 43 tkcreate(canvas, "line", 100, 250, 100, 50, width=2) 44 tkcreate(canvas, "text", 225, 20, text="A Simple Plot", 45 font=plotFont, fill="brown") 46 47 # X tickmarks & labels 48 for (i in 0:10) { 49 x <- 100 + i * 30 50 tkcreate(canvas, "line", x, 250, x, 245, width=2) 51 tkcreate(canvas, "text", x, 254, 52 text=10*i, anchor="n", font=plotFont) 53 } 54 # Y tickmarks & labels 55 for (i in 0:5) { 56 y <- 250 - i * 40 57 tkcreate(canvas, "line", 100, y, 105, y, width=2) 58 tkcreate(canvas, "text", 96, y, 59 text=formatC(50*i,format="f",digits=1), 60 anchor="e", font=plotFont) 61 } 62 63 # The (original) data 64 points <- matrix(c(12, 56, 65 20, 94, 66 33, 98, 67 32, 120, 68 61, 180, 69 75, 160, 70 98, 223), ncol=2, byrow=TRUE) 71 72 ## `self-drawing' point object 73 point.items <- apply(points, 1, function(row) { 74 x <- 100 + 3 * row[1] 75 y <- 250 - 4/5 * row[2] 76 item <- tkcreate(canvas, "oval", x - 6, y - 6, x + 6, y + 6, 77 width=1, outline="black", 78 fill="SkyBlue2") 79 tkaddtag(canvas, "point", "withtag", item) 80 item 81 }) 82 83 plotDown <- function(x, y) { 84 ## This procedure is invoked when the mouse is pressed over one 85 ## of the data points. It sets up state to allow the point 86 ## to be dragged. 87 ## 88 ## Arguments: 89 ## x, y - The coordinates of the mouse press. 90 x <- as.numeric(x) 91 y <- as.numeric(y) 92 tkdtag(canvas, "selected") 93 tkaddtag(canvas, "selected", "withtag", "current") 94 tkitemraise(canvas,"current") 95 lastX <<- x 96 lastY <<- y 97 } 98 99 plotMove <- function(x, y) { 100 ## This procedure is invoked during mouse motion events. 101 ## It drags the current item. 102 ## 103 ## Arguments: 104 ## x, y - The coordinates of the mouse. 105 x <- as.numeric(x) 106 y <- as.numeric(y) 107 tkmove(canvas, "selected", x - lastX, y - lastY) 108 lastX <<- x 109 lastY <<- y 110 } 111### FIXME : Don't allow points to be moved outside the canvas !! 112 113 plotLine <- function(){ 114 coords <- lapply(point.items, 115 function(item) 116 as.double(tkcoords(canvas,item))) 117 x <- sapply(coords, function(z) (z[1]+z[3])/2) 118 y <- sapply(coords, function(z) (z[2]+z[4])/2) 119 lm.out <- lm(y~x) 120 x0 <- range(x) 121 y0 <- predict(lm.out, data.frame(x=x0)) 122 tkcreate(canvas, "line", x0[1], y0[1], x0[2], y0[2], width=3) 123 } 124 125 line <- plotLine() 126 127 lastX <- 0 128 lastY <- 0 129 130 tkitembind(canvas, "point", "<Any-Enter>", 131 function() tkitemconfigure(canvas, "current", 132 fill="red")) 133 tkitembind(canvas, "point", "<Any-Leave>", 134 function() tkitemconfigure(canvas, "current", 135 fill="SkyBlue2")) 136 tkitembind(canvas, "point", "<1>", plotDown) 137 tkitembind(canvas, "point", "<ButtonRelease-1>", 138 function(x){ 139 tkdtag(canvas, "selected") 140 tkdelete(canvas, "withtag", line) 141 line <<- plotLine() 142 }) 143 tkbind(canvas, "<B1-Motion>", plotMove) 144 tclServiceMode(TRUE) 145 146 cat("******************************************************\n", 147 "The source for this demo can be found in the file:\n", 148 file.path(system.file(package = "tcltk"), "demo", "tkcanvas.R"), 149 "\n******************************************************\n") 150 151}) 152