path: root/inst/GUI/gmkin.R

# gWidgetsWWW2 GUI for mkin {{{1

# Copyright (C) 2013,2014 Johannes Ranke
# Portions of this file are copyright (C) 2013 Eurofins Regulatory AG, Switzerland
# Contact: jranke@uni-bremen.de

# This file is part of the R package mkin

# mkin is free software: you can redistribute it and/or modify it under the
# terms of the GNU General Public License as published by the Free Software
# Foundation, either version 3 of the License, or (at your option) any later
# version.

# This program is distributed in the hope that it will be useful, but WITHOUT
# ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
# FOR A PARTICULAR PURPOSE.  See the GNU General Public License for more
# details.

# You should have received a copy of the GNU General Public License along with
# this program. If not, see <http://www.gnu.org/licenses/>

# Set the GUI title and create the basic widget layout {{{1
w      <- gwindow("gmkin - Browser based GUI for kinetic evaluations using mkin")
sb     <- gstatusbar(paste("Powered by gWidgetsWWW2 (ExtJS, Rook)",
                           "and mkin (FME, deSolve and minpack.lm)",
                           "--- Working directory is", getwd()), cont = w)
pg     <- gpanedgroup(cont = w, default.size = 260)
center <- gnotebook(cont = pg)
left   <- gvbox(cont = pg, use.scrollwindow = TRUE)
# Set initial values {{{1
# Initial project workspace contents {{{2
project_name <- "FOCUS_2006_gmkin"
project_file <- paste0(project_name, ".RData")
workspace <- get(project_name)     # From dataset distributed with mkin
studies.df <- workspace$studies.df # dataframe containing study titles
ds <- workspace$ds                 # list of datasets
ds.cur <- workspace$ds.cur         # current dataset index
m <- workspace$m                   # list with mkinmod models, amended with mkinmod$name
m.cur <- workspace$m.cur           # m.cur current model index
f <- workspace$f                   # f list of fitted mkinfit objects
f.cur <- workspace$f.cur           # current fit index
s <- workspace$s                   # list of summaries of the fitted mkinfit objects
# Initialise meta data objects so assignments within functions using <<- will {{{2
# update them in the right environment
observed.all <- vector()           # vector of names of observed variables in datasets
ds.df <- data.frame()
m.df <- data.frame()
f.df <- data.frame()
# Empty versions of meta data {{{2
f.df.empty <- data.frame(Fit = as.integer(0), 
                         Dataset = "", 
                         Model = "",
                         stringsAsFactors = FALSE)
# Helper functions {{{1
# Override function for making it possible to override original data in the GUI {{{2
override <- function(d) {
  data.frame(name = d$name, time = d$time, 
             value = ifelse(is.na(d$override), d$value, d$override),
             err = d$err)
}
# Update dataframe with datasets for selection {{{2
update_ds.df <- function() {
  ds.n <- length(ds)
  ds.df <<- data.frame(Index = 1:ds.n, 
                       Title = character(ds.n),
                       Study = character(ds.n), 
                       stringsAsFactors = FALSE)
  for (i in 1:ds.n)
  {
    ds.index <- names(ds)[[i]]
    ds.df[i, "Title"] <<- ds[[ds.index]]$title
    ds.df[i, "Study"] <<- ds[[ds.index]]$study_nr
    observed = as.character(unique(ds[[ds.index]]$data$name))
    observed.all <<- union(observed, observed.all)
  }
}
# Update dataframe with models for selection {{{2
update_m.df <- function() {
  m.n <- length(m)
  m.df <<- data.frame(Index = 1:m.n, 
                      Name = character(m.n),
                      stringsAsFactors = FALSE)
  for (i in 1:m.n) {
    m.index <- names(m)[[i]]
    m.df[i, "Name"] <<- m[[m.index]]$name
  }
}
# Update dataframe with fits for selection {{{2
update_f.df <- function() {
  f.df <<- f.df.empty
  f.count <- 0
  for (fit.index in names(f)) {
    f.count <- f.count + 1
    ftmp <- f[[fit.index]]
    f.df[f.count, "Fit"] <<- as.integer(f.count)
    f.df[f.count, c("Dataset", "Model")] <<- c(ftmp$ds.index, ftmp$mkinmod$name)
  }
}
# Initialise meta data objects {{{1
update_ds.df()
update_m.df()
update_f.df()
# Widgets and handlers for project data {{{1
prg <- gexpandgroup("Project file management", cont = left, horizontal = FALSE)
# Project data management handler functions {{{2
upload_file_handler <- function(h, ...)
{
  # General
  tmpfile <- normalizePath(svalue(h$obj), winslash = "/")
  project_file <<- pr.gf$filename
  project_name <<- try(load(tmpfile))
  if (inherits(project_name, "try-error")) {
    galert(paste("Failed to load", project_file), parent = w)
  } 

  svalue(sb) <- paste("Loaded project file", project_file)
  svalue(pr.ge) <- project_name
  workspace <- get(project_name)

  # Studies
  studies.gdf[,] <- studies.df <- workspace$studies.df

  # Datasets
  ds.cur <<- workspace$ds.cur
  ds <<- workspace$ds
  update_ds.df()
  ds.gtable[,] <- ds.df
  update_ds_editor()

  # Models
  m.cur <<- workspace$m.cur
  m <<- workspace$m
  update_m.df()
  m.gtable[,] <- m.df
  update_m_editor()

  # Fits
  f.cur <<- workspace$f.cur
  f <<- workspace$f
  s <<- workspace$s
  if (length(f) > 0) {
    update_f.df()
    ftmp <<- f[[f.cur]]
    stmp <<- s[[f.cur]]
    ds.i <<- ds.cur
    delete(f.gg.plotopts, f.gg.po.obssel)
    f.gg.po.obssel <<- gcheckboxgroup(names(ftmp$mkinmod$spec), cont = f.gg.plotopts, 
                                     checked = TRUE)
    update_plotting_and_fitting()
  } else {
    f.df <<- f.df.empty
    update_ds_editor()
    svalue(center) <- 1
  }
  f.gtable[,] <- f.df
}
save_to_file_handler <- function(h, ...)
{
  studies.df <- data.frame(studies.gdf[,], stringsAsFactors = FALSE)
  workspace <- list(
                    studies.df = studies.df,

                    ds = ds,
                    ds.cur = ds.cur,

                    m = m,
                    m.cur = m.cur,

                    f = f,
                    f.cur = f.cur,

                    s = s)
  assign(project_name, workspace)
  save(list = project_name, file = project_file)
  svalue(sb) <- paste("Saved project contents to", project_file, "in working directory", getwd())
}
change_project_name_handler = function(h, ...) {
  project_name <<- as.character(svalue(h$obj))
  project_file <<- paste0(project_name, ".RData")
}
# Project data management GUI elements {{{2
pr.gf <- gfile(text = "Select project file", cont = prg,
               handler = upload_file_handler)
