diff options
Diffstat (limited to 'inst/GUI/gmkin.R')
| -rw-r--r-- | inst/GUI/gmkin.R | 826 |
1 files changed, 826 insertions, 0 deletions
diff --git a/inst/GUI/gmkin.R b/inst/GUI/gmkin.R new file mode 100644 index 0000000..07f892e --- /dev/null +++ b/inst/GUI/gmkin.R @@ -0,0 +1,826 @@ +# $Id: mkinGUI.R 122 2013-10-21 20:19:57Z jranke $ {{{1
+
+# gWidgetsWWW2 GUI for mkin
+
+# Copyright (C) 2013 Johannes Ranke
+# Contact: jranke@uni-bremen.de, johannesranke@eurofins.com
+
+# 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/>
+require(mkin) # {{{1
+# Set the GUI title and create the basic widget layout {{{1
+w <- gwindow("Browser based GUI for kinetic evaluations using mkin")
+sb <- gstatusbar("Powered by gWidgetsWWW2 and Rook", cont = w)
+pg <- gpanedgroup(cont = w, default.size = 300)
+center <- gnotebook(cont = pg)
+left <- gvbox(cont = pg)
+# 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)
+}
+# Set default values for project data {{{1
+# Initial project file name {{{2
+project_file <- "mkin_FOCUS_2006.RData"
+# Initial studies {{{2
+studies.df <- data.frame(Index = as.integer(1),
+ Citation = "FOCUS (2006) Guidance on degradation kinetics",
+ stringsAsFactors = FALSE)
+# Initial datasets {{{2
+ds <- list()
+observed.all <- vector()
+for (i in 1:2) {
+ ds.letter = LETTERS[i + 2]
+ ds.index <- as.character(i)
+ ds.name = paste0("FOCUS_2006_", ds.letter)
+ ds[[ds.index]] <- list(
+ study_nr = 1,
+ title = paste("FOCUS example dataset", ds.letter),
+ sampling_times = unique(get(ds.name)$time),
+ time_unit = "",
+ observed = as.character(unique(get(ds.name)$name)),
+ unit = "% AR",
+ replicates = 1,
+ data = get(ds.name)
+ )
+ ds[[ds.index]]$data$name <- as.character(ds[[ds.index]]$data$name)
+ ds[[ds.index]]$data$override = as.numeric(NA)
+ ds[[ds.index]]$data$err = 1
+}
+# 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)
+ }
+}
+ds.df <- data.frame()
+update_ds.df()
+ds.cur = "1"
+# Initial models {{{2
+m <- list()
+m[["1"]] <- mkinmod(parent = list(type = "SFO"))
+m[["1"]]$name = "SFO"
+m[["2"]] <- mkinmod(parent = list(type = "FOMC"))
+m[["2"]]$name = "FOMC"
+m[["3"]] <- mkinmod(parent = list(type = "DFOP"))
+m[["3"]]$name = "DFOP"
+m[["4"]] <- mkinmod(parent = list(type = "SFO", to = "m1"),
+ m1 = list(type = "SFO"),
+ use_of_ff = "max")
+m[["4"]]$name = "SFO_SFO"
+# 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
+ }
+}
+m.df <- data.frame()
+update_m.df()
+m.cur = "1"
+# Initial fit lists {{{2
+# The fits and summaries are collected in lists of lists
+f <- s <- list()
+# Dataframe with fits for selection {{{2
+update_f.df <- function() {
+ f.df <<- data.frame(Fit = character(),
+ Dataset = character(),
+ Model = character(),
+ stringsAsFactors = FALSE)
+ 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)
+ }
+}
+f.df.empty <- f.df <- data.frame(Fit = "0",
+ Dataset = "",
+ Model = "",
+ stringsAsFactors = FALSE)
+# 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 = "/")
+ try(load(tmpfile))
+ project_file <<- pr.gf$filename
+ svalue(pr.ge) <- project_file
+
+ # Studies
+ studies.gdf[,] <- studies.df
+
+ # Datasets
+ ds.cur <<- ds.cur
+ ds <<- ds
+ update_ds.df()
+ ds.gtable[,] <- ds.df
+ update_ds_editor()
+
+ # Models
+ m.cur <<- ds.cur
+ m <<- m
+ update_m.df()
+ m.gtable[,] <- m.df
+ update_m_editor()
+
+ # Fits
+ f.cur <<- f.cur
+ f <<- f
+ s <<- s
+ if (length(f) > 0) update_f.df()
+ else f.df <- f.df.empty
+ f.gtable[,] <- f.df
+ ftmp <<- f[[f.cur]]
+ stmp <<- s[[f.cur]]
+ ds.i <<- ds.cur
+ update_plotting_and_fitting()
+}
+save_to_file_handler <- function(h, ...)
+{
+ studies.df <- data.frame(studies.gdf[,], stringsAsFactors = FALSE)
+ save(studies.df, ds, ds.cur, m, m.cur, f, s, f.cur, file = project_file)
+ galert(paste("Saved project contents to", project_file), parent = w)
+}
+change_project_file_handler = function(h, ...) {
+ project_file <<- as.character(svalue(h$obj))
+}
+# Project data management GUI elements {{{2
+pr.gf <- gfile(text = "Select project file", cont = prg,
+ handler = upload_file_handler)
+pr.ge <- gedit(project_file, cont = prg,
+ handler = change_project_file_handler)
+# The save button is always visible {{{1
+gbutton("Save current project contents", cont = left,
+ handler = save_to_file_handler)
+
+# GUI widgets and a function 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 = 290, height = 200, 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)
+# 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, width = 290, cont = dsm)
+addHandlerDoubleClick(ds.gtable, ds.switcher)
+size(ds.gtable) <- list(columnWidths = c(40, 200, 40))
+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, width = 290, cont = dsm)
+addHandlerDoubleClick(m.gtable, m.switcher)
+size(m.gtable) <- list(columnWidths = c(40, 240))
+m.gtable$value <- 1
+
+# Button for setting up a fit for the selected dataset and model
+gbutton("Configure fit for selected model and dataset", cont = dsm,
+ 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)
+ show_plot("Initial", default = TRUE)
+ 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.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)
+ svalue(f.gg.summary) <- capture.output(stmp)
+ svalue(center) <- 3
+ })
+
+# Fits {{{1
+f.gf <- gframe("Fits", cont = left, horizontal = FALSE)
+# Fit table with handler {{{2
+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, width = 290, cont = f.gf)
+addHandlerDoubleClick(f.gtable, f.switcher)
+size(f.gtable) <- list(columnWidths = c(40, 60, 180))
+
+# Dataset editor {{{1
+ds.editor <- gframe("Dataset 1", horizontal = FALSE, cont = center, label = "Dataset editor")
+# Handler functions {{{3
+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]] <<- 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
+ )
+ )
+ update_ds.df()
+ ds.gtable[,] <- ds.df
+ update_ds_editor()
+}
+
+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)
+ if (class(tmpd) != "try-error") {
+ ds.cur <<- as.character(1 + length(ds))
+ ds[[ds.cur]] <<- list(
+ study_nr = NA,
+ title = "New upload",
+ sampling_times = sort(unique(tmpd$t)),
+ time_unit = "",
+ observed = unique(tmpdw$name),
+ unit = "",
+ replicates = max(aggregate(tmpdw$time,
+ list(tmpdw$time,
+ tmpdw$name),
+ length)$x),
+ data = tmpdw)
+ ds[[ds.cur]]$data$override <<- as.numeric(NA)
+ 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()
+}
+
+# Widget setup {{{3
+# Line 1 {{{4
+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 {{{4
+ds.e.2 <- ggroup(cont = ds.editor, horizontal = TRUE)
+gbutton("Copy dataset", cont = ds.e.2, handler = copy_dataset_handler)
+gbutton("Delete dataset", cont = ds.e.2, handler = delete_dataset_handler)
+gbutton("New dataset", cont = ds.e.2, handler = new_dataset_handler)
+
+upload_dataset.gf <- gfile(text = "Upload text file", cont = ds.e.2,
+ handler = new_ds_from_csv_handler)
+
+# Line 3 with forms {{{4
+ds.e.forms <- ggroup(cont= ds.editor, 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"
+
+# Keep button {{{4
+gbutton("Keep changes", cont = ds.editor, handler = keep_ds_changes_handler)
+
+# Kinetic Data {{{4
+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
+
+ 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),
+ state.ini = stateparms,
+ parms.ini = deparms,
+ err = "err",
+ control.modFit = list(maxiter = 0)))
+ ftmp$ds.index <<- ds.i
+ ftmp$ds <<- ds[[ds.i]]
+ }
+
+ svg(tf, width = 7, height = 5)
+ plot(ftmp, main = ftmp$ds$title,
+ 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)))
+ dev.off()
+ svalue(plot.gs) <<- tf
+}
+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)),
+ 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) <- capture.output(stmp)
+}
+ds.i <- m.i <- "1"
+f.cur <- "0"
+
+# GUI widgets {{{2
+pf <- gframe("Dataset 1, Model SFO", horizontal = FALSE,
+ cont = center, label = "Plotting and fitting")
+
+# Mid group with plot and options {{{3
+f.gg.mid <- ggroup(cont = pf)
+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)
+tf <- get_tempfile(ext=".svg")
+svg(tf, width = 7, height = 5)
+plot(ftmp)
+dev.off()
+plot.gs <- gsvg(tf, container = f.gg.mid, width = 420, height = 300)
+f.gg.opts <- gformlayout(cont = f.gg.mid)
+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)
+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)
+
+# Dataframe with initial and optimised parameters {{{3
+f.gg.parms <- gdf(Parameters, width = 420, height = 300, cont = pf,
+ do_add_remove_buttons = FALSE)
+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)
+
+# Row with buttons {{{3
+f.gg.buttons <- ggroup(cont = pf)
+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",
+ 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)
+ f[[f.cur]] <<- ftmp
+ s[[f.cur]] <<- stmp
+ update_f.df()
+ f.gtable[,] <<- f.df
+ }, cont = f.gg.buttons)
+tooltip(keep.fit.gb) <- "Store the optimised model with all settings and the current dataset in the fit list"
+
+show.plots.gb <- gbutton("Show plots",
+ handler = function(h, ...) show_plot_window(),
+ cont = f.gg.buttons)
+tooltip(show.plots.gb) <- "Show a window with plots including residual plots"
+
+# Summary {{{3
+f.gg.summary <- gtext(capture.output(stmp), cont = pf,
+ use.codemirror = TRUE)
+
+
+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"
+
+# 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)
+ show_plot("Optimised")
+ svalue(f.gg.opts.st) <- ftmp$solution_type
+ 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
+ f.gg.parms[,] <- get_Parameters(stmp, TRUE)
+ svalue(f.gg.summary) <- capture.output(stmp)
+}
+
+# Show plot window with residual plots {{{3
+show_plot_window <- function(h, ...) {
+ n.obs = length(ftmp$mkinmod$spec)
+ obs.vars = names(ftmp$mkinmod$spec)
+ parent = obs.vars[1]
+ if(n.obs == 1) {
+ n.rows = 1
+ ps = 7
+ } else {
+ n.rows = 1 + ceiling(n.obs / 2)
+ ps = 10
+ }
+ imgwidth = 800
+ imgheight = 360 * n.rows
+ pw <- gwindow("Plot window", parent = w,
+ width = imgwidth + 20, height = imgheight + 100)
+ pwg <- ggroup(cont = pw, horizontal = FALSE)
+ make_plots <- function() {
+ par(mfrow = c(n.rows, 2))
+ plot(ftmp, main = ftmp$ds$title,
+ 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)))
+ if (n.obs > 1) {
+ plot(ftmp, legend = FALSE,
+ main = paste0("Zoomed in on metabolite",
+ ifelse(n.obs > 2, "s", "")),
+ 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)),
+ ylim = c(0, max(subset(ftmp$data,
+ variable != parent)$observed)))
+ for (met in obs.vars[-1]) {
+ mkinresplot(ftmp, met, legend = FALSE,
+ main = paste("Residual plot for", met))
+ }
+ } else {
+ mkinresplot(ftmp, parent, legend = FALSE,
+ main = paste("Residual plot for", parent),
+ xlab = ifelse(ftmp$ds$time_unit == "", "Time",
+ paste("Time in", ftmp$ds$time_unit)),
+ ylab = ifelse(ds[[ds.i]]$unit == "", "Residuals",
+ paste("Residuals in", ftmp$ds$unit)))
+ }
+ }
+
+ tf2 <- get_tempfile(ext = ".png")
+ png(tf2, width = imgwidth / 50 , height = imgheight / 50,
+ units = "cm", res = 300, pointsize = ps)
+ make_plots()
+ dev.off()
+
+ ghtml(paste0("<img width='", imgwidth, "' height='", imgheight,
+ "' src='", get_tempfile_url(tf2), "' />"),
+ cont = pwg)
+}
+# vim: set foldmethod=marker ts=2 sw=2 expandtab: {{{1
|