Nothing
print.tsgui <- function(x,..., details=FALSE) {
n <- names(x)
idx <- sapply(strsplit(n, ".mi"), length) > 1 |
sapply(strsplit(n, ".ma"), length) > 1 |
sapply(strsplit(n, ".intege"), length) > 1
name <- attr(x, "model")
if (!is.null(name)) cat("'", name, "' is a ")
class(x) <- NULL
if (details) base::print(x)
else utils::str(x[!idx], ..., give.attr=FALSE) ##
}
str.tsgui <- function(object, ..., give.attr=FALSE) {
name <- attr(object, "model")
if (!is.null(name)) cat("'", name, "' is a ")
class(object) <- NULL
utils::str(object,..., give.attr=give.attr) ##
}
ARMA.model <- function(p.max=3, q.max=3) {
nphi <- p.max
ntheta <- q.max
stopifnot(nphi >= 0, ntheta >= 0, nphi + ntheta > 0)
arma.phi <- c(if (nphi > 0) c(0.5, rep(0, nphi - 1)),
if (ntheta > 0) c(0.5, rep(0, ntheta -1))
)
names(arma.phi) <- c(if (nphi > 0) paste("phi", 1:nphi),
if (ntheta > 0) paste("theta", 1:ntheta))
starting.ts <- rep(0, nphi)
if (nphi > 0) names(starting.ts) <- paste("process value at", (1-nphi):0)
starting.innovations <- rep(0, ntheta)
if (ntheta > 0)
names(starting.innovations) <- paste("innovation at", (1-ntheta):0)
ARMA <-
list(
time = 2000,
burn.in=20L,
repetitions = 1L,
phi = arma.phi,
phi.min = c(rep(-2, nphi),
rep(-2, ntheta)),
phi.max = c(rep(2, nphi),
rep(2, ntheta)),
distr = c(norm=function(p, param) qnorm(p, 0, param[1]),
exponential=function(p, param) qexp(p, rate=1/param[2])-param[2],
cauchy=function(p, param) qcauchy(p, scale=param[3])
),
distr.param = c("normal sigma" = 1,
"exponential inverse rate"=0.5,
"cauchy scale"=0.01
),
distr.param.min = c(0.01, 0.2, 0.001),
distr.param.max = c(10, 10, .1),
distr.show = c("normal"=TRUE, "exponential"=FALSE, "cauchy"=FALSE),
titles = list(function(phi) {
theta <- phi[-1:-nphi]
i <- nphi
while (i>0 && phi[i] == 0) i <- i - 1;
j <- ntheta
while (j>0 && theta[j] == 0) j <- j - 1;
if (j == 0) {
if (i == 0) "white noise"
else paste("AR(", i, ")", sep="")
} else {
if (i==0) paste("MA(", j, ")", sep="")
else paste("ARMA(", i, ", ", j, ")", sep="")
}
},
function(phi) {
i <- nphi
while (i>0 && phi[i] == 0) i <- i - 1;
if (i == 0) "stationary process"
else {
r <- polyroot(c(1, -phi[1:i]))
r.re <- round(Re(r) * 1000) / 1000
r.im <- round(Im(r) * 1000) / 1000
r.txt <- format(r.re + r.im * 1i, dig=2)
if (any(r.im==0)) r.txt[r.im==0] <- format(r.re[r.im==0], dig=2)
outside <- all(Mod(r)>1)
paste(if (!outside) "not all ",
"roots of phi (", paste(r.txt, collapse=";"),
") outside unit circle, i.e. ", if (!outside) "non-",
"causal", sep="")
}
}),
update.function = function(innovations, phi, start.ts) {
theta <- phi[-1:-nphi]
phi <- phi[1:nphi]
n.innovations <- nrow(innovations) - length(theta)
X <- rbind(start.ts,
matrix(NA, ncol=ncol(start.ts), nrow=n.innovations))
for (i in 1:n.innovations) {
segX <- i + nphi
segI <- i + ntheta
u <- innovations[segI, ]
if (nphi > 0) u <- u + (phi %*% X[segX + (-1 : - nphi), ])
if (ntheta > 0) u <- u+(theta %*% innovations[segI + (-1 : - ntheta), ])
X[segX, ] <- u
}
X
},
starting.ts = starting.ts,
starting.ts.min = rep(-10, nphi),
starting.ts.max = rep(10, nphi),
starting.matrix.ts = function(repetitions, n.distr, param) {
matrix(param, nrow=length(param), ncol=n.distr * repetitions)
},
starting.innovations = starting.innovations,
starting.innovations.min = rep(-10, ntheta),
starting.innovations.max = rep(10, ntheta),
starting.matrix.innovations = function(repetitions, n.distr, param) {
matrix(param, nrow=length(param), ncol=n.distr * repetitions)
}
)
attr(ARMA, "multivariate") <- 1
attr(ARMA, "model") <- "ARMA"
class(ARMA) <- "tsgui"
ARMA
}
GARCH.model <- function(a.max=3, b.max=3) {
na <- a.max
nb <- b.max
stopifnot(na > 1, nb >= 0)
garch.a <- c(c(0.005, 0.1, rep(0, na - 2)),
if (nb > 0) c(0.5, rep(0, nb -1)))
names(garch.a) <- c(paste("a", 0:(na-1)), ## x
if (nb > 0) paste("b", 1:nb)) ## sigma^2
starting.ts <- rep(0, nb)
if (nb > 0) names(starting.ts) <- paste("process value at", (1-nb):0)
starting.innovations <- rep(0, na)
names(starting.innovations) <- paste("innovation at", (1-na):0)
GARCH <-
list(
time = 2000,
burn.in=20L,
repetitions = 1L,
phi = garch.a,
phi.min = c(rep(0, na),
rep(0, nb)),
phi.max = c(0.01, rep(10, na-1) / na,
if (nb > 0) c(3, rep(1.5, nb - 1)) / b.max),
#
## button whether they should be used
distr = c(norm=function(p, param) qnorm(p, 0, param[1]),
exponential=function(p, param) qexp(p, rate=1/param[2])-param[2],
cauchy=function(p, param) qcauchy(p, scale=param[3])
),
distr.param = c("normal sigma" = 1,
"exponential inverse rate"=1,
"cauchy scale"=0.01
),
distr.param.min = c(0.01, 0.2, 0.001),
distr.param.max = c(10, 10, .1),
distr.show = c("normal"=TRUE, "exponential"=FALSE, "cauchy"=FALSE),
titles = list(function(a) {
b <- a[-1:-na]
i <- na
while (i>0 && a[i] == 0) i <- i - 1;
j <- nb
while (j>0 && b[j] == 0) j <- j - 1;
if (j == 0) {
if (i <= 1) c("white noise", "constant")
else c(paste("ARCH(", i-1, ")", sep=""), "sigma")
} else {
if (i==0) c("independent variables", paste("deterministic", sep=""))
else c(paste("GARCH(", i-1, ", ", j,")", sep=""), "sigma")
}
}),
update.function = function(innovations, a, start.ts) {
b <- a[-1:-na]
a0 <- a[1]
a <- a[2:na]
n.innovations <- nrow(innovations) - na + 1
X <- innovations
S2 <- rbind(start.ts,
matrix(NA, ncol=ncol(start.ts), nrow=n.innovations))
for (i in 1:n.innovations) {
segS <- i + nb
segX <- i + na - 1
u <- a0 + (a %*% X[segX + 1 + (-2 : -na), ]^2)
## if (i == 1) Print(u, a, a0, nb)
if (nb > 0) u <- u + (b %*% S2[segS + (-1 : -nb), ])
S2[segS, ] <- u
X[segX, ] <- sqrt(S2[segS, ]) * X[segX, ]
}
list(X=X, sigma=sqrt(S2))
},
starting.ts = starting.ts,
starting.ts.min = rep(0, nb),
starting.ts.max = rep(10, nb),
starting.matrix.ts = function(repetitions, n.distr, param) {
matrix(param, nrow=length(param), ncol=n.distr * repetitions)
},
starting.innovations = starting.innovations,
starting.innovations.min = rep(-10, na),
starting.innovations.max = rep(10, na),
starting.matrix.innovations = function(repetitions, n.distr, param) {
matrix(param[-1], nrow=length(param)-1, ncol=n.distr * repetitions)
}
)
attr(GARCH, "multivariate") <- 2
attr(GARCH, "model") <- "GARCH"
class(GARCH) <- "tsgui"
GARCH
}
tsgui <- function(user = NULL,
wait = 1000,
included.models =c("ARMA", "GARCH")
) {
if (length(included.models) > 0) {
included.models <- match.arg(included.models, several.ok = TRUE)
all.included.models <- eval(as.list(args(tsgui))$included.models)
}
#### see https://www.tcl.tk/man/tcl/TkCmd/label.htm
if (!interactive()) {
#warning("'tsgui' can be used only in an interactive mode")
#return(NULL)
}
wait <- as.integer(wait)
Env <- if (wait >= 0) environment() else .GlobalEnv
if (exists(".tsgui.exit", .GlobalEnv))
rm(".tsgui.exit", envir=.GlobalEnv)
order.show <- list("time",
"burn.in",
"repetitions", ## how often is simulation study repeated?
## Then it gives the time instance at which it is shown
"GLOBAL:INNOVATIONS" = c(1),
"distr.show",
"MODEL PARAMETERS" = c(1, 1, 1),
"phi",
"INNOVATION PARAMETERS" = c(2, 2),
"distr.param",
"STARTING VALUES" = c(3, 3),
"starting.ts",
"starting.innovations"
)
constraints <- list(
time.min = 2L, ## fraction of totaltime
time.max = 10000L,
burn.in.min = 0L, ## fraction of totaltime
burn.in.max = 50L,
repetitions.min = 1L,
repetitions.max = 5L,
distr.show.min = FALSE,
distr.show.max = TRUE,
phi.min = -1,
phi.max = 1,
distr.param.min = 0,
distr.param.max = 10,
starting.ts.min = -10,
starting.ts.max = 10,
starting.innovations.min = -10,
starting.innovations.max = 10
)
if (length(user) > 0) {
if (!is.list(user[[1]])) user <- list(user = user)
modelclasses <- user
} else modelclasses <-list()
for (i in included.models)
modelclasses[[i]] <- switch(pmatch(i, all.included.models),
"1" = ARMA.model(),
"2" = GARCH.model()
)
tsgui.intern(currentClass = 1,
order.show = order.show,
constraints = constraints,
parent.ev = Env,
modelclasses = modelclasses)
if (wait >= 0) {
while (!exists(".tsgui.exit", envir=Env))
RandomFieldsUtils::sleep.micro(wait)
res <- get(".tsgui.exit", envir=Env)
rm(".tsgui.exit", envir=Env)
if (is.null(res)) return(res)
for (i in 1:length(res)) {
if (is.function(res[[i]])) environment(res[[i]]) <- .GlobalEnv
}
class(res) <- "tsgui"
return(res)
} else invisible(NULL)
}
tsgui.intern <- function(currentClass,
order.show,
constraints,
parent.ev=NULL,
colour=c("black", "darkred", "darkblue",
"orange", "darkgreen"),
# subcol=c("grey", "red", "lightblue",
# "yellow", "green", "orange"),
fgcol=c("white", "white", "white", "white", "white"),
modelclasses = NULL
) {
# set.mixcol <- c(colour[1], subcol[-1])
max.sets <- length(colour)
numberSteps <- 256L ## even
image.rowspan <- 15L
image.colspan <- 5L
fst.col <- 1L
half.col <- fst.col + 0L
snd.col <- half.col + 2L
trd.col <- snd.col + c(3L, 5L)
fst.row <- 1L
snd.row <- 17L
trd.row <- 32L ## position of sliders of global variables
col.sl <- fst.col + 2 * image.colspan + 1L ## position of slides for model
row.last <- image.rowspan + 4L
row.sl <- 1L # giving the position of the first label
width.entry <- 4L
width.slider <- 15L ## 18L
length.slider <- 170L
length.slider.main <- 130L
plothscale <- 1.6 # Horizontal scaling, defines real size of image
plotvscale <- 1.6 # Vertical scaling, defines real size of image
## plothscale <- 2.5
importance <- rep(2, 10)
fg <- c("black", "gray25", "gray40", "gray70")
col.alert <- "darkred"
ENVIR <- environment()
L <- (wait.simulation <- innovations <- Len <- isinteger <- minall
<- maxall <- islogical <- imgLU <- sumLen <- strictpos
<- currentNrVariab <- tt <- sets <- buttonNewSimu <- classTitle
<- col_bg <- copyFctn <- buttonReturn
<- NULL)
tkDestroy <- tcltk::tkdestroy
tkValue <- tcltk::tclvalue
"tkValue<-" <- do.call("::", list("tcltk", "tclvalue<-"))
tkLabel <- tcltk::tklabel
tkEntry <- tcltk::tkentry
tkScale <- tcltk::tkscale
tkBind <- tcltk::tkbind
tkGridConf <- tcltk::tkgrid.configure
tkVar <- tcltk::tclVar
tkGrid <- tcltk::tkgrid
tkPlot <- tkrplot::tkrplot
tkCheckbutton <- tcltk::tkcheckbutton
tkCheckbutton <- tcltk::tkcheckbutton
tkConfigure <- tcltk::tkconfigure
Tcl <- tcltk::tcl
tkRreplot <- tkrplot::tkrreplot
tkButton <- tcltk::tkbutton
tkDelete <- tcltk::tkgrid.forget
non.show.loc <- which(names(order.show) != "")
titles.val <- order.show[non.show.loc]
idx <- sapply(titles.val, is.logical)
do.not.show <- names(titles.val[idx])
titles.loc <- non.show.loc[!idx]
titles.val <- order.show[titles.loc]
rawtitles <- strsplit(names(titles.val), "GLOBAL:")
titles <- sapply(rawtitles, function(x) if (length(x) == 1) x else x[2])
globaltitles <- sum(rawtitles != titles)
globalParams <- titles.loc[1 + globaltitles] - globaltitles - 1
titles.guiloc <- c(titles.loc, 9999)
for (i in 1:length(titles.loc))
titles.guiloc[i] <- titles.guiloc[i] - sum(non.show.loc < titles.loc[i])
Names <- unlist(order.show[-non.show.loc])
min.names <- paste(Names, "min", sep=".")
max.names <- paste(Names, "max", sep=".")
integer.names <- paste(Names, "integer", sep=".")
all.names <- c(Names, do.not.show)
Laengen <- sapply(modelclasses, function(x) sapply(x[all.names], length))
row.names(Laengen) <- all.names
orig.constraints <- rep(list(constraints), length(modelclasses))
multivariate <- sapply(modelclasses, function(x) {
v <- attr(x, "multivariate")
if (length(v) == 0) 1 else v
})
storedvariables <- c("L", "Len", "minall", "maxall", "isinteger",
"islogical", "strictpos")
setClassLists <- function(s) {
assign("currentClass", s, envir = ENVIR)
assign("currentNrVariab", multivariate[s], envir=ENVIR)
assign("Len", apply(Laengen, 1, max), envir=ENVIR)
##
assign("Len", Laengen[, s], envir=ENVIR)
assign("sumLen", sum(Len), envir=ENVIR)
constraints <- orig.constraints[[s]]
for (i in 1:length(Len)) {
m <- max(Len[i], length(constraints[[min.names[i]]]))
constraints[[min.names[i]]] <- rep(constraints[[min.names[i]]],
length.out=m)
constraints[[max.names[i]]] <- rep(constraints[[max.names[i]]],
length.out=m)
}
assign("constraints", constraints, envir=ENVIR)
Lorig <- modelclasses[[s]]
for (n in all.names)
Lorig[[n]] <- c(Lorig[[n]], rep(NaN, Len[n] - length(Lorig[[n]])))
modelclasses[[s]] <- Lorig
assign("modelclass", envir=ENVIR, modelclasses)
L <- Lorig[all.names]
Len <- sapply(L, length)
names(Len) <- all.names
L[do.not.show] <- Lorig[do.not.show]
is_fctn <- sapply(Lorig, function(x) is.function(x) ||
(is.list(x) && is.function(x[[1]])))
fctnNames <- names(Lorig)[is_fctn]
L[fctnNames] <- Lorig[fctnNames]
maxall <- constraints[max.names]
tmp <- Lorig[max.names]
tmp <- tmp[sapply(tmp, length) > 0]
for (n in names(tmp)) { ## wegen strictpos
x <- c(tmp[[n]], rep(if (is.logical(tmp[[n]])) FALSE else -1,
length(maxall[[n]]) - length(tmp[[n]])))
maxall[[n]] <- x
}
## maxall[names(tmp)] <- tmp
val <- titles.val
tmp <- Lorig[titles]
tmp <- tmp[sapply(tmp, length) > 0]
val[names(tmp)] <- tmp
assign("titles.val", val, envir=ENVIR)
minall <- constraints[min.names]
islogical <- lapply(minall, function(x) rep(is.logical(x), length(x)))
for (i in 1:length(Names))
if ( #Len[i] == 0 ||
length(islogical[[i]]) < Len[i] || any(is.na(islogical[[i]]))) {
stop("'", Names[i], "' has an incomplete definition.\nSee 'order.show', 'constraints' and the model definition itself.\n")
}
isinteger <- lapply(minall, function(x) rep(is.integer(x), length(x)))
tmp <- Lorig[min.names]
tmp <- tmp[sapply(tmp, length) > 0]
for (n in names(tmp)) { ## wegen strictpos
x <- c(tmp[[n]], rep(if (is.logical(tmp[[n]])) FALSE else -1,
length(minall[[n]]) - length(tmp[[n]])))
minall[[n]] <- x
}
names(isinteger) <- integer.names
for (cond in list(constraints, Lorig)) {
tmp <- cond[integer.names]
names(tmp) <- integer.names
tmp.idx <- sapply(tmp, length) > 0
isinteger[tmp.idx] <- tmp[tmp.idx]
}
strictpos <- lapply(minall, function(m) m > 0)
names(strictpos) <- Names
for (v in storedvariables) assign(v, get(v), envir=ENVIR)
}
ERROR <- function(txt) {
cat(txt, "\n")
OnReturn()
}
Cat <- function(...) cat(...)
Cat <- function(...) {}
isScalar <- function(i) Len[i] == 1
noeffect <- "next slider has no effect"
labName <- function(i, j) {
n0 <- names(L[[i]])
if (!is.finite(L[[Names[i]]][j])) return(noeffect)
if (length(n0) > 0) n0[j] else
paste(Names[i], if (!isScalar(i)) paste("[", j, "]", sep=""), sep="")
}
labObj <- function(i, j) paste(Names[i], "_", j, sep="")
basename <- function(name, j, set=1)
paste(name, set, if (!missing(j) && length(j)>0) j else 1, sep="")
BaseName <- function(i, j, set=1) basename(Names[i], j, set)
slValue <- function(i, j, set=1)
paste("sl_", BaseName(i, j, set), sep="")
entryValue <- function(i, j, set=1)
paste("entry_", sep="",
if (is.numeric(i)) BaseName(i, j, set) else basename(i, j, set))
slWidget <- function(i, j, set=1)
paste("wiS_", BaseName(i, j, set), sep="")
entryWidget <- function(i, j, set=1)
paste("wiE_", BaseName(i, j, set), sep="")
buttonWidget <- function(i, j, set=1)
paste("wiB_", BaseName(i, j, set), sep="")
Value <- function(name, j, set=1) { ## sehr langsam !!
prefix <- "entry_"
if (missing(j)) {
len <- Len[name]
if (len == 0) return(logical(0))
ans <- numeric(len)
variab <- paste(prefix, basename(name, 1:len, set), sep="")
for (j in 1:len) {
ans[j] <- tkValue(get(variab[j], envir=ENVIR))
}
} else {
variab <- paste(prefix, basename(name, j, set), sep="")
ans <- tkValue(get(variab, envir=ENVIR))
}
as.numeric(ans)
}
simuValue <- function(set) paste("simu_", set, sep="")
deleteFctn <- function(set) paste("delete_", set, sep="")
firstFctn <- function(set) paste("first_", set, sep="")
classButton <- function(s) paste("buttonClass", s, sep="")
entryAssign <- function(i, j, set=1, value) { ## loest EntryChanges aus
entry <- get(entryValue(i, j, set=set), envir=ENVIR)
if (isinteger[[i]][j]) value <- as.integer(round(value))
tkValue(entry) <- value
assign(entryValue(i, j, set=set), entry, envir=ENVIR)
}
slAssign <- function(i, j, value) { ## loest SliderChanges aus
sl <- get(slValue(i, j), envir=ENVIR)
tkValue(sl) <- value
assign(slValue(i, j), sl, envir=ENVIR)
}
GetL <- function(set=1) {
L <- modelclasses[[currentClass]]
for (i in 1:length(all.names)) {
if (Len[i] > 0)
for (j in 1:Len[i]) {
if (is.finite(L[[ all.names[i] ]][j])) {
L[[all.names[i]]][j] <-
as.numeric(tkValue(get(entryValue(all.names[i],j, set),
envir=ENVIR)))
}
}
}
L[names(minall)] <- minall
L[names(maxall)] <- maxall
modelclasses[[currentClass]] <- L
assign("modelclasses", modelclasses, envir=ENVIR)
orig.constraints[[currentClass]] <- constraints
assign("orig.constraints", orig.constraints, envir=ENVIR)
L[names(isinteger)] <- isinteger
L[names(islogical)] <- islogical
attr(L, "model") <- names(modelclasses)[[currentClass]]
return(L)
}
first <- function(set, changeEntry=TRUE) { #, do.simu=TRUE, do.plot=TRUE) {
## assign("wait.simulation", c(first=sumLen - 1), envir=ENVIR)
simu <- get(simuValue(set))
for (v in storedvariables) assign(v, simu[[v]], envir=ENVIR)
for (i in 1:length(Names)) {
if (Len[i] > 0)
for (j in 1:Len[i]) {
a <- as.numeric(tkValue(get(entryValue(i, j), envir=ENVIR)))
b <- as.numeric(tkValue(get(entryValue(i, j, set), envir=ENVIR)))
entryAssign(i, j, set=set, value=a)
entryAssign(i, j, value=b)
if (changeEntry) EntryChangesShort(i, j, value=b)
}
}
assign("wait.simulation", c(first=0), envir=ENVIR)
entryAssign(i, j, value=b)
a <- get(simuValue(1), envir=ENVIR)
for (v in storedvariables) a[[v]] <- get(v, envir=ENVIR)
b <- get(simuValue(set), envir=ENVIR)
assign(simuValue(set), a, envir=ENVIR)
assign(simuValue(1), b, envir=ENVIR)
for (v in storedvariables) assign(v, b[[v]], envir=ENVIR)
setClass()
}
setClass <- function() {
starting.values(sets=1)
start_simu(update="time")
assign("wait.simulation", c(position=sumLen -1), envir=ENVIR)
position()
tkRreplot(imgLU)
}
copy <- function(...) {
sets <- get("sets", envir=ENVIR)
set <- which(!sets)
if (length(set) == 0) return()
set <- set[1]
sets[set] <- TRUE
assign("sets", sets, envir=ENVIR)
for (i in 1:length(Names)) {
if (Len[i] > 0)
for (j in 1:Len[i])
entryAssign(i, j, set,
as.numeric(tkValue(get(entryValue(i, j), envir=ENVIR))))
}
simu <- get(simuValue(1), envir=ENVIR)
for (v in storedvariables) simu[[v]] <- get(v, envir=ENVIR)
assign(simuValue(set), simu, envir=ENVIR)
assign("wait.simulation", c(copy=0), envir=ENVIR)
position()
tkRreplot(imgLU)
}
delete <- function(set) {
stopifnot(set > 1)
sets <- get("sets", envir=ENVIR)
sets[set] <- FALSE
assign("sets", sets, envir=ENVIR)
tkDelete(get(deleteFctn(set), envir=ENVIR))
tkDelete(get(firstFctn(set), envir=ENVIR))
for (i in 3:length(Names)) {
if (Len[i]>0)
for (j in 1:Len[i]) {
widget <- (if (islogical[[i]][j]) buttonWidget(i, j, set)
else entryWidget(i, j, set))
tkDelete(get(widget, envir=ENVIR))
}
}
assign("wait.simulation", c(delete=0), envir=ENVIR)
position()
tkRreplot(imgLU)
}
EntryChangesShort <- function(i, j, set=1, factor=3, value) {
if (islogical[[i]][j]) return();
is.int <- isinteger[[i]][j]
if (is.int) value <- as.integer(base::round(value))
s <- strictpos[[i]][j]
if (missing(value)) stop("missing value in EntryChangesShort")
if (set == 1) {
if (value == 0) {
from <- minall[[i]][j]
to <- maxall[[i]][j]
} else if (!is.logical(minall[[i]][j])) {
from <- if (value < 0) value * factor else value / factor
to <- if (value > 0) value * factor else value / factor
minall[[i]][j] <<- from
maxall[[i]][j] <<- to
}
if (s) {
value <- sqrt(value)
from <- sqrt(from)
to <- sqrt(to)
}
tkConfigure(get(slWidget(i, j, set=set), envir=ENVIR),
to=to, from=from,
resolution=if (is.int) -1 else (to-from)/numberSteps)
slAssign(i, j, value=value) ## zwingend nach tkconfigure
# v <- as.numeric(tkValue(get(slValue(i,j,set),envir=ENVIR)))
# if (s) v <- v^2
# if (isinteger[[i]][j]) v <- as.integer(base::round(v))
# entryAssign(i, j, set, value=v)
}
}
EntryChanges <- function(i, j, set=1, factor=3) {
value <- as.numeric(tkValue(get(entryValue(i, j, set=set), envir=ENVIR)))
EntryChangesShort(i, j, set=set, factor=factor, value=value)
if (set != 1) {
for (i in 1:2) first(set, changeEntry=FALSE)
}
assign("wait.simulation", get("wait.simulation", envir=ENVIR) - 1 , envir=ENVIR)
if (get("wait.simulation", envir=ENVIR) < 0) {
name <- Names[i]
start_simu(update=name)
tkRreplot(imgLU)
}
return(NULL)
}
SliderChanges <- function(i, j, set=1) {
Evalue <- value <-
as.numeric(tkValue(get(slValue(i,j,set=set), envir=ENVIR)))
name <- Names[i]
if (strictpos[[i]][j]) Evalue <- Evalue^2
if (isinteger[[i]][j]) Evalue <- as.integer(base::round(Evalue))
entryAssign(i, j, set=set, value=Evalue)
assign("wait.simulation", get("wait.simulation", envir=ENVIR) - 1 , envir=ENVIR)
if (get("wait.simulation", envir=ENVIR) < 0) {
start_simu(update=name)
tkRreplot(imgLU)
}
return(Evalue)
}
get.RS <- function() .Random.seed[length(.Random.seed)]
start_simu <- function(update, all=FALSE) {
Cat("start_simu ... ", if (missing(update)) "" else update, "...")
repetitions <- Value("repetitions")
time <- Value("time")
burn.in <- Value("burn.in")
totaltime <- time + burn.in
# if (!exists("innovations", envir=ENVIR))
# assign("innovations", matrix(NA, nrow=totaltime, ncol=repetitions))
if (!exists("all.rs", envir=ENVIR)) {
runif(1)
all <- TRUE
}
if (ts.unif <- burn.in.unif <- do.distr <- all) {
assign("all.rs",
if (exists("all.rs", envir=ENVIR)) get("all.rs", envir=ENVIR)+100
else
base::round(runif(1,1,100000)), envir=ENVIR)
} else {
if (missing(update)) ERROR("update missing")
switch(update,
"time" = ts.unif <- do.distr <- TRUE,
"burn.in" = burn.in.unif <- do.distr <- TRUE,
"repetitions" = ts.unif <- burn.in.unif <- do.distr <- TRUE,
"phi" = NULL,
"distr.param" = do.distr <- TRUE,
"distr.show" = do.distr <- TRUE,
"starting.ts" = NULL,
"starting.innovations" = do.distr <- TRUE,
{
ERROR("unknown parameter")
}
)
}
show <- Value("distr.show")
if (ts.unif) {
if (all) assign("ts.seed", get.RS(), envir=ENVIR)
ts.unif <- matrix(nrow=time, ncol = repetitions)
for (i in 1:repetitions) {
set.seed(get("ts.seed", envir=ENVIR) + (i-1) * 100)
ts.unif[, i] <- runif(time)
}
assign("ts.unif", ts.unif, envir=ENVIR)
}
if (burn.in.unif) {
if (all) assign("burn.in.seed", get.RS(), envir=ENVIR)
burn.in.unif <- matrix(nrow=burn.in, ncol = repetitions)
for (i in 1:repetitions) {
set.seed(get("burn.in.seed", envir=ENVIR) + (i-1) * 100)
burn.in.unif[, i] <- rev(runif(burn.in))
}
assign("burn.in.unif", burn.in.unif, envir=ENVIR)
}
if (do.distr) {
innovations <- matrix(NA, nrow=totaltime, ncol=repetitions * length(show))
param <- Value("distr.param")
unif <- rbind(get("burn.in.unif", envir=ENVIR),
get("ts.unif", envir=ENVIR))
for (d in 1:length(L$distr))
if (show[d]) {
idx <-(d-1) * repetitions + (1:repetitions)
# Print(idx, unif, param, L$distr[[d]](unif, param))
innovations[, idx] <- L$distr[[d]](unif, param)
}
start.inno <- L$starting.matrix.innovations(repetitions, length(show),
Value("starting.innovations"))
assign("innovations", rbind(start.inno, innovations), envir=ENVIR)
}
Cat("ende\n")
}
plotvoid <- function()
plot(Inf, Inf, xlim=c(0,1), ylim=c(0,1), axes=FALSE, xlab="", ylab="")
plotSimulation <- function() {
## print("plotSimulation"); print(get("wait.simulation", envir=ENVIR))
assign("wait.simulation",
get("wait.simulation", envir=ENVIR) - 1 , envir=ENVIR)
if (get("wait.simulation", envir=ENVIR) >= 0) return()
show <- which(Value("distr.show") != 0)
ls <- length(show)
if (!exists("all.rs", envir=ENVIR) || ls == 0) {
plotvoid()
return()
}
Cat("simu ... ")
start.ts <-Value("starting.ts")
start.inno <-Value("starting.innovations")
phi <- Value("phi")
repet <- Value("repetitions")
## first distr all repetitions; second distr all repet, etc.
col.idx <- as.vector(outer(1:repet, (show - 1) * repet, "+"))
inno <- innovations[, col.idx, drop=FALSE]
burn.in <- Value("burn.in")
ntime <- Value("time")
burn.in <- Value("burn.in")
row.idx.inno <- nrow(inno) + 1 - (ntime:1)
start.ts.matrix <- L$starting.matrix.ts(repet, ls, start.ts)
## Print(start.ts.matrix, start.inno, repet, ls, start.ts, show)
row.idx.ts <- function(M) nrow(M) + 1 - (ntime:1)
stopifnot(all(row.idx.inno > 0))
if (is(L$update.function, "RegisteredNativeSymbol")) {
stop("not programmed yet")
} else {
X <- L$update.function(inno, phi, start.ts.matrix)
}
assign(simuValue(1), envir=ENVIR,
list(X=X, dim.i=dim(inno), dim.s=dim(start.ts) ))
titles <- list()
n.titles <- length(L$titles)
for (i in 1:n.titles) titles[[i]] <- L$titles[[i]](phi)
n.sets <- sum(sets)
par(mfcol=c(currentNrVariab + 1, 1), cex=0.8, mar=c(3.2, 4.2, 0.2, 0.2))
s.sets <- rev(which(sets))
lty <- rep(show, each=repet)
pch <- 1:repet
# Print(col.idx, pch, lty)
if (simple.repet <- length(s.sets)==1 &&
xor(repet > 1, ls > 1))
rbcol <- c(colour, rainbow(repet * show))[1:(repet * ls)]
type <- (if (sum(c(length(s.sets), repet, ls) != 1) <= 1) "l"
else "b")
matplot(1:ntime, inno[row.idx.inno, ],
cex.lab=1.4, cex.axis=1.4, xlab="", #"time",
ylab="innovations",
type=type,
col=if (simple.repet) rbcol else colour[1],
pch = pch, lty=lty)
max.ylim <- 1e100
for (m in 1:currentNrVariab) {
M <- if (is.list(X)) X[[m]] else X
row.idx <- row.idx.ts(M)
y <-try(range(M[row.idx, ], na.rm=TRUE), silent=TRUE)
if (is(y, "try-error") || any(is.na(y)) ||
y[2] > max.ylim || y[1] < -max.ylim) {
plot(Inf, Inf, xlab="", ylab="", xlim=c(0,1), ylim=c(0,1))
text(0.5,0.5, label="no finite value with these innovations and these model parameters")
next
}
plot(1:ntime, rep(NA, ntime), ylim=y,
cex.lab=1.4, cex.axis=1.4, xlab="", # "time",
ylab= if (n.titles > 0) titles[[1]][m] else ""
)
for (set in s.sets) {
simu <- get(simuValue(set), envir=ENVIR)
M <- if (is.list(simu$X)) simu$X[[m]] else simu$X
row.idx <- row.idx.ts(M)
stopifnot(all(row.idx > 0))
try(silent= TRUE,
matlines(1:ntime,
M[row.idx, ],
type=type,
col=if (simple.repet) rbcol else colour[set],
pch = pch, lty=lty))
}
if (n.titles > 1)
for (i in 2:n.titles)
text(0, y[2] - diff(y) * (i-2), cex = 1.2,
adj=c(0,1), titles[[i]][m], col="darkred")
}
Cat("ende\n")
}
OnReturn <- function(...) {
#RFoptions(LIST=get("RFopt.old", envir=ENVIR))
assign(".tsgui.exit", GetL(), envir=parent.ev)
tkDestroy(tt)
}
position_j <- function(i, row, col) {
if (Len[i] == 0) return(row)
for (j in 1:Len[i]) {
tkGridConf(get(labObj(i, j), envir=ENVIR), pady=1,
column=col, row=row, sticky="w")
if (i==globalParams + 1 && j==1) {
tkGridConf(copyFctn, column=col + 0, row=row, sticky="e", pady=1)
}
if (islogical[[i]][j]) {
tkGridConf(get(buttonWidget(i,j), envir=ENVIR), column=col + 0,
pady=1, row=row, sticky="e")
if (sum(sets) > 1) {
for (set in which(sets)[-1]) {
tkGridConf(get(buttonWidget(i,j,set), envir=ENVIR),
pady=1, column=col + 2 * set + 1, row=row)
}
}
} else {
row <- row+1
tkGridConf(get(slWidget(i,j), envir=ENVIR), column=col, row=row,
pady=1, sticky="w")
tkGridConf(get(entryWidget(i,j), envir=ENVIR), column=col + 0,
pady=1, row=row, sticky="e")
if (sum(sets) > 1) {
for (set in which(sets)[-1]) {
tkGridConf(get(entryWidget(i,j,set), envir=ENVIR),
pady=1, column=col + 2 * set + 1, row=row)
}
}
}
row <- row+1
}
return(row)
}
position <- function(...) {
# tkGridConf(emptyColumn, column=col.sl - 1, row=1, sticky="w")
##--- Parameterwaehler ----------------------------------------------
title.count <- 1
row <- trd.row
for (i in 1:globalParams) {
if (titles.guiloc[title.count] == i) {
row <- trd.row
tkGridConf(get(titles[title.count], envir=ENVIR),
column=trd.col[title.count + 1], row=row)
row <- row + 1
title.count <- title.count + 1
}
row <- position_j(i, row, trd.col[title.count])
}
row <- -1
orig.title.count <- title.count
for (i in (globalParams + 1):length(Names)) {
if (titles.guiloc[title.count] == i) {
row <- row + 2
if (sum(sets) > 1 && title.count == orig.title.count) {
for (set in which(sets)[-1]) {
tkGridConf(get(deleteFctn(set), envir=ENVIR),
column=col.sl + 2 * set,
row=row, sticky="w")
tkGridConf(get(firstFctn(set), envir=ENVIR),
column=col.sl + 2 * set + 1,
row=row, sticky="w")
}
} else {
tkGridConf(get(titles[title.count], envir=ENVIR),
column=col.sl, row=row)
}
row <- row + 1
title.count <- title.count + 1
}
row <- position_j(i, row, col.sl)
}
##--- Buttons - new simulation (new seed), return ---------------
tkGridConf(buttonNewSimu,column=half.col, row=row<-trd.row+1, sticky="e")
tkGridConf(buttonReturn, column=half.col, row=row <- row + 2, sticky="e")
##--- PLOT ---------------------------------------------------------
tkGridConf(imgLU, rowspan= 2 * image.rowspan, columnspan=2 * image.colspan,
column=fst.col, row=fst.row,sticky="w")
if (length(modelclasses) > 1) {
row <- trd.row
tkGridConf(classTitle, column=snd.col, row=row, sticky="e")
Namen <- names(modelclasses)
for (s in 1:length(modelclasses)) {
tkGridConf(get(classButton(s), envir=ENVIR),
column=snd.col, row=row <- row + 1,
sticky="e")
}
}
} ## end fct position
classButtons <- function() {
Namen <- names(modelclasses)
for (s in 1:length(modelclasses)) {
# text <- paste("function(...) { delete.titles(); setClassLists(", s,
# ");classButtons();setClass()}")
text <- paste("function(...) { ",
"GetL();",
"setClassLists(", s, "); setClass(); restart()}")
Delete(X <- classButton(s))
assign(X, envir=ENVIR,
tkButton(tt, text=Namen[s], command=eval(parse(text=text)),
fg=if (s == currentClass) col.alert else "black"
))
}
}
Delete <- function(X)
if (exists(X, envir=ENVIR, inherits=FALSE))
do.call("rm", list(X, envir=ENVIR))
SetSlider <- function(i, j, set=1, value, length.slider) {
from <- minall[[i]][j]
to <- maxall[[i]][j]
s <- strictpos[[i]][j]
if (s) {
value <- sqrt(value)
from <- sqrt(from)
to <- sqrt(to)
}
sltext <- paste("function(...) SliderChanges(i=", i, ", j=", j,
", set=", set, ")")
Delete(X <- slWidget(i, j, set))
Delete(Y <- slValue(i, j, set))
assign(Y, tkVar(value), envir=ENVIR)
assign(X,
tkScale(tt, command = eval(parse(text=sltext)),
from= from,
to = to,
showvalue=FALSE,
variable=get(Y),
## neg value needed to get precise bounds
# bd = 1,
resolution=(if (isinteger[[i]][j]) -1
else (to - from) / numberSteps),
orient="horizontal",
length=length.slider,
width=width.slider),
envir=ENVIR)
}
SetEntry <- function(i, j, set=1, value) {
Delete(X <- entryValue(i, j, set))
if (isinteger[[i]][j]) value <- as.integer(round(value))
assign(X, tkVar(value), envir=ENVIR)
# text <- paste("function(...) EntryChanges(i=", i, ", j=", j,
# ", set=", set, ")")
text <- paste("function(...) EntryChanges(i=", i, ", j=", j,
", set=", set, ");"
)
Delete(X <- entryWidget(i, j, set))
assign(X, tkEntry(tt, width=width.entry, borderwidth=1,
selectborderwidth=1,
textvariable=get(entryValue(i,j,set), envir=ENVIR)),
envir=ENVIR)
tkBind(get(entryWidget(i, j, set), envir=ENVIR), "<Return>",
eval(parse(text=text)))
}
SetButton <- function(i, j, set=1, value) {
Delete(X <- entryValue(i, j, set))
assign(X, tkVar(value), envir=ENVIR)
Delete(X <- buttonWidget(i, j, set))
assign(X, envir=ENVIR,
tkCheckbutton(tt, onvalue = TRUE, offvalue=FALSE,
variable=get(entryValue(i,j,set), envir=ENVIR),
command=function(...) {
start_simu(all=TRUE)
tkRreplot(imgLU)}))
}
delete.titles <- function() {
for (i in 1:length(Names)) {
if (Len[i] > 0)
for (j in 1:Len[i]) {
Delete(n <- labObj(i, j))
assign(n, tkLabel(tt, text = labName(i, j),fg=col_bg
## ,bd=1
),
envir=ENVIR)
}
}
assign("wait.simulation", c(delete=0), envir=ENVIR)
position()
}
starting.values <- function(sets=1:max.sets) {
sub.n <- 1
title.count <- 1
for (i in 1:length(Names)) {
## cat("starting.values ", i, "\n")
if (titles.guiloc[title.count] == i) {
importance <- titles.val[[title.count]]
sub.n <- 1
title.count <- title.count + 1
}
if (Len[i] > 0) {
val <- L[[i]]
val[!is.finite(val)] <- 1 ## dummy
for (j in 1:Len[i]) {
for (set in sets) {
if (islogical[[i]][j]) {
SetButton(i, j, set, value=val[j])
} else {
SetSlider(i, j, set, value=val[j],
if (title.count<2) length.slider.main
else length.slider)
v <- as.numeric(tkValue(get(slValue(i,j,set),envir=ENVIR)))
if (strictpos[[i]][j]) v <- v^2
SetEntry(i, j, set, value=v)
}
}
Delete(n <- labObj(i, j))
ln <- labName(i, j)
assign(n, tkLabel(tt, text = ln,
fg=if (ln==noeffect) fg[length(fg)]
else fg[importance[sub.n]]
# ,bd=1
),
envir=ENVIR)
}
}
sub.n <- sub.n + 1
}
if (length(do.not.show) > 0) {
for (i in 1:length(do.not.show)) {
if (Len[i] > 0) {
val <- L[[do.not.show[i]]]
for (j in 1:Len[i]) {
for (set in sets) {
Delete(X <- entryValue(do.not.show[i], j, set))
assign(X, tkVar(val[j]), envir=ENVIR)
}
}
}
}
}
}
main <- function() {
cat("opening a new window ...")
assign("sets", c(TRUE, rep(FALSE, max.sets - 1)), envir=ENVIR)
setClassLists(currentClass)
tt <- tcltk::tktoplevel()
tcltk::tktitle(tt) <- "Time Series Gui"
tcltk::tkwm.protocol(tt, "WM_DELETE_WINDOW", OnReturn)
## tkGrid(tkLabel(tt, text="", width=1, height=0), column=0, row=0)
tkGrid(tkLabel(tt, text="", width=1), column=fst.col+image.colspan,row=1)
tkGrid(tkLabel(tt, text="", width=1), column=snd.col+image.colspan,row=1)
tkGrid(tkLabel(tt, text="", width=1), column=col.sl+image.colspan, row=1)
##
assign("col_bg", tkValue(tcltk::tkcget(tt, "-bg")), envir=ENVIR)
## col_fg <- tkValue(tcltk::tkcget(tt, "-fg"))
assign("tt", tt, envir = ENVIR)
## checkbuttion setzt die variable und fuehrt dann noch zusaetzlich
## command aus.
##--- Buttons ----------------------------
assign("buttonNewSimu", envir=ENVIR,
tkButton(tt,text="New innovations",
command=function(...) {
start_simu(all=TRUE)
tkRreplot(imgLU)}))
assign("buttonReturn", envir=ENVIR,
tkButton(tt, text=" Return ",
command=OnReturn, fg = col.alert))
assign("copyFctn", envir=ENVIR,
tkButton(tt, text="cpy", command=copy, fg="green"))
assign("classTitle", envir=ENVIR, tkLabel(tt, text="MODELS", fg=col.alert))
assign("emptyColumn", envir=ENVIR, tkLabel(tt, text=" "))
for (i in 1:length(Names))
assign(titles[i], tkLabel(tt, text=titles[i], fg=col.alert, bd=1),
envir=ENVIR)
assign(simuValue(1), NULL, envir=ENVIR)
for (set in 2:max.sets) {
assign(simuValue(set), NULL, envir=ENVIR)
text <- paste("function(...) delete(", set, ")")
assign(deleteFctn(set),
tkButton(tt, text="d", command=eval(parse(text=text)),
bg=colour[set], fg=fgcol[set]), envir=ENVIR)
text <- paste("function(...) first(", set, ")")
assign(firstFctn(set),
tkButton(tt, text="1", command=eval(parse(text=text)),
bg=colour[set], fg=fgcol[set]), envir=ENVIR)
}
assign("wait.simulation", c(start = 1 + sumLen - sum(unlist(islogical))),
envir=ENVIR)
classButtons()
assign("imgLU", envir = ENVIR,
tkPlot(tt,
fun = plotSimulation,
hscale=plothscale, vscale=plotvscale))
starting.values()
start_simu(all=TRUE)
position()
tkRreplot(imgLU)
}
restart <- function() {
tkDestroy(tt)
main()
}
main()
}
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.