pr.ge <- gedit(project_name, cont = prg, label = "Project",
               handler = change_project_name_handler)
# The save button is always visible {{{2
gbutton("Save current project contents", cont = left,
        handler = save_to_file_handler)

# Widget and handler for Studies {{{1
stg <- gexpandgroup("Studies", cont = left)
visible(stg) <- FALSE
update_study_selector <- function(h, ...) {
  delete(ds.e.1, ds.study.gc)
  ds.study.gc <<- gcombobox(paste("Study", studies.gdf[,1]), cont = ds.e.1) 
  svalue(ds.study.gc, index = TRUE) <- ds[[ds.cur]]$study_nr
}
studies.gdf <- gdf(studies.df, name = "Edit studies in the project",
                   width = 235,
                   height = 180, cont = stg)
studies.gdf$set_column_width(1, 40)
addHandlerChanged(studies.gdf, update_study_selector)
# Widgets and handlers for datasets and models {{{1
dsm <- gframe("Datasets and models", cont = left, horizontal = FALSE)
# Widget for dataset table with handler {{{2
ds.switcher <- function(h, ...) {
  ds.cur <<- as.character(svalue(h$obj))
  update_ds_editor()
  svalue(center) <- 1
}
ds.gtable <- gtable(ds.df, cont = dsm)
addHandlerDoubleClick(ds.gtable, ds.switcher)
size(ds.gtable) <- list(columnWidths = c(40, 150, 30))
ds.gtable$value <- 1

# Model table with handler {{{2
m.switcher <- function(h, ...) {
  m.cur <<- as.character(svalue(h$obj))
  update_m_editor()
  svalue(center) <- 2
}
m.gtable <- gtable(m.df, cont = dsm)
addHandlerDoubleClick(m.gtable, m.switcher)
m.gtable$set_column_width(1, 40)
m.gtable$value <- 1

# Button for setting up a fit for the selected dataset and model {{{2
configure_fit_handler = function(h, ...) {
          ds.i <<- as.character(svalue(ds.gtable))
          m.i <<- as.character(svalue(m.gtable))
          ftmp <<- suppressWarnings(mkinfit(m[[m.i]],
                                            override(ds[[ds.i]]$data),
                                            err = "err", 
                                            control.modFit = list(maxiter = 0)))
          ftmp$ds.index <<- ds.i
          ftmp$ds <<- ds[[ds.i]]
          stmp <<- summary(ftmp)
          svalue(pf) <- paste0("Dataset ", ds.i, ", Model ", m[[m.i]]$name)
          svalue(f.gg.opts.st) <<- ftmp$solution_type
          svalue(f.gg.opts.weight) <<- ftmp$weight
          svalue(f.gg.opts.atol) <<- ftmp$atol
          svalue(f.gg.opts.rtol) <<- ftmp$rtol
          svalue(f.gg.opts.transform_rates) <<- ftmp$transform_rates
          svalue(f.gg.opts.transform_fractions) <<- ftmp$transform_fractions
          svalue(f.gg.opts.reweight.method) <<- ifelse(
                                         is.null(ftmp$reweight.method),
                                         "none", ftmp$reweight.method)
          svalue(f.gg.opts.reweight.tol) <<- ftmp$reweight.tol
          svalue(f.gg.opts.reweight.max.iter) <<- ftmp$reweight.max.iter
          svalue(f.gg.opts.method.modFit) <<- ftmp$method.modFit
          svalue(f.gg.opts.maxit.modFit) <<- ftmp$maxit.modFit
          f.gg.parms[,] <- get_Parameters(stmp, FALSE)
          delete(f.gg.plotopts, f.gg.po.obssel)
          f.gg.po.obssel <<- gcheckboxgroup(names(ftmp$mkinmod$spec), cont = f.gg.plotopts, 
                                           checked = TRUE)
          show_plot("Initial", default = TRUE)
          oldwidth <<- options()$width
          options(width = 90)
          svalue(f.gg.summary) <- c("<pre>", capture.output(stmp), "</pre>")
          options(width = oldwidth)
          svalue(center) <- 3
}
gbutton("Configure fit for selected model and dataset", cont = dsm, 
        handler = configure_fit_handler)

