From 0e352cae56c006a5636a1aaf3b40e2eee2c1c941 Mon Sep 17 00:00:00 2001 From: jranke Date: Thu, 17 Oct 2013 10:43:46 +0000 Subject: - See ChangeLog entry for today (2 small bugfixes and lots of GUI progress) git-svn-id: svn+ssh://svn.r-forge.r-project.org/svnroot/kinfit/pkg/mkin@117 edb9625f-4e0d-4859-8d74-9fd3b1da38cb --- inst/GUI/TODO | 5 ++- inst/GUI/simple.R | 130 +++++++++++++++++++++++++++++++++++++++++++----------- 2 files changed, 109 insertions(+), 26 deletions(-) (limited to 'inst') diff --git a/inst/GUI/TODO b/inst/GUI/TODO index ea875cea..e9089eda 100644 --- a/inst/GUI/TODO +++ b/inst/GUI/TODO @@ -1 +1,4 @@ -- Write the model editor +- 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/simple.R b/inst/GUI/simple.R index f5eafb62..f53b064d 100644 --- a/inst/GUI/simple.R +++ b/inst/GUI/simple.R @@ -38,8 +38,8 @@ studies.df <- data.frame(Index = as.integer(1), # Initial datasets {{{2 ds <- list() observed.all <- vector() -for (i in 1:5) { - ds.letter = LETTERS[i] +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( @@ -74,15 +74,13 @@ override <- function(d) { value = ifelse(is.na(d$override), d$value, d$override), err = d$err) } -f <- s <- f.gg <- f.gg.rows <- list() -f.gg.ini <- f.gg.fixed <- f.gg.optim <- list() +f <- s <- f.gg <- list() +f.gg.parms <- f.gg.opts <- list() for (ds.i in 1:length(ds)) { f[[as.character(ds.i)]] <- list() f.gg[[as.character(ds.i)]] <- list() - f.gg.rows[[as.character(ds.i)]] <- list() - f.gg.ini[[as.character(ds.i)]] <- list() - f.gg.fixed[[as.character(ds.i)]] <- list() - f.gg.optim[[as.character(ds.i)]] <- list() + f.gg.parms[[as.character(ds.i)]] <- list() + f.gg.opts[[as.character(ds.i)]] <- list() s[[as.character(ds.i)]] <- list() } # Data frames with datasets, models and fits to be continuosly updated {{{1 @@ -220,30 +218,112 @@ size(m.gtable) <- list(columnWidths = c(40, 200)) # Section for selecting datasets and model {{{2 dsmsel <- gvbox(cont = dsm) +show_plot <- function(ds.i, m.i, type) { + ow <- options("warn") + options(warn = -1) + Parameters <- f.gg.parms[[ds.i]][[m.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) + ftmp <- f[[ds.i]][[m.i]] + f <- get_tempfile(ext=".svg") + svg(f, width = 7, height = 5) + plot(ftmp, 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]]) <<- f +} +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) { + Parameters <- f.gg.parms[[ds.i]][[m.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]][[m.i]][,] <- get_Parameters(s[[ds.i]][[m.i]], TRUE) + + show_plot(ds.i, m.i, "Optimised") +} +show_fit_config <- function(ds.i, m.i) { + ftmp <- f[[ds.i]][[m.i]] + stmp <- summary(ftmp) + Parameters <- get_Parameters(stmp, FALSE) + + f.gg.parms[[ds.i]][[m.i]] <<- gdf(Parameters, + width = 420, height = 300, + cont = f.gg[[ds.i]][[m.i]], + do_add_remove_buttons = FALSE) + f.gg.parms[[ds.i]][[m.i]]$set_column_width(1, 200) + f.gg.parms[[ds.i]][[m.i]]$set_column_width(2, 50) + f.gg.parms[[ds.i]][[m.i]]$set_column_width(3, 60) + f.gg.parms[[ds.i]][[m.i]]$set_column_width(4, 50) + f.gg.parms[[ds.i]][[m.i]]$set_column_width(5, 60) + + f.gg.rest <- gvbox(cont = f.gg[[ds.i]][[m.i]]) + f.gg.buttons <- ggroup(cont = f.gg.rest) + gbutton("Show initial", handler = function(h, ...) show_plot(ds.i, m.i, "Initial"), + cont = f.gg.buttons) + gbutton("Run", handler = function(h, ...) run_fit(ds.i, m.i), + cont = f.gg.buttons) + f.gg.opts[[ds.i]][[m.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]][[m.i]]) +} configure_fits_handler <- function(h, ...) { ds.sel <- as.character(svalue(ds.gtable)) m.sel <- as.character(svalue(m.gtable)) + ow <- options("warn") + options("warn" = -1) for (ds.i in ds.sel) { for (m.i in m.sel) { f.gg[[ds.i]][[m.i]] <<- ggroup(cont = f.gn[[ds.i]], label = m[[m.i]]$name) - f.gg.parms <- gvbox(cont = f.gg[[ds.i]][[m.i]]) - f.gg.rows[[ds.i]][[m.i]] <<- list() - f.gg.ini[[ds.i]][[m.i]] <<- list() - f[[ds.i]][[m.i]] <- ftmp <- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), + f[[ds.i]][[m.i]] <<- mkinfit(m[[m.i]], override(ds[[ds.i]]$data), err = "err", control.modFit = list(maxiter = 0)) - s[[ds.i]][[m.i]] <- stmp <- summary(ftmp) - pars <- rbind(stmp$start[1:2], stmp$fixed) - pars$fixed <- c(rep(FALSE, length(stmp$start$value)), - rep(TRUE, length(stmp$fixed$value))) - - for (parm in c(paste0(names(ftmp$mkinmod$map), "_0"), names(ftmp$bparms.ode))) { - f.gg.rows[[ds.i]][[m.i]][[parm]] <- ggroup(cont = f.gg.parms) - glabel(parm, cont = f.gg.rows[[ds.i]][[m.i]][[parm]]) - f.gg.ini[[ds.i]][[m.i]][[parm]] <- gedit(pars[parm, "value"], - cont = f.gg.rows[[ds.i]][[m.i]][[parm]]) - } + show_fit_config(ds.i, m.i) } } + options(ow) } dsconfig <- gbutton("Configure fits for selections", cont = dsmsel, handler = configure_fits_handler) @@ -262,7 +342,7 @@ copy_dataset_handler <- function(h, ...) { ds.gtable[,] <- ds.df prows[[ds.cur]] <<- ggroup(cont = pfv) plots[[ds.cur]] <<- gsvg(svg_plot(ds.cur), - container=prows[[ds.cur]], + container = prows[[ds.cur]], width = 490, height = 350) } @@ -560,7 +640,7 @@ for (ds.i in 1:length(ds)) { plots[[ds.plot]] <- gsvg(svg_plot(ds.plot), container=prows[[ds.plot]], width = 490, height = 350) - f.gn[[ds.plot]] <- gnotebook(cont = prows[[ds.plot]], width = 600, + f.gn[[ds.plot]] <- gnotebook(cont = prows[[ds.plot]], width = 750, handler = function(h, ...) galert("test", parent = w)) } -- cgit v1.2.1