From 3746e251e68ea80de61bbef53d9a48eb3f99646b Mon Sep 17 00:00:00 2001
From: Johannes Ranke <jranke@uni-bremen.de>
Date: Wed, 30 Apr 2014 16:33:51 +0200
Subject: Overhaul of gmkin - should be useful now

- Improve widget layout
  + Size of widgets in left pane
  + Enable scrolling in left pane
  + Smaller plot
  + Control width of summary text file
- Upload of data with flexible format
- Parameter transformation is now optional
- Get initial values from selected previous fit
- Fix initial plots for the case of zero parameter values
---
 inst/GUI/gmkin.R | 220 ++++++++++++++++++++++++++++++++++++++++---------------
 1 file changed, 161 insertions(+), 59 deletions(-)

(limited to 'inst')

diff --git a/inst/GUI/gmkin.R b/inst/GUI/gmkin.R
index 4d33b35a..7588183b 100644
--- a/inst/GUI/gmkin.R
+++ b/inst/GUI/gmkin.R
@@ -23,9 +23,9 @@ require(mkin) # {{{1
 # 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, FME, deSolve and minpack.lm --- Working directory is", getwd()), cont = w)
-pg     <- gpanedgroup(cont = w, default.size = 300)
+pg     <- gpanedgroup(cont = w, default.size = 260)
 center <- gnotebook(cont = pg)
-left   <- gvbox(cont = pg)
+left   <- gvbox(cont = pg, use.scrollwindow = TRUE)
 # Helper functions {{{1
 # Override function for making it possible to override original data in the GUI {{{2
 override <- function(d) {
@@ -122,6 +122,8 @@ update_f.df <- function() {
     ftmp <- f[[fit.index]]
     f.df[f.count, ] <<- c(as.character(f.count), ftmp$ds.index, ftmp$mkinmod$name)
   }
+  delete(f.gg.buttons, get.initials.gc)
+  get.initials.gc <<- gcombobox(paste("Fit", f.df$Fit), cont = f.gg.buttons)
 }
 f.df.empty <- f.df <- data.frame(Fit = "0", 
                                Dataset = "", 
@@ -137,10 +139,10 @@ upload_file_handler <- function(h, ...)
   project_file <<- pr.gf$filename
   project_name <<- try(load(tmpfile))
   if (inherits(project_name, "try-error")) {
-    galert(paste("Failed to load", project_file, "from", getwd()), parent = w)
+    galert(paste("Failed to load", project_file), parent = w)
   } 
 
-  svalue(sb) <- paste("Loaded project file", project_file, "from working directory", getwd())
+  svalue(sb) <- paste("Loaded project file", project_file)
   svalue(pr.ge) <- project_name
   workspace <- get(project_name)
 
@@ -208,7 +210,7 @@ change_project_name_handler = function(h, ...) {
 # 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", width = 240,
+pr.ge <- gedit(project_name, cont = prg, label = "Project",
                handler = change_project_name_handler)
 # The save button is always visible {{{1
 gbutton("Save current project contents", cont = left,
@@ -223,9 +225,9 @@ update_study_selector <- function(h, ...) {
   svalue(ds.study.gc, index = TRUE) <- ds[[ds.cur]]$study_nr
 }
 studies.gdf <- gdf(studies.df, name = "Edit studies in the project",
-                   width = 290, height = 200, cont = stg)
+                   width = 235,
+                   height = 180, cont = stg)
 studies.gdf$set_column_width(1, 40)
-studies.gdf$set_column_width(2, 240)
 addHandlerChanged(studies.gdf, update_study_selector)
 # Datasets and models {{{1
 dsm <- gframe("Datasets and models", cont = left, horizontal = FALSE)
@@ -235,9 +237,9 @@ ds.switcher <- function(h, ...) {
   update_ds_editor()
   svalue(center) <- 1
 }
-ds.gtable <- gtable(ds.df, width = 290, cont = dsm)
+ds.gtable <- gtable(ds.df, cont = dsm)
 addHandlerDoubleClick(ds.gtable, ds.switcher)
-size(ds.gtable) <- list(columnWidths = c(40, 200, 40))
+size(ds.gtable) <- list(columnWidths = c(40, 150, 30))
 ds.gtable$value <- 1
 
 # Model table with handler {{{2
@@ -246,9 +248,9 @@ m.switcher <- function(h, ...) {
   update_m_editor()
   svalue(center) <- 2
 }
-m.gtable <- gtable(m.df, width = 290, cont = dsm)
+m.gtable <- gtable(m.df, cont = dsm)
 addHandlerDoubleClick(m.gtable, m.switcher)
-size(m.gtable) <- list(columnWidths = c(40, 240))
+m.gtable$set_column_width(1, 40)
 m.gtable$value <- 1
 
 # Button for setting up a fit for the selected dataset and model
@@ -278,7 +280,10 @@ gbutton("Configure fit for selected model and dataset", cont = dsm,
           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
         })
 
@@ -295,13 +300,14 @@ f.switcher <- function(h, ...) {
   }
   svalue(center) <- 3
 }
-f.gtable <- gtable(f.df, width = 290, cont = f.gf)
+f.gtable <- gtable(f.df, cont = f.gf)
 addHandlerDoubleClick(f.gtable, f.switcher)