# Widget and handler for fits {{{1
f.gf <- gframe("Fits", cont = left, horizontal = FALSE)
f.switcher <- function(h, ...) {
  if (svalue(h$obj) != "0") {
    f.cur <<- svalue(h$obj)
    ftmp <<- f[[f.cur]]
    stmp <<- s[[f.cur]]
    ds.i <<- ftmp$ds.index
    update_plotting_and_fitting()
  }
  svalue(center) <- 3
}
f.gtable <- gtable(f.df, cont = f.gf)
addHandlerDoubleClick(f.gtable, f.switcher)
f.gtable$set_column_width(1, 40)
f.gtable$set_column_width(2, 60)

# Dataset editor {{{1
ds.editor <- gframe("Dataset 1", horizontal = FALSE, cont = center, 
                    label = "Dataset editor")
# Handler functions {{{2
ds.empty <- list(
                 study_nr = 1,
                 title = "",
                 sampling_times = c(0, 1),
                 time_unit = "",
                 observed = "parent",
                 unit = "",
                 replicates = 1,
                 data = data.frame(
                                   name = "parent",
                                   time = c(0, 1),
                                   value = c(100, NA),
                                   override = "NA",
                                   err = 1,
                                   stringsAsFactors = FALSE))

copy_dataset_handler <- function(h, ...) {
  ds.old <- ds.cur
  ds.cur <<- as.character(1 + length(ds))
  svalue(ds.editor) <- paste("Dataset", ds.cur)
  ds[[ds.cur]] <<- ds[[ds.old]]
  update_ds.df()
  ds.gtable[,] <- ds.df
}
 
delete_dataset_handler <- function(h, ...) {
  ds[[ds.cur]] <<- NULL
  names(ds) <<- as.character(1:length(ds))
  ds.cur <<- names(ds)[[1]]
  update_ds.df()
  ds.gtable[,] <- ds.df
  update_ds_editor()
}
 
new_dataset_handler <- function(h, ...) {
  ds.cur <<- as.character(1 + length(ds))
  ds[[ds.cur]] <<- ds.empty
  update_ds.df()
  ds.gtable[,] <- ds.df
  update_ds_editor()
}

tmptextheader <- character(0)
load_text_file_with_data <- function(h, ...) {
  tmptextfile <<- normalizePath(svalue(h$obj), winslash = "/")
  tmptext <- readLines(tmptextfile, warn = FALSE)
  tmptextskip <<- 0
  for (tmptextline in tmptext) {
    if (grepl(":|#|/", tmptextline)) tmptextskip <<- tmptextskip + 1
    else break()
  }
  svalue(ds.e.up.skip) <- tmptextskip
  if (svalue(ds.e.up.header)) {
    tmptextheader <<- strsplit(tmptext[tmptextskip + 1], 
                             " |\t|;|,")[[1]]
  }
  svalue(ds.e.up.wide.time) <- tmptextheader[[1]]
  svalue(ds.e.up.long.time) <- tmptextheader[[2]]
  svalue(ds.e.up.text) <- c("<pre>", tmptext, "</pre>")
  svalue(ds.e.stack) <- 2
}
 
new_ds_from_csv_handler <- function(h, ...) {
   tmpd <- try(read.table(tmptextfile,
                          skip = as.numeric(svalue(ds.e.up.skip)), 
                          dec = svalue(ds.e.up.dec),
                          sep = switch(svalue(ds.e.up.sep), 
                                       whitespace = "", 
                                       ";" = ";",
                                       "," = ","),
                          header = svalue(ds.e.up.header),
                          stringsAsFactors = FALSE))
  if(svalue(ds.e.up.widelong) == "wide") {
    tmpdl <- mkin_wide_to_long(tmpd, time = as.character(svalue(ds.e.up.wide.time)))
  } else {
    tmpdl <- data.frame(
      name = tmpd[[svalue(ds.e.up.long.name)]],
      time = tmpd[[svalue(ds.e.up.long.time)]],
      value = tmpd[[svalue(ds.e.up.long.value)]])
    tmpderr <- tmpd[[svalue(ds.e.up.long.err)]]
    if (!is.null(tmpderr)) tmpdl$err <- tmpderr
  }
  if (class(tmpd) != "try-error") {
    ds.cur <<- as.character(1 + length(ds))
    ds[[ds.cur]] <<- list(
                          study_nr = NA,
                          title = "New import",
                          sampling_times = sort(unique(tmpdl$time)),
                          time_unit = "",
                          observed = unique(tmpdl$name),
                          unit = "",
                          replicates = max(aggregate(tmpdl$time,
                                                       list(tmpdl$time,
                                                            tmpdl$name),
                                                     length)$x),
                          data = tmpdl)
    ds[[ds.cur]]$data$override <<- as.numeric(NA)
    if (is.null(ds[[ds.cur]]$data$err)) ds[[ds.cur]]$data$err <<- 1
    update_ds.df()
    ds.gtable[,] <- ds.df
    update_ds_editor()
  } else {
    galert("Uploading failed", parent = "w")
  }
}
 
empty_grid_handler <- function(h, ...) {
  obs <- strsplit(svalue(ds.e.obs), ", ")[[1]]
  sampling_times <- strsplit(svalue(ds.e.st), ", ")[[1]]
  replicates <- as.numeric(svalue(ds.e.rep))
  new.data = data.frame(
    name = rep(obs, each = replicates * length(sampling_times)),
    time = as.numeric(rep(sampling_times, each = replicates, times = length(obs))),
    value = as.numeric(NA),
    override = as.numeric(NA),
    err = 1,
    stringsAsFactors = FALSE
  )
  ds.e.gdf[,] <- new.data
}

