1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158
|
## FIX up for non-integer values
setClass("gSlidertcltk",
contains="gComponenttcltk",
prototype=prototype(new("gComponenttcltk"))
)
setMethod(".gslider",
signature(toolkit="guiWidgetsToolkittcltk"),
function(toolkit,
from=0, to=100, by = 1,
value=from,
horizontal=TRUE,
handler=NULL, action=NULL,
container=NULL, ...) {
force(toolkit)
## if from a single value, then from, to ,by specify sequence
if(length(from) == 1)
x <- seq(from, to, by)
else
x <- from
## x needs sorting, make unique
x <- sort(unique(x)) # do I need to do for different types
ind <- seq_along(x)
value <- which(as.character(value) == as.character(x))
if(is(container,"logical") && container)
container = gwindow()
if(!is(container,"guiWidget")) {
warning("Container is not correct. No NULL containers possible\n" )
return()
}
if(horizontal)
orientation <- "horizontal"
else
orientation <- "vertical"
tt <- getWidget(container)
SliderValue <- tclVar(as.character(value))
## ## use old school. ttk:::scale doesn't allow steps, using other values.
## slider <- tkscale(tt, from=1L, to=length(x),
## showvalue=FALSE, variable=SliderValue,
## resolution=1L, orient=orientation)
slider <- tkwidget(tt, "ttk::scale", from=1L, to=length(x), variable=SliderValue,
orient=orientation)
obj <- new("gSlidertcltk",block=slider, widget=slider,
toolkit=toolkit, ID=getNewID(), e = new.env())
tag(obj,"..tclVar") <- SliderValue
tag(obj, "..byIndexValues") <- x
## ## modify label
## modifyLabel <- function() {
## tkconfigure(slider, label=format(svalue(obj), digts=3))
## }
## modifyLabel()
## tkbind(slider, "<Motion>", modifyLabel)
add(container, obj,...)
if (!is.null(handler)) {
id <- addhandlerchanged(obj, handler, action)
}
return(obj)
})
### methods
setMethod(".svalue",
signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"),
function(obj, toolkit, index=NULL, drop=NULL, ...) {
rbValue = tag(obj,"..tclVar")
val <- as.numeric(tclvalue(rbValue))
if(is.null(index) || !index) {
x <- tag(obj, "..byIndexValues")
val <- x[val]
}
return(val)
})
setReplaceMethod(".svalue",
signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"),
function(obj, toolkit, index=NULL, ..., value) {
## can set by index or match
if(is.null(index) || index==FALSE) {
value <- match(value, tag(obj, "..byIndexValues"))
} else {
value <- value
}
n <- length(tag(obj, "..byIndexValues"))
if(!is.na(value) &&
value >= 1 &&
value <= n)
tclvalue(tag(obj,"..tclVar")) <- value
## ## update label
## tkconfigure(getWidget(obj), label=format(svalue(obj), digts=3))
return(obj)
})
##' return values
setMethod(".leftBracket",
signature(toolkit="guiWidgetsToolkittcltk",x="gSlidertcltk"),
function(x, toolkit, i, j, ..., drop=TRUE) {
tag(x, "..byIndexValues")
})
## Method to replace values of spin button
setReplaceMethod("[",
signature(x="gSlidertcltk"),
function(x, i, j,..., value) {
.leftBracket(x, x@toolkit, i, j, ...) <- value
return(x)
})
## Method to replace values of spin button
setReplaceMethod(".leftBracket",
signature(toolkit="guiWidgetsToolkittcltk",x="gSlidertcltk"),
function(x, toolkit, i, j, ..., value) {
obj <- x
widget <- getWidget(obj)
curVal <- svalue(obj)
value <- sort(unique(value))
tag(obj, "..byIndexValues") <- value
tkconfigure(widget, from=1, to=length(value))
svalue(obj) <- curVal
return(obj)
})
### handlers
setMethod(".addhandlerchanged",
signature(toolkit="guiWidgetsToolkittcltk",obj="gSlidertcltk"),
function(obj, toolkit, handler, action=NULL, ...) {
# .addHandler(obj,toolkit, signal="<ButtonRelease-1>",handler,action)
.addHandler(obj,toolkit, signal="command",handler,action)
})
|