-size(f.gtable) <- list(columnWidths = c(40, 60, 180))
+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 {{{3
+# # Handler functions {{{3
 copy_dataset_handler <- function(h, ...) {
   ds.old <- ds.cur
   ds.cur <<- as.character(1 + length(ds))
@@ -344,10 +350,40 @@ new_dataset_handler <- function(h, ...) {
   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("<pre>", tmptext, "</pre>")
+  svalue(ds.e.stack) <- 2
+}
+ 
 new_ds_from_csv_handler <- function(h, ...) {
-  tmpfile <- normalizePath(svalue(h$obj), winslash = "/")
-  tmpd <- try(read.table(tmpfile, sep = "\t", header = TRUE, stringsAsFactors = FALSE))
-  tmpdw <- mkin_wide_to_long(tmpd)
+   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 <- tmpd
+  }
   if (class(tmpd) != "try-error") {
     ds.cur <<- as.character(1 + length(ds))
     ds[[ds.cur]] <<- list(
@@ -355,13 +391,13 @@ new_ds_from_csv_handler <- function(h, ...) {
                           title = "New upload",
                           sampling_times = sort(unique(tmpd$t)),
                           time_unit = "",
-                          observed = unique(tmpdw$name),
+                          observed = unique(tmpdl$name),
                           unit = "",
-                          replicates = max(aggregate(tmpdw$time,
-                                                       list(tmpdw$time,
-                                                            tmpdw$name),
+                          replicates = max(aggregate(tmpdl$time,
+                                                       list(tmpdl$time,
+                                                            tmpdl$name),
                                                      length)$x),
-                          data = tmpdw)
+                          data = tmpdl)
     ds[[ds.cur]]$data$override <<- as.numeric(NA)
     ds[[ds.cur]]$data$err <<- 1
     update_ds.df()
@@ -371,7 +407,7 @@ new_ds_from_csv_handler <- function(h, ...) {
     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]]
@@ -402,6 +438,7 @@ keep_ds_changes_handler <- function(h, ...) {
                                             list(tmpd$time, tmpd$name), length)$x)
   update_ds_editor()
   observed.all <<- union(observed.all, ds[[ds.cur]]$observed)
+  update_m_editor()
 }
  
 # Widget setup {{{3
@@ -420,13 +457,18 @@ 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 = new_ds_from_csv_handler)
+        handler = load_text_file_with_data)
 
 gbutton("Keep changes", cont = ds.e.2, handler = keep_ds_changes_handler)
 
-# Line 3 with forms {{{4
-ds.e.forms <- ggroup(cont= ds.editor, horizontal = TRUE)
+# Line 3 with forms or upload area {{{4
+ds.e.stack <- gstackwidget(cont = ds.editor)
+# Forms for meta data {{{5
+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)
@@ -452,6 +494,36 @@ ds.e.obu <- gedit(ds[[ds.cur]]$unit,
 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 {{{5
+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 {{{4
@@ -470,7 +542,7 @@ update_ds_editor <- function() {
   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
@@ -604,8 +676,10 @@ show_plot <- function(type, default = FALSE) {
   if (type == "Initial" & default == FALSE) {
     ftmp <<- suppressWarnings(mkinfit(ftmp$mkinmod, 
                                       override(ds[[ds.i]]$data),
-                                      state.ini = stateparms, 
                                       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
@@ -659,6 +733,8 @@ run_fit <- function() {
                    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,
@@ -697,7 +773,7 @@ plot_ftmp_png <- function() {
   } else {
     obs_vars_plot = names(ftmp$mkinmod$spec)
   }
-  png(tf, width = 525, height = 600)
+  png(tf, width = 400, height = 500)
   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)),
@@ -708,20 +784,17 @@ plot_ftmp_png <- function() {
   return(tf)
 }
 
-plot.gi <- gimage(plot_ftmp_png(), container = pf, width = 525, height = 600)
+plot.gi <- gimage(plot_ftmp_png(), container = pf, width = 400, height = 500)
 
 # Buttons and notebook area to the left {{{3
 p.gg <- ggroup(cont = pf, horizontal = FALSE)
 # Row with buttons {{{4
 f.gg.buttons <- ggroup(cont = p.gg)
-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"
-run.fit.gb <- gbutton("Run", 
+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", 
                        handler = function(h, ...) {
                             f.cur <<- as.character(length(f) + 1)
@@ -732,12 +805,53 @@ keep.fit.gb <- gbutton("Keep",
                           }, 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 = 700, height = 700)
+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 = 690, height = 660,
+                 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)
@@ -755,6 +869,10 @@ 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)
@@ -768,30 +886,11 @@ 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("<pre>", capture.output(stmp), "</pre>"),
                         cont = f.gn, label = "Summary")
-
-delete.fit.gb <- gbutton("Delete", 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"
+options(width = oldwidth)
 
 # Plot options {{{4
 f.gg.plotopts <- ggroup(cont = f.gn, label = "Plot options", horizontal = FALSE)
@@ -818,6 +917,9 @@ update_plotting_and_fitting <- function() {
   delete(f.gg.plotopts, f.gg.po.obssel)
   f.gg.po.obssel <<- gcheckboxgroup(names(m[[m.cur]]$spec), cont = f.gg.plotopts, 
                                    checked = TRUE)
+  oldwidth <<- options()$width
+  options(width = 90)
   svalue(f.gg.summary) <- c("<pre>", capture.output(stmp), "</pre>")
+  options(width = oldwidth)
 }
 # vim: set foldmethod=marker ts=2 sw=2 expandtab: {{{1
-- 
cgit v1.2.1