keep_ds_changes_handler <- function(h, ...) {
  ds[[ds.cur]]$title <<- svalue(ds.title.ge)
  ds[[ds.cur]]$study_nr <<- as.numeric(gsub("Study ", "", svalue(ds.study.gc)))
  update_ds.df()
  ds.gtable[,] <- ds.df
  tmpd <- ds.e.gdf[,]
  ds[[ds.cur]]$data <<- tmpd
  ds[[ds.cur]]$sampling_times <<- sort(unique(tmpd$time))
  ds[[ds.cur]]$time_unit <<- svalue(ds.e.stu)
  ds[[ds.cur]]$observed <<- unique(tmpd$name)
  ds[[ds.cur]]$unit <<- svalue(ds.e.obu)
  ds[[ds.cur]]$replicates <<- max(aggregate(tmpd$time, 
                                            list(tmpd$time, tmpd$name), length)$x)
  update_ds_editor()
  observed.all <<- union(observed.all, ds[[ds.cur]]$observed)
  update_m_editor()
}
 
# Widget setup {{{2
# Line 1 {{{3
ds.e.1 <- ggroup(cont = ds.editor, horizontal = TRUE)
glabel("Title: ", cont = ds.e.1) 
ds.title.ge <- gedit(ds[[ds.cur]]$title, cont = ds.e.1) 
glabel(" from ", cont = ds.e.1) 
ds.study.gc <- gcombobox(paste("Study", studies.gdf[,1]), cont = ds.e.1) 

# Line 2 {{{3
ds.e.2 <- ggroup(cont = ds.editor, horizontal = TRUE)
ds.e.2a <- ggroup(cont = ds.e.2, horizontal = FALSE)
gbutton("Copy dataset", cont = ds.e.2a, handler = copy_dataset_handler)
gbutton("Delete dataset", cont = ds.e.2a, handler = delete_dataset_handler)
gbutton("New dataset", cont = ds.e.2a, handler = new_dataset_handler)

ds.e.2b <- ggroup(cont = ds.e.2)
tmptextfile <- "" # Initialize file name for imported data
tmptextskip <- 0 # Initialize number of lines to be skipped
tmptexttime <- "V1" # Initialize name of time variable if no header row
upload_dataset.gf <- gfile(text = "Upload text file", cont = ds.e.2b,
        handler = load_text_file_with_data)

gbutton("Keep changes", cont = ds.e.2, handler = keep_ds_changes_handler)

# Line 3 with forms or upload area {{{3
ds.e.stack <- gstackwidget(cont = ds.editor)
# Forms for meta data {{{4
ds.e.forms <- ggroup(cont = ds.e.stack, horizontal = TRUE)

ds.e.3a <- gvbox(cont = ds.e.forms)
ds.e.3a.gfl <- gformlayout(cont = ds.e.3a)
ds.e.st  <- gedit(paste(ds[[ds.cur]]$sampling_times, collapse = ", "),
                  width = 40,
                  label = "Sampling times", 
                  cont = ds.e.3a.gfl)
ds.e.stu <- gedit(ds[[ds.cur]]$time_unit, 
                  width = 20,
                  label = "Unit", cont = ds.e.3a.gfl)
ds.e.rep <- gedit(ds[[ds.cur]]$replicates, 
                  width = 20,
                  label = "Replicates", cont = ds.e.3a.gfl)

ds.e.3b <- gvbox(cont = ds.e.forms)
ds.e.3b.gfl <- gformlayout(cont = ds.e.3b)
ds.e.obs <- gedit(paste(ds[[ds.cur]]$observed, collapse = ", "),
                  width = 50,
                  label = "Observed", cont = ds.e.3b.gfl)
ds.e.obu <- gedit(ds[[ds.cur]]$unit,
                  width = 20, label = "Unit", 
                  cont = ds.e.3b.gfl)
generate_grid.gb <- gbutton("Generate empty grid for kinetic data", cont = ds.e.3b, 
        handler = empty_grid_handler)
tooltip(generate_grid.gb) <- "Overwrites the kinetic data shown below"
# Data upload area {{{4
ds.e.upload <- ggroup(cont = ds.e.stack, horizontal = TRUE)
ds.e.up.text <- ghtml("<pre></pre>", cont = ds.e.upload, width = 400, height = 400)
ds.e.up.options <- ggroup(cont = ds.e.upload, horizontal = FALSE)
ds.e.up.import <- gbutton("Import using options specified below", cont = ds.e.up.options,
                          handler = new_ds_from_csv_handler)
ds.e.up.skip <- gedit(tmptextskip, label = "Comment lines", cont = ds.e.up.options)
ds.e.up.header <- gcheckbox(cont = ds.e.up.options, label = "Column names", 
                            checked = TRUE)
ds.e.up.sep <- gcombobox(c("whitespace", ";", ","), cont = ds.e.up.options,
                         selected = 1, label = "Separator")
ds.e.up.dec <- gcombobox(c(".", ","), cont = ds.e.up.options,
                         selected = 1, label = "Decimal")
ds.e.up.widelong <- gradio(c("wide", "long"), horizontal = TRUE, 
                           label = "Format", cont = ds.e.up.options,
                           handler = function(h, ...) {
                             widelong = svalue(h$obj, index = TRUE)
                             svalue(ds.e.up.wlstack) <- widelong
                           })
