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