diff options
Diffstat (limited to 'inst')
| -rw-r--r-- | inst/GUI/README | 1 | ||||
| -rw-r--r-- | inst/GUI/TODO | 1 | ||||
| -rw-r--r-- | inst/GUI/gmkin.R | 928 |
3 files changed, 0 insertions, 930 deletions
diff --git a/inst/GUI/README b/inst/GUI/README deleted file mode 100644 index 89e37265..00000000 --- a/inst/GUI/README +++ /dev/null @@ -1 +0,0 @@ -These code fragments are still experimental, but some basic functionality works. diff --git a/inst/GUI/TODO b/inst/GUI/TODO deleted file mode 100644 index 1fbcca66..00000000 --- a/inst/GUI/TODO +++ /dev/null @@ -1 +0,0 @@ -- Make plot of fit and residuals configurable diff --git a/inst/GUI/gmkin.R b/inst/GUI/gmkin.R deleted file mode 100644 index ae9d88d1..00000000 --- a/inst/GUI/gmkin.R +++ /dev/null @@ -1,928 +0,0 @@ -# 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/>
-
-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 = 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)
-
-# 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 = 235,
- height = 180, cont = stg)
-studies.gdf$set_column_width(1, 40)
-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, 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("<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)
-
-# 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 {{{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()
-}
-
-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 <- 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(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)
- 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 {{{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)
-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 {{{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)
-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 {{{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
-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("<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)
-
-# 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.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("<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
|