ds.e.up.wlstack <- gstackwidget(cont = ds.e.up.options)
ds.e.up.wide <- ggroup(cont = ds.e.up.wlstack, horizontal = FALSE, width = 300)
ds.e.up.wide.time <- gedit(tmptexttime, cont = ds.e.up.wide, label = "Time column")
ds.e.up.long <- ggroup(cont = ds.e.up.wlstack, horizontal = FALSE, width = 300)
ds.e.up.long.name <- gedit("name", cont = ds.e.up.long, label = "Observed variables")
ds.e.up.long.time <- gedit(tmptexttime, cont = ds.e.up.long, label = "Time column")
ds.e.up.long.value <- gedit("value", cont = ds.e.up.long, label = "Value column")
ds.e.up.long.err <- gedit("err", cont = ds.e.up.long, label = "Relative errors")
svalue(ds.e.up.wlstack) <- 1

svalue(ds.e.stack) <- 1

# Kinetic Data {{{3
ds.e.gdf <- gdf(ds[[ds.cur]]$data, name = "Kinetic data", 
                width = 500, height = 700, cont = ds.editor)
ds.e.gdf$set_column_width(2, 70)

# Update the dataset editor {{{3
update_ds_editor <- function() {
  svalue(ds.editor) <- paste("Dataset", ds.cur)
  svalue(ds.title.ge) <- ds[[ds.cur]]$title
  svalue(ds.study.gc, index = TRUE) <- ds[[ds.cur]]$study_nr

  svalue(ds.e.st) <- paste(ds[[ds.cur]]$sampling_times, collapse = ", ")
  svalue(ds.e.stu) <- ds[[ds.cur]]$time_unit
  svalue(ds.e.obs) <- paste(ds[[ds.cur]]$observed, collapse = ", ")
  svalue(ds.e.obu) <- ds[[ds.cur]]$unit
  svalue(ds.e.rep) <- ds[[ds.cur]]$replicates
  svalue(ds.e.stack) <- 1
  ds.e.gdf[,] <- ds[[ds.cur]]$data
}
# Model editor {{{1
m.editor <- gframe("Model 1", horizontal = FALSE, cont = center, label = "Model editor")
# Handler functions {{{3
copy_model_handler <- function(h, ...) {
  m.old <- m.cur
  m.cur <<- as.character(1 + length(m))
  svalue(m.editor) <- paste("Model", m.cur)
  m[[m.cur]] <<- m[[m.old]]
  update_m.df()
  m.gtable[,] <- m.df
}
 
delete_model_handler <- function(h, ...) {
  m[[m.cur]] <<- NULL
  names(m) <<- as.character(1:length(m))
  m.cur <<- "1"
  update_m.df()
  m.gtable[,] <- m.df
  update_m_editor()
}

add_observed_handler <- function(h, ...) {
  obs.i <- length(m.e.rows) + 1
  m.e.rows[[obs.i]] <<- ggroup(cont = m.editor, horizontal = TRUE)
  m.e.obs[[obs.i]] <<- gcombobox(observed.all, selected = obs.i, 
                                cont = m.e.rows[[obs.i]])
  m.e.type[[obs.i]] <<- gcombobox(c("SFO", "FOMC", "DFOP", "HS", "SFORB"),
                                 cont = m.e.rows[[obs.i]])
  svalue(m.e.type[[obs.i]]) <- "SFO"
  glabel("to", cont = m.e.rows[[obs.i]]) 
  m.e.to[[obs.i]] <<- gedit("", width = 40, cont = m.e.rows[[obs.i]])
  m.e.sink[[obs.i]] <<- gcheckbox("Path to sink", 
                                  checked = TRUE, cont = m.e.rows[[obs.i]]) 
  gbutton("Remove compound", handler = remove_compound_handler, 
          action = obs.i, cont = m.e.rows[[obs.i]])
}

remove_compound_handler <- function(h, ...) {
  m[[m.cur]]$spec[[h$action]] <<- NULL
  update_m_editor()
}

keep_m_changes_handler <- function(h, ...) {
  spec <- list()
  for (obs.i in 1:length(m.e.rows)) {
    to_vector = strsplit(svalue(m.e.to[[obs.i]]), ", ")[[1]]
    if (length(to_vector) == 0) to_vector = ""
    spec[[obs.i]] <- list(type = svalue(m.e.type[[obs.i]]),
                          to = to_vector,
                          sink = svalue(m.e.sink[[obs.i]]))
    if(spec[[obs.i]]$to == "") spec[[obs.i]]$to = NULL
    names(spec)[[obs.i]] <- svalue(m.e.obs[[obs.i]])
  }
  m[[m.cur]] <<- mkinmod(use_of_ff = svalue(m.ff.gc), 
                         speclist = spec)
  m[[m.cur]]$name <<- svalue(m.name.ge) 
  update_m.df()
  m.gtable[,] <- m.df
}
 
# Widget setup {{{3
m.e.0 <- ggroup(cont = m.editor, horizontal = TRUE)
glabel("Model name: ", cont = m.e.0) 
m.name.ge <- gedit(m[[m.cur]]$name, cont = m.e.0) 
glabel("Use of formation fractions: ", cont = m.e.0) 
m.ff.gc <- gcombobox(c("min", "max"), cont = m.e.0)
svalue(m.ff.gc) <- m[[m.cur]]$use_of_ff

# Model handling buttons {{{4
m.e.b <- ggroup(cont = m.editor, horizontal = TRUE)
gbutton("Copy model", cont = m.e.b, handler = copy_model_handler)
gbutton("Delete model", cont = m.e.b, handler = delete_model_handler)
gbutton("Add transformation product", cont = m.e.b, 
        handler = add_observed_handler)
gbutton("Keep changes", cont = m.e.b, handler = keep_m_changes_handler)


