summaryrefslogblamecommitdiff
path: root/CakePenalties.R
blob: 1feffbe68afd43254ffda7699455b638a4a8288a (plain) (tree) 
3d6b4b4

be6d42e























































1

2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56

      






















































                                                                                                                                        
# $Id$
# The CAKE R modules are based on mkin
# CAKE (6245), by Tessella, for Syngenta: Copyright (C) 2011  Syngenta
#
#    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/>.”

# Penalty function for fits that should not be accepted
CakePenalties<-function(params, modelled, obs, penalty.scale = 10, ...){
	# Because the model cost is roughly proportional to points,
	# make the penalties scale that way too for consistent behaviour
	# with many or few data points
	sum(CakePenaltiesLong(params, modelled, obs, penalty.scale, ...)$value) * dim(obs)[[1]]
}
CakePenaltiesLong<-function(params, modelled, obs, penalty.scale = 10, ...){	
	r<-data.frame(name=character(0), value=numeric(0))
	
	# Flow fractions > 1
	#-------------------------------
	fails<-CakePenaltiesFF(params);
	if(dim(fails)[[1]] > 0){
		#print("Penalty failures:")
		#print(fails)
		# Add a failure record for each flow fraction that missed
		names(fails)<-c('name', 'value')
		fails$value = 100*(fails$value - 1)
		fails$name = lapply(fails$name, function(x) paste("FF_", x, sep=""))
		r <- rbind(r, fails)
		#totalPenalties <- totalPenalties + 100*sum(fails$x - 1)	# Penalty for failure
	}	

	r$value <- r$value * penalty.scale
	return(r)
}

CakePenaltiesFF<-function(params){
	ff.values<-params["f_"==substr(names(params), 0, 2)]	# Flow fractions
	if(length(ff.values) > 0){
		ffs<-data.frame(t(sapply(strsplit(names(ff.values), '_'), FUN=function(x){ x[c(2,4)] })))	# Split into source/dest
		names(ffs)<-c('source', 'dest')
		ffs['value'] <- ff.values	# Add values
		sums<-aggregate(ffs$value, list(s=ffs$source), sum)	# Sum of flows from each source
		fails<-sums[sums$x>1.00001,]	# All compartments > 1
	} else { fails<-data.frame(s=character(0), x=numeric(0)) }
	return(fails)
}

Contact - Imprint