From a0421f67c70c9857d96bfcd7fc0069efa7d83b37 Mon Sep 17 00:00:00 2001 From: jranke Date: Wed, 6 Nov 2013 06:40:17 +0000 Subject: - New candidate for release containing the latest changes to the GUI - Checking and releasing myself as r-forge has a stuffed build pipeline git-svn-id: svn+ssh://svn.r-forge.r-project.org/svnroot/kinfit/pkg/mkin@139 edb9625f-4e0d-4859-8d74-9fd3b1da38cb --- inst/GUI/README | 2 +- inst/GUI/TODO | 1 - inst/GUI/mkinGUI.R | 173 ++++++++------ inst/GUI/run_simple.R | 3 - inst/GUI/simple.R | 645 -------------------------------------------------- 5 files changed, 100 insertions(+), 724 deletions(-) delete mode 100644 inst/GUI/run_simple.R delete mode 100644 inst/GUI/simple.R (limited to 'inst') diff --git a/inst/GUI/README b/inst/GUI/README index aa83ea6c..f431c2d1 100644 --- a/inst/GUI/README +++ b/inst/GUI/README @@ -1 +1 @@ -These code fragments do not provide a GUI for mkin. They are purely experimental. +These code fragments are experimental. diff --git a/inst/GUI/TODO b/inst/GUI/TODO index e9089eda..c0e822c6 100644 --- a/inst/GUI/TODO +++ b/inst/GUI/TODO @@ -1,4 +1,3 @@ - Import of csv files -- Create widgets for model configuration only once per dataset, it takes too much time - Make summary text file accessible - Make plot of fit and residuals accessible diff --git a/inst/GUI/mkinGUI.R b/inst/GUI/mkinGUI.R index b418b42d..921daea7 100644 --- a/inst/GUI/mkinGUI.R +++ b/inst/GUI/mkinGUI.R @@ -119,10 +119,13 @@ update_f.df <- function() { 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$m.name) + 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 @@ -138,31 +141,32 @@ upload_file_handler <- function(h, ...) studies.gdf[,] <- studies.df # Datasets - ds.cur <<- "1" + ds.cur <<- ds.cur ds <<- ds update_ds.df() ds.gtable[,] <- ds.df update_ds_editor() # Models - m.cur <<- "1" + m.cur <<- ds.cur m <<- m update_m.df() m.gtable[,] <- m.df update_m_editor() # Fits - f.cur <<- "1" + f.cur <<- f.cur f <<- f s <<- s - update_f.df() + if (length(f) > 0) update_f.df() + else f.df <- f.df.empty f.gtable[,] <- f.df update_plotting_and_fitting() } save_to_file_handler <- function(h, ...) { studies.df <- data.frame(studies.gdf[,], stringsAsFactors = FALSE) - save(studies.df, ds, m, f, s, file = project_file) + 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, ...) { @@ -219,23 +223,19 @@ 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)) - f.cur <<- as.character(as.numeric(f.cur) + 1) - f[[f.cur]] <<- suppressWarnings( - mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - err = "err", - control.modFit = list(maxiter = 0))) - f[[f.cur]]$ds.index <<- ds.i - f[[f.cur]]$ds <<- ds[[ds.i]] - f[[f.cur]]$m.index <<- m.i - f[[f.cur]]$m.name <<- m[[m.i]]$name + 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]] update_f.df() f.gtable[,] <<- f.df - s[[f.cur]] <<- summary(f[[f.cur]]) - svalue(pf) <- paste0("Fit ", f.cur, ": Dataset ", ds.i, - ", Model ", m[[m.i]]$name) + stmp <<- summary(ftmp) + svalue(pf) <- paste0("Dataset ", ds.i, ", Model ", m[[m.i]]$name) show_plot("Initial", default = TRUE) svalue(f.gg.opts.st) <<- "auto" - f.gg.parms[,] <- get_Parameters(s[[f.cur]], FALSE) + f.gg.parms[,] <- get_Parameters(stmp, FALSE) svalue(center) <- 3 }) @@ -243,15 +243,18 @@ gbutton("Configure fit for selected model and dataset", cont = dsm, f.gf <- gframe("Fits", cont = left, horizontal = FALSE) # Fit table with handler {{{2 f.switcher <- function(h, ...) { - f.cur <<- svalue(h$obj) - update_plotting_and_fitting() + if (svalue(h$obj) != "0") { + f.cur <<- svalue(h$obj) + ftmp <<- f[[f.cur]] + stmp <<- f[[f.cur]] + ds.i <<- ftmp$ds.index + update_plotting_and_fitting() + } svalue(center) <- 3 } -f.df <- data.frame(Fit = "1", Dataset = "1", Model = "SFO", - stringsAsFactors = FALSE) f.gtable <- gtable(f.df, width = 290, cont = f.gf) addHandlerDoubleClick(f.gtable, f.switcher) -size(f.gtable) <- list(columnWidths = c(80, 80, 120)) +size(f.gtable) <- list(columnWidths = c(40, 60, 180)) # Dataset editor {{{1 ds.editor <- gframe("Dataset 1", horizontal = FALSE, cont = center, label = "Dataset editor") @@ -516,15 +519,15 @@ show_plot <- function(type, default = FALSE) { deparms <- as.numeric(Parameters.de[[type]]) names(deparms) <- rownames(Parameters.de) if (type == "Initial" & default == FALSE) { - ftmp <- suppressWarnings( - mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - state.ini = stateparms, parms.ini = deparms, - err = "err", - control.modFit = list(maxiter = 0)) - ) - } else { - ftmp <- f[[f.cur]] - } + 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]] + } tmp <- get_tempfile(ext=".svg") svg(tmp, width = 7, height = 5) @@ -566,42 +569,39 @@ run_fit <- function() { iniparms <- Parameters.ini$Initial names(iniparms) <- sub("_0", "", Parameters.ini$Name) inifixed <- names(iniparms[Parameters.ini$Fixed]) - f[[f.cur]] <<- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - state.ini = iniparms, - fixed_initials = inifixed, - parms.ini = deparms, - fixed_parms = defixed, - solution_type = svalue(f.gg.opts.st), - err = "err") - f[[f.cur]]$ds.index <<- ds.i - f[[f.cur]]$ds <<- ds[[ds.i]] - f[[f.cur]]$m.index <<- m.i - f[[f.cur]]$m.name <<- m[[m.i]]$name - s[[f.cur]] <<- summary(f[[f.cur]]) + 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), + err = "err") + ftmp$ds.index <<- ds.i + ftmp$ds <<- ds[[ds.i]] + stmp <<- summary(ftmp) show_plot("Optimised") - svalue(f.gg.opts.st) <- f[[f.cur]]$solution_type - f.gg.parms[,] <- get_Parameters(s[[f.cur]], TRUE) + svalue(f.gg.opts.st) <- ftmp$solution_type + f.gg.parms[,] <- get_Parameters(stmp, TRUE) } -ds.i <- m.i <- f.cur <- "1" +ds.i <- m.i <- "1" +f.cur <- "0" # GUI widgets {{{2 -pf <- gframe("Fit 1: Dataset 1, Model SFO", horizontal = FALSE, +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) -f[[f.cur]] <- suppressWarnings(mkinfit(m[[m.cur]], override(ds[[ds.i]]$data), +ftmp <- suppressWarnings(mkinfit(m[[m.cur]], override(ds[[ds.i]]$data), err = "err", control.modFit = list(maxiter = 0))) -f[[f.cur]]$ds.index = ds.i -f[[f.cur]]$ds = ds[[ds.i]] -f[[f.cur]]$m.index = m.i -f[[f.cur]]$m.name = m[[m.i]]$name -s[[f.cur]] <- summary(f[[f.cur]]) -Parameters <- get_Parameters(s[[f.cur]], FALSE) +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(f[[f.cur]]) +plot(ftmp) dev.off() plot.gs <- gsvg(tf, container = f.gg.mid, width = 490, height = 350) f.gg.opts <- gformlayout(cont = f.gg.mid) @@ -621,27 +621,52 @@ f.gg.parms$set_column_width(5, 60) # Row with buttons {{{3 f.gg.buttons <- ggroup(cont = pf) -gbutton("Show initial", - handler = function(h, ...) show_plot("Initial"), - cont = f.gg.buttons) -gbutton("Run", handler = function(h, ...) run_fit(), - cont = f.gg.buttons) -gbutton("Delete", handler = function(h, ...) { - f[[f.cur]] <<- NULL - s[[f.cur]] <<- NULL - names(f) <<- as.character(1:length(f)) - names(s) <<- as.character(1:length(f)) - update_f.df() +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" + +delete.fit.gb <- gbutton("Delete", handler = function(h, ...) { + if (length(f) > 0) { + f[[f.cur]] <<- NULL + s[[f.cur]] <<- NULL + } + if(length(f) > 1) { + 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 <<- f[[f.cur]] + ds.i <<- ftmp$ds.index + update_plotting_and_fitting() + } else { + f.df <<- f.df.empty + f.cur <<- "0" + } f.gtable[,] <<- f.df - f.cur <<- "1" }, 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 ", f[[f.cur]]$ds.index, - ", Model ", f[[f.cur]]$m.name) + svalue(pf) <- paste0("Fit ", f.cur, ": Dataset ", ftmp$ds.index, + ", Model ", ftmp$mkinmod$name) show_plot("Optimised") - svalue(f.gg.opts.st) <- f[[f.cur]]$solution_type - f.gg.parms[,] <- get_Parameters(s[[f.cur]], TRUE) + svalue(f.gg.opts.st) <- ftmp$solution_type + f.gg.parms[,] <- get_Parameters(stmp, TRUE) } # vim: set foldmethod=marker ts=2 sw=2 expandtab: {{{1 diff --git a/inst/GUI/run_simple.R b/inst/GUI/run_simple.R deleted file mode 100644 index 49af7682..00000000 --- a/inst/GUI/run_simple.R +++ /dev/null @@ -1,3 +0,0 @@ -require(gWidgetsWWW2) -load_app("simple.R") -# vim: set filetype=r: diff --git a/inst/GUI/simple.R b/inst/GUI/simple.R deleted file mode 100644 index e53ffa18..00000000 --- a/inst/GUI/simple.R +++ /dev/null @@ -1,645 +0,0 @@ -# $Id$ {{{1 - -# Simple 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 -require(mkin) # {{{1 -# Set the GUI title and create the parent frame {{{1 -GUI_title <- "Simple Browser based GUI for kinetic evaluations using mkin" -w <- gwindow(GUI_title) -sb <- gstatusbar("Powered by gWidgetsWWW2 and Rook", cont = w) -g <- gframe(GUI_title, cont = w, use.scrollwindow = TRUE, horizontal = FALSE) -# 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), - Author = "FOCUS kinetics workgroup", - Year = "2006", - Title = "FOCUS 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 -} -# 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" -# Initial fit lists {{{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) -} -# The GUI elements for each dataset are kept in lists -f.gg <- f.gg.sel <- f.gg.parms <- f.gg.opts <- list() -# The fits and summaries are collected in a list of lists -f <- s <- list() -for (ds.i in 1:length(ds)) { - f[[as.character(ds.i)]] <- list() - s[[as.character(ds.i)]] <- list() -} -# Data frames with datasets, models and fits to be continuosly updated {{{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" -# 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" -# Expandable group for project data management {{{1 -prg <- gexpandgroup("Project file management", cont = g) -# Project data management handler functions {{{2 -upload_file_handler <- function(h, ...) -{ - tmpfile <- normalizePath(svalue(h$obj), winslash = "/") - try(load(tmpfile)) - project_file <<- pr.gf$filename - svalue(wf.ge) <- project_file - studies.gdf[,] <- studies.df - ds.cur <<- "1" - ds <<- ds - update_ds.df() - ds.gtable[,] <- ds.df - update_ds_editor() - m.cur <<- "1" - m <<- m - update_m.df() - m.gtable[,] <- m.df - update_m_editor() -} -save_to_file_handler <- function(h, ...) -{ - studies.df <- data.frame(studies.gdf[,], stringsAsFactors = FALSE) - save(studies.df, ds, m, file = project_file) - galert(paste("Saved project contents to", project_file), parent = w) -} -# Project data management GUI elements {{{2 -pr.vg <- ggroup(cont = prg, horizontal = FALSE) -pr.hg <- ggroup(cont = pr.vg, horizontal = TRUE) -pr.gf <- gfile(text = "Select project file", cont = pr.hg, - handler = upload_file_handler) -pr.vg2 <- ggroup(cont = pr.hg, horizontal = FALSE) -pr.hg2 <- ggroup(cont = pr.vg2, horizontal = TRUE) -glabel("Current project file name is", cont = pr.hg2) -change_project_file_handler = function(h, ...) { - project_file <<- as.character(svalue(h$obj)) -} -wf.ge <- gedit(project_file, cont = pr.hg2, - handler = change_project_file_handler) - -gbutton("Save current project contents to this file", cont = pr.vg2, - handler = save_to_file_handler) - -# Expandable group for studies {{{1 -stg <- gexpandgroup("Studies", cont = g) -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 = "Studies in the project", - width = 500, height = 200, cont = stg) -studies.gdf$set_column_width(1, 40) -studies.gdf$set_column_width(2, 200) -addHandlerChanged(studies.gdf, update_study_selector) - -# Datasets and models {{{1 -dsm <- gframe("Datasets and models - double click to edit", cont = g, - horizontal = TRUE) - -# Dataset table with handler {{{2 -ds.switcher <- function(h, ...) { - ds.cur <<- as.character(svalue(h$obj)) - update_ds_editor() - visible(dse) <- TRUE - visible(me) <- FALSE -} -ds.gtable <- gtable(ds.df, multiple = TRUE, cont = dsm) -addHandlerDoubleClick(ds.gtable, ds.switcher) -size(ds.gtable) <- list(columnWidths = c(40, 200, 40)) - -# Model table with handler {{{2 -m.switcher <- function(h, ...) { - m.cur <<- as.character(svalue(h$obj)) - update_m_editor() - visible(dse) <- FALSE - visible(me) <- TRUE -} -m.gtable <- gtable(m.df, multiple = TRUE, cont = dsm) -addHandlerDoubleClick(m.gtable, m.switcher) -size(m.gtable) <- list(columnWidths = c(40, 200)) - -# Section for selecting datasets and model {{{2 -dsmsel <- gvbox(cont = dsm) -show_plot <- function(ds.i, type) { - m.i <- as.character(svalue(f.gg.sel[[ds.i]], index = TRUE)) - ow <- options("warn") - options(warn = -1) - Parameters <- f.gg.parms[[ds.i]][,] - 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") { - f[[ds.i]][[m.i]] <- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - state.ini = stateparms, - parms.ini = deparms, - err = "err", control.modFit = list(maxiter = 0)) - } - - options(ow) - tmp <- get_tempfile(ext=".svg") - svg(tmp, width = 7, height = 5) - plot(f[[ds.i]][[m.i]], main = ds[[ds.i]]$title, - xlab = ifelse(ds[[ds.i]]$time_unit == "", "Time", - paste("Time in", ds[[ds.i]]$time_unit)), - ylab = ifelse(ds[[ds.i]]$unit == "", "Observed", - paste("Observed in", ds[[ds.i]]$unit))) - dev.off() - svalue(plots[[ds.i]]) <<- tmp -} -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(ds.i) { - m.i <- as.character(svalue(f.gg.sel[[ds.i]], index = TRUE)) - Parameters <- f.gg.parms[[ds.i]][,] - Parameters.de <- subset(Parameters, Type == "deparm") - deparms <- Parameters.de$Initial - names(deparms) <- rownames(Parameters.de) - f[[ds.i]][[m.i]] <- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - state.ini = subset(Parameters, - Type == "state")$Initial, - parms.ini = deparms, - err = "err") - s[[ds.i]][[m.i]] <- summary(f[[ds.i]][[m.i]]) - f.gg.parms[[ds.i]][,] <- get_Parameters(s[[ds.i]][[m.i]], TRUE) - show_plot(ds.i, "Optimised") -} -select_model_handler <- function(h, ...) { - m.i <- as.character(svalue(h$obj, index = TRUE)) - if (is.null(f[[ds.i]][[m.i]])) { - f[[ds.i]][[m.i]] <<- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), - err = "err", control.modFit = list(maxiter = 0)) - } - if (is.na(f.gg.parms[[ds.i]][1, "Optimised"])) { - f.gg.parms[[ds.i]][,] <- get_Parameters(summary(f[[ds.i]][[m.i]]), FALSE) - show_plot(ds.i, "Initial") - } else { - f.gg.parms[[ds.i]][,] <- get_Parameters(s[[ds.i]][[m.i]], TRUE) - show_plot(ds.i, "Optimised") - } -} -show_fit_config <- function(ds.i) { - ftmp <- f[[ds.i]][["1"]] - stmp <- summary(ftmp) - Parameters <- get_Parameters(stmp, FALSE) - f.gg[[ds.i]] <<- gvbox(cont = prows[[ds.i]]) - - f.gg.head <- ggroup(cont = f.gg[[ds.i]]) - f.gg.sel[[ds.i]] <- gcombobox(m.df$Name, sel = 1, cont = f.gg.head, - handler = select_model_handler) - gbutton("Show initial", - handler = function(h, ...) show_plot(ds.i, "Initial"), - cont = f.gg.head) - gbutton("Run", handler = function(h, ...) run_fit(ds.i), - cont = f.gg.head) - - f.gg.rest <- ggroup(cont = f.gg[[ds.i]]) - f.gg.parms[[ds.i]] <<- gdf(Parameters, width = 420, height = 300, - cont = f.gg.rest, - do_add_remove_buttons = FALSE) - f.gg.parms[[ds.i]]$set_column_width(1, 200) - f.gg.parms[[ds.i]]$set_column_width(2, 50) - f.gg.parms[[ds.i]]$set_column_width(3, 60) - f.gg.parms[[ds.i]]$set_column_width(4, 50) - f.gg.parms[[ds.i]]$set_column_width(5, 60) - - f.gg.opts[[ds.i]] <<- gformlayout(cont = f.gg.rest) - solution_types <- character() - if (length(ftmp$mkinmod$map) == 1) solution_types <- "analytical" - if (is.matrix(ftmp$mkinmod$coefmat)) solution_types <- c(solution_types, "eigen") - solution_types <- c(solution_types, "deSolve") - - gcombobox(solution_types, selected = 1, - label = "solution_type", - cont = f.gg.opts[[ds.i]]) -} -#configure_fits_handler <- function(h, ...) { -# ds.sel <- as.character(svalue(ds.gtable)) -# m.sel <- as.character(svalue(m.gtable)) -#} -#dsconfig <- gbutton("Configure fits for selections", cont = dsmsel, -# handler = configure_fits_handler) - -# Expandable group for the dataset editor {{{1 -dse <- gexpandgroup("Dataset editor", cont = g, horizontal = FALSE) -visible(dse) <- FALSE - -# 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 - prows[[ds.cur]] <<- ggroup(cont = pfv) - plots[[ds.cur]] <<- gsvg(svg_plot(ds.cur), - container = prows[[ds.cur]], - width = 490, height = 350) -} - -delete_dataset_handler <- function(h, ...) { - ds[[ds.cur]] <<- NULL - delete(pfv, prows[[ds.cur]]) - names(ds) <<- names(plots) <<- names(prows) <<- 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 = "NA", - observed = "parent", - unit = "NA", - 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() - prows[[ds.cur]] <<- ggroup(cont = pfv) - plots[[ds.cur]] <<- gsvg(svg_plot(ds.cur), - container=prows[[ds.cur]], - width = 490, height = 350) -} - -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 = rep(sampling_times, each = replicates, times = length(obs)), - value = NA, - override = NA, - err = 1 - ) - ds.e.gdf[,] <- new.data -} - -save_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() - update_plot() -} - - -# Widget setup {{{3 -ds.editor <- gframe("Dataset 1", horizontal = FALSE, cont = dse) -# 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) - -# 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 = 50, - 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) -gbutton("Generate empty grid for kinetic data", cont = ds.e.3b, - handler = empty_grid_handler) - -# Save button {{{4 -gbutton("Save changes", cont = ds.editor, handler = save_ds_changes_handler) - -# Kinetic Data {{{4 -ds.e.gdf <- gdf(ds[[ds.cur]]$data, name = "Kinetic data", - width = 700, height = 700, cont = ds.editor) -ds.e.gdf$set_column_width(2, 70) -enter_next_value_handler <- function(h, ...) galert("next value", parent = w) -addHandlerChanged(ds.e.gdf, enter_next_value_handler) - -# 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 -} - -# Expandable group for the model editor {{{1 -me <- gexpandgroup("Model editor", cont = g, horizontal = FALSE) -visible(me) <- FALSE - -# 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() -} - -save_m_changes_handler <- function(h, ...) { - spec <- list() - for (obs.i in 1:length(m.e.rows)) { - spec[[obs.i]] <- list(type = svalue(m.e.type[[obs.i]]), - to = svalue(m.e.to[[obs.i]]), - 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.editor <- gframe("Model 1", horizontal = FALSE, cont = me) -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("Save changes", cont = m.e.b, handler = save_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.observed)) { - 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]]) <<- 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), "", - m[[m.cur]]$spec[[obs.i]]$to) - 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}}} -# Plots and fits {{{1 -pf <- gframe("Plots and fitting", cont = g) -pfv <- gvbox(cont = pf) -prows <- plots <- list() - -svg_plot <- function(ds.i) { - d <- ds[[ds.i]] - - f <- get_tempfile(ext=".svg") - svg(f, width = 7, height = 5) - plot(0, type = "n", - xlim = c(0, max(d$data$time, na.rm = TRUE)), - xlab = ifelse(d$time_unit == "", "Time", - paste("Time in", d$time_unit)), - ylim = c(0, max(d$data$value, na.rm = TRUE)), - ylab = ifelse(d$unit == "", "Observed", - paste("Observed in", d$unit)), - main = d$title) - pointcolor = 1 - for (obs_var in d$observed) { - points(subset(d$data, name == obs_var, c(time, value)), - col = pointcolor) - pointcolor = pointcolor + 1 - } - legend("topright", inset = c(0.05, 0.05), legend = d$observed, - pch = 1, col = 1:length(d$observed)) - dev.off() - return(f) -} - -# Show the plots and the fit configuration -for (ds.i in 1:length(ds)) { - ds.plot <- as.character(ds.i) - prows[[ds.plot]] <- ggroup(cont = pfv) - plots[[ds.plot]] <- gsvg(svg_plot(ds.plot), - container=prows[[ds.plot]], - width = 490, height = 350) - - f[[ds.plot]][["1"]] <- mkinfit(m[["1"]], override(ds[[ds.plot]]$data), - err = "err", control.modFit = list(maxiter = 0)) - show_fit_config(ds.i) -} - -update_plot <- function() { - svalue(plots[[ds.cur]]) <<- svg_plot(ds.cur) -} - -# 1}}} -# vim: set foldmethod=marker foldlevel=0 ts=2 sw=2 expandtab: -- cgit v1.2.1