m.observed <- names(m[[m.cur]]$spec)
m.e.rows <- m.e.obs <- m.e.type <- m.e.to <- m.e.sink <- list()
obs.to <- ""

# Show the model specification {{{4
show_m_spec <- function() {
  for (obs.i in 1:length(m[[m.cur]]$spec)) {
    obs.name <- names(m[[m.cur]]$spec)[[obs.i]]
    m.e.rows[[obs.i]] <<- ggroup(cont = m.editor, horizontal = TRUE)
    m.e.obs[[obs.i]] <<- gcombobox(observed.all, selected = 0, 
                                  cont = m.e.rows[[obs.i]])
    svalue(m.e.obs[[obs.i]]) <<- obs.name
    m.e.type[[obs.i]] <<- gcombobox(c("SFO", "FOMC", "DFOP", "HS", "SFORB"),
                                   cont = m.e.rows[[obs.i]])
    svalue(m.e.type[[obs.i]]) <<- m[[m.cur]]$spec[[obs.i]]$type
    glabel("to", cont = m.e.rows[[obs.i]]) 
    obs.to <<- ifelse(is.null(m[[m.cur]]$spec[[obs.i]]$to), "",
                 paste(m[[m.cur]]$spec[[obs.i]]$to, collapse = ", "))
    m.e.to[[obs.i]] <<- gedit(obs.to, width = 40, cont = m.e.rows[[obs.i]])
    m.e.sink[[obs.i]] <<- gcheckbox("Path to sink", checked = m[[m.cur]]$spec[[obs.i]]$sink,
              cont = m.e.rows[[obs.i]]) 
    if (obs.i > 1) {
      gbutton("Remove compound", handler = remove_compound_handler, 
              action = obs.i, cont = m.e.rows[[obs.i]])
    }
  }
}
show_m_spec()

# Update the model editor {{{3
update_m_editor <- function() {
  svalue(m.editor) <- paste("Model", m.cur)
  svalue(m.name.ge) <- m[[m.cur]]$name
  svalue(m.ff.gc) <- m[[m.cur]]$use_of_ff
  for (oldrow.i in 1:length(m.e.rows)) {
    delete(m.editor, m.e.rows[[oldrow.i]])
  }
  m.observed <<- names(m[[m.cur]]$spec)
  m.e.rows <<- m.e.obs <<- m.e.type <<- m.e.to <<- m.e.sink <<- list()
  show_m_spec()
}

# 3}}}
# 2}}}
# Plotting and fitting {{{1
show_plot <- function(type, default = FALSE) {
  Parameters <- f.gg.parms[,]
  Parameters.de <- subset(Parameters, Type == "deparm", type)
  stateparms <- subset(Parameters, Type == "state")[[type]]
  deparms <- as.numeric(Parameters.de[[type]])
  names(deparms) <- rownames(Parameters.de)
  if (type == "Initial" & default == FALSE) {
    ftmp <<- suppressWarnings(mkinfit(ftmp$mkinmod, 
                                      override(ds[[ds.i]]$data),
                                      parms.ini = deparms,
                                      state.ini = stateparms, 
                                      fixed_parms = names(deparms),
                                      fixed_initials = names(stateparms),
                                      err = "err", 
                                      control.modFit = list(maxiter = 0)))
    ftmp$ds.index <<- ds.i
    ftmp$ds <<- ds[[ds.i]]
  } 
  svalue(plot.ftmp.gi) <<- plot_ftmp_png()
  svalue(plot.confint.gi) <<- plot_confint_png()
}
get_Parameters <- function(stmp, optimised)
{
  pars <- rbind(stmp$start[1:2], stmp$fixed)

  pars$fixed <- c(rep(FALSE, length(stmp$start$value)),
                  rep(TRUE, length(stmp$fixed$value)))
  pars$name <- rownames(pars)
  Parameters <- data.frame(Name = pars$name,
                           Type = pars$type,
                           Initial = pars$value,
                           Fixed = pars$fixed,
                           Optimised = as.numeric(NA))
  Parameters <- rbind(subset(Parameters, Type == "state"),
                      subset(Parameters, Type == "deparm"))
  rownames(Parameters) <- Parameters$Name
  if (optimised) {
    Parameters[rownames(stmp$bpar), "Optimised"] <- stmp$bpar[, "Estimate"]
  }
  return(Parameters)
}
run_fit <- function() {
  Parameters <- f.gg.parms[,]
  Parameters.de <- subset(Parameters, Type == "deparm")
  deparms <- Parameters.de$Initial
  names(deparms) <- Parameters.de$Name
  defixed <- names(deparms[Parameters.de$Fixed])
  Parameters.ini <- subset(Parameters, Type == "state")
  iniparms <- Parameters.ini$Initial
  names(iniparms) <- sub("_0", "", Parameters.ini$Name)
  inifixed <- names(iniparms[Parameters.ini$Fixed])
  weight <- svalue(f.gg.opts.weight)
  if (weight == "manual") {
    err = "err"
  } else {
    err = NULL
  }
  reweight.method <- svalue(f.gg.opts.reweight.method)
  if (reweight.method == "none") reweight.method = NULL
  ftmp <<- mkinfit(ftmp$mkinmod, override(ds[[ds.i]]$data),
                   state.ini = iniparms,
                   fixed_initials = inifixed,
                   parms.ini = deparms, 
                   fixed_parms = defixed,
                   solution_type = svalue(f.gg.opts.st),
                   atol = as.numeric(svalue(f.gg.opts.atol)),
                   rtol = as.numeric(svalue(f.gg.opts.rtol)),
                   transform_rates = svalue(f.gg.opts.transform_rates),
                   transform_fractions = svalue(f.gg.opts.transform_fractions),
                   weight = weight,
                   err = err,
                   reweight.method = reweight.method,
                   reweight.tol = as.numeric(svalue(f.gg.opts.reweight.tol)),
                   reweight.max.iter = as.numeric(svalue(f.gg.opts.reweight.max.iter)),
                   method.modFit = svalue(f.gg.opts.method.modFit),
                   maxit.modFit = svalue(f.gg.opts.maxit.modFit)
                   )
  ftmp$ds.index <<- ds.i
  ftmp$ds <<- ds[[ds.i]]
  stmp <<- summary(ftmp)
  show_plot("Optimised")
  svalue(f.gg.opts.st) <- ftmp$solution_type
  svalue(f.gg.opts.weight) <- ftmp$weight.ini
  f.gg.parms[,] <- get_Parameters(stmp, TRUE)
  svalue(f.gg.summary) <- c("<pre>", capture.output(stmp), "</pre>")
}
ds.i <- m.i <- "1"
f.cur <- "0"

