# 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 # 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 = "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, ] <<- c(as.character(f.count), 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 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("
", capture.output(stmp), "
") 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() } 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("
", tmptext, "
") 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("
", 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("", 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, 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))
                   )
  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("
", capture.output(stmp), "
") } 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) # Summary {{{3 oldwidth <- options()$width options(width = 90) f.gg.summary <- ghtml(c("
", capture.output(stmp), "
"), 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 # Summary oldwidth <<- options()$width options(width = 90) svalue(f.gg.summary) <- c("
", capture.output(stmp), "
") 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