Nothing
##' @include GWidget.R
NULL
##' Toolkit constructor
##'
##' @inheritParams gWidgets2::gcalendar
##' @export
##' @rdname gWidgets2tcltk-undocumented
##' @method .gcalendar guiWidgetsToolkittcltk
.gcalendar.guiWidgetsToolkittcltk <- function(toolkit,
text="",
format="%Y-%m-%d",
handler = NULL,action = NULL, container = NULL, ... ) {
GCalendar$new(toolkit,
text=text,
format=format,
handler = handler,action = action, container = container, ...)
}
## Calendar
GCalendar <- setRefClass("GCalendar",
contains="GWidget",
fields=list(
"format"="character",
date_var="ANY"
),
methods=list(
initialize=function(toolkit=NULL,
text="",
format="%Y-%m-%d",
handler, action, container, ...) {
block <<- ttkframe(container$get_widget())
date_var <<- tclVar("")
widget <<- ttkentry(block, textvariable=date_var)
id <- getStockIconByName("date")
button <- ttkbutton(block, text="date",
image=id, compound="image",
command=.self$popup_date
)
tkpack(widget, expand=TRUE, fill="x", side="left")
tkpack(button, side="left")
initFields(format=format,
change_signal="<<Changed>>"
)
set_value(text)
add_to_parent(container, .self, ...)
handler_id <<- add_handler_changed(handler, action)
add_bindings()
callSuper(toolkit)
},
popup_date=function() {
cur_date <- get_value()
if(is.na(cur_date))
cur_date <- Sys.Date()
makeCalendar(date_var, widget, cur_date, format, set_value)
},
get_value=function(drop=TRUE, ...) {
val <- as.character(tclvalue(date_var))
cur_date <- try(as.Date(val, format="%Y-%m-%d"))
if(is.na(cur_date))
cur_date <- as.Date(NA)
if(missing(drop) || is.null(drop) || drop)
format(cur_date, format=format)
else
cur_date
},
set_value=function(value, ...) {
if(value == "") return()
d <- as.Date(value, format=format)
tclvalue(date_var) <<- format(d)
invoke_change_handler()
},
add_bindings = function() {
add_handler("<Return>",function(...) {
set_value(as.character(tclvalue(date_var)))
})
add_handler("<FocusOut>",function(...) {
set_value(as.character(tclvalue(date_var)))
})
}
))
## helper
##' make a calendar...
##'
##' @param date_var var
##' @param widget var
##' @param date var
##' @param date_format var
##' @param set_value var
makeCalendar <- function(date_var, widget, date, date_format="%Y-%m-%d", set_value) {
if(missing(date))
date <- Sys.Date()
date <- as.Date(date)
year <- as.POSIXlt(date)$year + 1900
month <- as.POSIXlt(date)$mon + 1
##
toplevel <- tktoplevel()
tktitle(toplevel) <- gettext("Select a day")
## make transient to widget
xpos <- as.numeric(tkwinfo("rootx", widget))
ypos <- as.numeric(tkwinfo("rooty", widget))
tkwm.geometry(toplevel,paste("+",xpos+30,"+",ypos+30,sep="")) # shift
tkwm.transient(toplevel, widget) # set transient
tkbind(widget, "<Destroy>",function(...) tkdestroy(toplevel))
tkbind(widget, "<Unmap>",function(...) tkdestroy(toplevel))
##
f <- ttkframe(toplevel, padding=c(3,3,12,12))
tkpack(f, expand=TRUE, fill="both", side="top")
cframe <- ttkframe(f)
calframe <- ttkframe(f)
tkpack(cframe, fill="x", side="top")
tkpack(calframe, expand=TRUE, anchor="n")
year <- year; month <- month # function local
##' from chron with slight change to arguments
day.of.week <- function (year, month, day) {
ix <- year + trunc((month - 14)/12)
jx <- (trunc((13 * (month + 10 - (month + 10)%/%13 * 12) -
1)/5) + day + 77 + (5 * (ix - (ix%/%100) * 100))%/%4 +
ix%/%400 - (ix%/%100) * 2)
jx%%7
}
## is this a valid date
validDate <- function(year, month, day)
!is.na(as.Date(sprintf("%s-%s-%s", year, month, day), format="%Y-%m-%d"))
## how many days in a month
days.in.month <- function(year, month) {
for(i in c(31, 30, 29, 28)) {
if(validDate(year, month, i))
return(i)
}
}
## 0-based week of month
week.of.month <- function(year, month, day) {
first.day <- day.of.week(year, month, 1)
(first.day + day - 1) %/% 7
}
makeMonth <- function(w, year, month) {
## add headers
days <- c("S","M","T","W","Th","F","S")
lapply(1:7, function(i) {
l <- ttklabel(w, text=days[i]) # color
tkgrid(l, row=0, column=i-1, sticky="")
})
## add days
lapply(1:days.in.month(year, month), function(day) {
l <- ttklabel(w, text=day)
## bind to each day
## might be more efficient to bind to toplevel and intercept
tkbind(l, "<Button-1>", function(W) {
day <- sprintf("%s-%s-%s", year, month, tclvalue(tkcget(W,"-text")))
set_value(day)
tkdestroy(toplevel)
})
tkgrid(l, row=1 + week.of.month(year, month, day),
column=day.of.week(year, month, day),
sticky="e")
})
}
## controls
prevy <- ttklabel(cframe, text="<<")
prevm <- ttklabel(cframe, text="<")
nextm <- ttklabel(cframe, text=">")
nexty <- ttklabel(cframe, text=">>")
curmo <- ttklabel(cframe)
tkpack(prevy, side="left", anchor="w", padx=2)
tkpack(prevm, side="left", anchor="w")
tkpack(curmo, side="left", anchor="center", expand=TRUE, padx=2)
tkpack(nextm, side="left", anchor="e")
tkpack(nexty, side="left", anchor="e", padx=2)
setMonth <- function() {
tclServiceMode(TRUE)
sapply(as.character(tkwinfo("children", calframe)), tkpack.forget)
# calframe <<- ttkframe(f); tkpack(calframe)
makeMonth(calframe, year, month)
tkconfigure(curmo, text=sprintf("%s %s", month.abb[month], year))
tclServiceMode(TRUE)
}
setMonth() # initial calendar
## lock up size
tkbind(prevy, "<Button-1>", function() {
year <<- year - 1
setMonth()
})
tkbind(prevm, "<Button-1>", function() {
if(month > 1) {
month <<- month - 1
} else {
month <<- 12; year <<- year - 1
}
setMonth()
})
tkbind(nextm, "<Button-1>", function() {
if(month < 12) {
month <<- month + 1
} else {
month <<- 1; year <<- year + 1
}
setMonth()
})
tkbind(nexty, "<Button-1>", function() {
year <<- year + 1
setMonth()
})
}
Any scripts or data that you put into this service are public.
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.