# GUI widgets {{{2
pf <- gframe("Dataset 1, Model SFO", horizontal = TRUE, 
             cont = center, label = "Plotting and fitting")

# Plot area to the left {{{3
pf.p <- ggroup(cont = pf, horizontal = FALSE)
ftmp <- suppressWarnings(mkinfit(m[[m.cur]], override(ds[[ds.i]]$data), 
                                 err = "err", 
                                 control.modFit = list(maxiter = 0)))
ftmp$ds.index = ds.i
ftmp$ds = ds[[ds.i]]
stmp <- summary(ftmp)
Parameters <- get_Parameters(stmp, FALSE)

plot_ftmp_png <- function() {
  tf <- get_tempfile(ext=".png")
  if(exists("f.gg.po.obssel")) {
    obs_vars_plot = svalue(f.gg.po.obssel)
  } else {
    obs_vars_plot = names(ftmp$mkinmod$spec)
  }
  png(tf, width = 400, height = 400)
  plot(ftmp, main = ftmp$ds$title, obs_vars = obs_vars_plot,
       xlab = ifelse(ftmp$ds$time_unit == "", "Time", 
                     paste("Time in", ftmp$ds$time_unit)),
       ylab = ifelse(ds[[ds.i]]$unit == "", "Observed", 
                     paste("Observed in", ftmp$ds$unit)),
       show_residuals = TRUE)
  dev.off()
  return(tf)
}

plot_confint_png <- function() {
  tf <- get_tempfile(ext=".png")
  png(tf, width = 400, height = 400)
  mkinparplot(ftmp) 
  dev.off()
  return(tf)
}

plot.ftmp.gi <- gimage(plot_ftmp_png(), container = pf.p, width = 400, height = 400)
plot.confint.gi <- gimage(plot_confint_png(), container = pf.p, width = 400, height = 400)

# Buttons and notebook area to the right {{{3
p.gg <- ggroup(cont = pf, horizontal = FALSE)
# Row with buttons {{{4
f.gg.buttons <- ggroup(cont = p.gg)
run.fit.gb <- gbutton("Run", width = 100,
                      handler = function(h, ...) run_fit(), cont =
                      f.gg.buttons)
tooltip(run.fit.gb) <- "Fit with current settings on the current dataset, with the original model"

keep.fit.gb <- gbutton("Keep fit", 
                       handler = function(h, ...) {
                            f.cur <<- as.character(length(f) + 1)
                            f[[f.cur]] <<- ftmp
                            s[[f.cur]] <<- stmp
                            update_f.df()
                            f.gtable[,] <<- f.df
                            delete(f.gg.plotopts, f.gg.po.obssel)
                            f.gg.po.obssel <<- gcheckboxgroup(names(ftmp$mkinmod$spec), 
                                                              cont = f.gg.plotopts, 
                                                              checked = TRUE)
                            delete(f.gg.buttons, get.initials.gc)
                            get.initials.gc <<- gcombobox(paste("Fit", f.df$Fit), 
                                                          cont = f.gg.buttons)
                          }, cont = f.gg.buttons)
tooltip(keep.fit.gb) <- "Store the optimised model with all settings and the current dataset in the fit list"

delete.fit.gb <- gbutton("Delete fit", handler = function(h, ...) {
          if (length(f) > 0) {
            f[[f.cur]] <<- NULL
            s[[f.cur]] <<- NULL
          }
          if (length(f) > 0) {
            names(f) <<- as.character(1:length(f))
            names(s) <<- as.character(1:length(f))
            update_f.df()
            f.cur <<- "1"
            ftmp <<- f[[f.cur]]
            stmp <<- s[[f.cur]]
            ds.i <<- ftmp$ds.index
            update_plotting_and_fitting()
          } else {
            f.df <<- f.df.empty
            f.cur <<- "0"
          }
          f.gtable[,] <<- f.df
        }, cont = f.gg.buttons)
tooltip(delete.fit.gb) <- "Delete the currently loaded fit from the fit list"

show.initial.gb <- gbutton("Show initial", 
                           handler = function(h, ...) show_plot("Initial"),
                           cont = f.gg.buttons)
tooltip(show.initial.gb) <- "Show model with current inital settings for current dataset"

get_initials_handler <- function(h, ...)
{
  f.i <- svalue(get.initials.gc, index = TRUE)
  if (length(f) > 0) {
    got_initials <- c(f[[f.i]]$bparms.fixed, f[[f.i]]$bparms.optim)
    parnames <- f.gg.parms[,"Name"]
    newparnames <- names(got_initials)
    commonparnames <- intersect(parnames, newparnames)
    f.gg.parms[commonparnames, "Initial"] <<- got_initials[commonparnames]
  }
}
get.initials.gb <- gbutton("Get initials from", cont = f.gg.buttons,
                           handler = get_initials_handler)
