ghyp-slider.R

.slider.env = new.env()

.sliderMenu <- function(refresh.code, names, minima, maxima, resolutions,
                        starts, title = "Slider", no = 0, set.no.value = 0) {
    # Requirement:
    if (!require(tcltk, quietly = TRUE))
      stop("\n -- Package tcltk not available -- \n\n")

    # Environment:
    if (!exists(".slider.env"))
      .slider.env <<- new.env()

    if (no != 0) {
      options(show.error.messages = FALSE)
      ans <- as.numeric(tclvalue(get(paste("slider", no, sep = ""),
                        env = .slider.env)))
      options(show.error.messages = TRUE)
      return(ans)
    }

    if (set.no.value[1] != 0) {
      try(eval(parse(text = paste("tclvalue(slider", set.no.value[1],
          ") <- ", set.no.value[2], sep = "")), env = .slider.env),
          silent = TRUE)
      return(set.no.value[2])
    }

    # Toplevel:
    nt <- tktoplevel()
    tkwm.title(nt, title)

    # Slider:
    for (i in seq(names)) {
      eval(parse(text = paste("assign(\"slider", i, "\",
           tclVar(starts[i]), env = .slider.env)", sep = "")))
      tkpack(fr <- tkframe(nt), anchor = "sw")
      lab <- tklabel(fr, text = names[i], anchor = "sw")
      sc <- tkscale(fr, command = refresh.code, from = minima[i],
                    to = maxima[i], showvalue = TRUE, resolution =
                    resolutions[i], orient = "horiz")
      assign("sc", sc, env = .slider.env)
      tkgrid(sc, lab)
      eval(parse(text = paste("tkconfigure(sc, variable = slider", i, ")",
           sep = "")), env = .slider.env)
    }

    tkpack(fr <- tkframe(nt), anchor = "sw")

    # Quit:
    quitButton <- tkbutton(fr, text = "   Quit   ",
      command <- function() {
        tkdestroy(nt)
      })

    # Reset:
    resetButton <- tkbutton(fr, text = "   Start | Reset   ",
      command <- function() {
        for (i in seq(starts)) eval(parse(text =
          paste("tclvalue(slider", i, ")<-", starts[i], sep = "")),
                env = .slider.env)
          refresh.code()
      })

    # Compose:
    tkgrid(resetButton, quitButton, sticky = "sew")
}

ghypSlider <- function() {
  refresh.code <- function(...) {

    # Sliders:
    N <- .sliderMenu(no = 1)
    mu <- .sliderMenu(no = 2)
    delta <- .sliderMenu(no = 3)
    alpha <- .sliderMenu(no = 4)
    beta  <- .sliderMenu(no = 5)
    lambda <- .sliderMenu(no = 6)

    param <- c(mu, delta, alpha, beta, lambda)

    # Plot Data:
    xmin <- round(qghyp(0.01, param = param), digits = 2)
    xmax <- round(qghyp(0.99, param = param), digits = 2)
    x <- seq(xmin, xmax, length = N)
    y <- dghyp(x, param = param)
    main <- paste("GHyp Density\n",
        "mu = ", as.character(mu), " | ",
        "delta = ", as.character(delta), " | ",
        "alpha = ", as.character(alpha), " | ",
        "beta = ", as.character(beta), " | ",
        "lambda = ", as.character(lambda))

    # Density:
    plot(x, y, type = "l", xlim = c(xmin, xmax), col = "steelblue")
    abline(h = 0, lty = 3)
    title(main = main)
  }

  # Open Slider Menu:
  .sliderMenu(refresh.code,
     names =       c( "N", "mu", "delta", "alpha", "beta", "lambda"),
     minima =      c(  50, -5.0, -0.0,     0.0,    -2.0,   -2.0),
     maxima =      c(1000,  5.0,  10.0,    2.0,     2.0,    2.0),
     resolutions = c(  50,  1.0,  1.0,     0.2,     0.2,    0.5),
     starts =      c(  50,  0.0,  1.0,     1.0,     0.0,    1.0))
}