summaryrefslogtreecommitdiff
path: root/CakeOlsPlot.R
diff options
context:
space:
mode:
authorJohannes Ranke <jranke@uni-bremen.de>2018-02-02 10:53:38 +0100
committerJohannes Ranke <jranke@uni-bremen.de>2018-02-02 10:53:38 +0100
commit1684a82b15dee35812c1340e26d721ee64a28751 (patch)
treeb7c491cb77d9844c07e78943a52e603e4aed0328 /CakeOlsPlot.R
parent5b3daf393831acc4099e1bde3fe4527993529d74 (diff)
Version 3.3 from a fresh installationv3.3
Diffstat (limited to 'CakeOlsPlot.R')
-rw-r--r--CakeOlsPlot.R175
1 files changed, 0 insertions, 175 deletions
diff --git a/CakeOlsPlot.R b/CakeOlsPlot.R
deleted file mode 100644
index e92742c..0000000
--- a/CakeOlsPlot.R
+++ /dev/null
@@ -1,175 +0,0 @@
-#$Id$
-# Generates fitted curves so the GUI can plot them
-# Based on code in IRLSkinfit
-# Author: Rob Nelson (Tessella)
-# Modifications developed by Tessella Plc for Syngenta: Copyright (C) 2011 Syngenta
-# Tessella Project Reference: 6245
-#
-# This program 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/>.”
-
-CakePlotInit <- function(fit, xlim = range(fit$data$time), ...)
-{
- t.map.names <- names(fit$map)
- metabolites <- grep("[A-Z]\\d", t.map.names, value = TRUE)
- t.map.rest <- setdiff(t.map.names, metabolites)
-
- # Generate the normal graphs.
- final <- CakeOlsPlot(fit, xlim)
- final_scaled <- final
-
- if(length(metabolites) > 0){
- for(i in 1:length(metabolites))
- {
- metabolite <- metabolites[i]
- decay_var <- paste("k", metabolite, sep="_")
-
- # calculate the new ffm and generate the two ffm scale charts
- regex <- paste("f_(.+)_to", metabolite, sep="_")
- decays = grep(regex, names(fit$par), value = TRUE)
- ffm_fitted <- sum(fit$par[decays])
- normal <- final
- ffm_scale <- NULL
-
- # Generate the DT50=1000d and ffm as fitted.
- k_new <- fit$par[decay_var]*fit$distimes[metabolite,]["DT50"]/1000;
- fit$par[decay_var]<- k_new[metabolite,]
- dt50_1000_ffm_fitted <- CakeOlsPlot(fit, xlim)[metabolite]
-
- naming <- c(names(final), paste(metabolite, "DT50_1000_FFM_FITTED", sep="_"))
- normal <- c(final, dt50_1000_ffm_fitted)
- names(normal) <- naming
- final <- normal
-
- # Generate the scaled FFM
- if(ffm_fitted != 0)
- {
- ffm_scale <- 1 / ffm_fitted
- final_scaled <- final[c("time", metabolite, paste(metabolite, "DT50_1000_FFM_FITTED", sep="_"))]
- final_scaled[t.map.rest] <- NULL;
- final_frame <- as.data.frame(final_scaled)
- new_names <- c(paste(metabolite, "DT50_FITTED_FFM_1", sep="_"), paste(metabolite, "DT50_1000_FFM_1", sep="_"))
- names(final_frame) <- c("time", new_names)
- final_frame[new_names]<-final_frame[new_names]*ffm_scale;
-
- cat("<PLOT MODEL START>\n")
-
- write.table(final_frame, quote=FALSE)
-
- cat("<PLOT MODEL END>\n")
- }
- }
- }
-
- cat("<PLOT MODEL START>\n")
-
- write.table(final, quote=FALSE)
-
- cat("<PLOT MODEL END>\n")
-
- # View(final)
-}
-
-CakeOlsPlot <- function(fit, xlim = range(fit$data$time), scale_x = 1.0, ...)
-{
- solution = fit$solution
- if ( is.null(solution) ) {
- solution <- "deSolve"
- }
- atol = fit$atol
- if ( is.null(atol) ) {
- atol = 1.0e-6
- }
-
- fixed <- fit$fixed$value
- names(fixed) <- rownames(fit$fixed)
- parms.all <- c(fit$par, fixed)
- ininames <- c(
- rownames(subset(fit$start, type == "state")),
- rownames(subset(fit$fixed, type == "state")))
- odeini <- parms.all[ininames]
- names(odeini) <- names(fit$diffs)
-
- outtimes <- seq(0, xlim[2], length.out=101) * scale_x
-
- odenames <- c(
- rownames(subset(fit$start, type == "deparm")),
- rownames(subset(fit$fixed, type == "deparm")))
- odeparms <- parms.all[odenames]
-
- # Solve the system
- evalparse <- function(string)
- {
- eval(parse(text=string), as.list(c(odeparms, odeini)))
- }
- if (solution == "analytical") {
- parent.type = names(fit$map[[1]])[1]
- parent.name = names(fit$diffs)[[1]]
- o <- switch(parent.type,
- SFO = SFO.solution(outtimes,
- evalparse(parent.name),
- evalparse(paste("k", parent.name, sep="_"))),
- FOMC = FOMC.solution(outtimes,
- evalparse(parent.name),
- evalparse("alpha"), evalparse("beta")),
- DFOP = DFOP.solution(outtimes,
- evalparse(parent.name),
- evalparse("k1"), evalparse("k2"),
- evalparse("g")),
- HS = HS.solution(outtimes,
- evalparse(parent.name),
- evalparse("k1"), evalparse("k2"),
- evalparse("tb")),
- SFORB = SFORB.solution(outtimes,
- evalparse(parent.name),
- evalparse(paste("k", parent.name, "free_bound", sep="_")),
- evalparse(paste("k", parent.name, "bound_free", sep="_")),
- evalparse(paste("k", parent.name, "free_sink", sep="_")))
- )
- out <- cbind(outtimes, o)
- dimnames(out) <- list(outtimes, c("time", parent.name))
- }
- if (solution == "eigen") {
- coefmat.num <- matrix(sapply(as.vector(fit$coefmat), evalparse),
- nrow = length(odeini))
- e <- eigen(coefmat.num)
- c <- solve(e$vectors, odeini)
- f.out <- function(t) {
- e$vectors %*% diag(exp(e$values * t), nrow=length(odeini)) %*% c
- }
- o <- matrix(mapply(f.out, outtimes),
- nrow = length(odeini), ncol = length(outtimes))
- dimnames(o) <- list(names(odeini), NULL)
- out <- cbind(time = outtimes, t(o))
- }
- if (solution == "deSolve") {
- out <- ode(
- y = odeini,
- times = outtimes,
- func = fit$mkindiff,
- parms = odeparms,
- atol = atol
- )
- }
-
- # Output transformation for models with unobserved compartments like SFORB
- out_transformed <- data.frame(time = out[,"time"])
- for (var in names(fit$map)) {
- if(length(fit$map[[var]]) == 1) {
- out_transformed[var] <- out[, var]
- } else {
- out_transformed[var] <- rowSums(out[, fit$map[[var]]])
- }
- }
- return(out_transformed)
-}

Contact - Imprint