get.initials.gc <- gcombobox(paste("Fit", f.df$Fit), cont = f.gg.buttons)

# Notebook to the right {{{3
f.gn <- gnotebook(cont = p.gg, width = 680, height = 790)
# Dataframe with initial and optimised parameters {{{4
f.gg.parms <- gdf(Parameters, cont = f.gn, 
                 width = 670, height = 750,
                 do_add_remove_buttons = FALSE, label = "Parameters")
f.gg.parms$set_column_width(1, 200)
f.gg.parms$set_column_width(2, 50)
f.gg.parms$set_column_width(3, 60)
f.gg.parms$set_column_width(4, 50)
f.gg.parms$set_column_width(5, 60)

# Fit options form {{{4
f.gg.opts <- gformlayout(cont = f.gn, label = "Fit options")
solution_types <- c("auto", "analytical", "eigen", "deSolve")
f.gg.opts.st <- gcombobox(solution_types, selected = 1,
                          label = "solution_type", width = 200,
                          cont = f.gg.opts)
f.gg.opts.atol <- gedit(ftmp$atol, label = "atol", width = 20,
                         cont = f.gg.opts)
f.gg.opts.rtol <- gedit(ftmp$rtol, label = "rtol", width = 20,
                         cont = f.gg.opts)
f.gg.opts.transform_rates <- gcheckbox("transform_rates",
                         cont = f.gg.opts, checked = TRUE)
f.gg.opts.transform_fractions <- gcheckbox("transform_fractions",
                         cont = f.gg.opts, checked = TRUE)
weights <- c("manual", "none", "std", "mean")
f.gg.opts.weight <- gcombobox(weights, selected = 1, label = "weight",
                              width = 200, cont = f.gg.opts)
f.gg.opts.reweight.method <- gcombobox(c("none", "obs"), selected = 1,
                                       label = "reweight.method",
                                       width = 200,
                                       cont = f.gg.opts)
f.gg.opts.reweight.tol <- gedit(1e-8, label = "reweight.tol",
                                 width = 20, cont = f.gg.opts)
f.gg.opts.reweight.max.iter <- gedit(10, label = "reweight.max.iter",
                                 width = 20, cont = f.gg.opts)
optimisation_methods <- c("Marq", "Port", "SANN")
f.gg.opts.method.modFit <- gcombobox(optimisation_methods, selected = 1,
                                     label = "method.modFit",
                                     width = 200,
                                     cont = f.gg.opts)
f.gg.opts.maxit.modFit <- gedit("auto", label = "maxit.modFit",
                                 width = 20, cont = f.gg.opts)

# Summary {{{3
oldwidth <- options()$width
options(width = 90)
f.gg.summary <- ghtml(c("<pre>", capture.output(stmp), "</pre>"),
                        cont = f.gn, label = "Summary")
options(width = oldwidth)

# Plot options {{{4
f.gg.plotopts <- ggroup(cont = f.gn, label = "Plot options", horizontal = FALSE)
f.gg.po.update <- gbutton("Update plot", 
                          handler = function(h, ...) show_plot("Optimised"), 
                          cont = f.gg.plotopts)
f.gg.po.obssel <- gcheckboxgroup(names(m[[m.cur]]$spec), cont = f.gg.plotopts, 
                                 checked = TRUE)
svalue(f.gn) <- 1

# Update the plotting and fitting area {{{3
update_plotting_and_fitting <- function() {
  svalue(pf) <- paste0("Fit ", f.cur, ": Dataset ", ftmp$ds.index, 
                       ", Model ", ftmp$mkinmod$name)
  # Parameters
  f.gg.parms[,] <- get_Parameters(stmp, TRUE)

  # Fit options
  delete(f.gg.buttons, get.initials.gc)
  get.initials.gc <<- gcombobox(paste("Fit", f.df$Fit), cont = f.gg.buttons)

  svalue(f.gg.opts.st) <- ftmp$solution_type
  svalue(f.gg.opts.atol) <- ftmp$atol
  svalue(f.gg.opts.rtol) <- ftmp$rtol
  svalue(f.gg.opts.transform_rates) <- ftmp$transform_rates
  svalue(f.gg.opts.transform_fractions) <- ftmp$transform_fractions
  svalue(f.gg.opts.weight) <- ftmp$weight.ini
  svalue(f.gg.opts.reweight.method) <- ifelse(is.null(ftmp$reweight.method),
                                                      "none", 
                                                      ftmp$reweight.method)
  svalue(f.gg.opts.reweight.tol) <- ftmp$reweight.tol
  svalue(f.gg.opts.reweight.max.iter) <- ftmp$reweight.max.iter
  svalue(f.gg.opts.method.modFit) <- ftmp$method.modFit
  svalue(f.gg.opts.maxit.modFit) <- ftmp$maxit.modFit

  # Summary
  oldwidth <<- options()$width
  options(width = 90)
  svalue(f.gg.summary) <- c("<pre>", capture.output(stmp), "</pre>")
  options(width = oldwidth)

  # Plot options
  delete(f.gg.plotopts, f.gg.po.obssel)
  f.gg.po.obssel <<- gcheckboxgroup(names(ftmp$mkinmod$spec), cont = f.gg.plotopts, 
                                   checked = TRUE)
  # Plot
  show_plot("Optimised")  
 
}
# vim: set foldmethod=marker ts=2 sw=2 expandtab: {{{1