checkINSPEcTObjectversion <- function(object, returnLogical=FALSE) {
# objects from 1.17.11 has the slot, therefore this contol detect as obsoletes objects from 1.17.10
# In case there will be the need to check for a specific version, use somthing as follows:
# > ver <- package_version(object@version)
# > if (ver < "1.18") stop()
# > OR if (ver$major < 2) stop()
# > OR if (ver$major < 1 & ver$minor < 18) stop()
if( !.hasSlot(object, 'version') ) {
if( returnLogical ) {
return(FALSE)
} else {
stop("This object is OBSOLETE and cannot work with the current version of INSPEcT.")
}
} else {
if( returnLogical ) return(TRUE)
}
}
#######################################
# generation of the simulated dataset ###
########################################
sampleNormQuantile <- function(values_subject
, dist_subject
, dist_object, na.rm=FALSE
, quantiles=100)
# sample values from the distribution OBJECT given that some values of the
# distribution SUBJECT are known.
{
quantileMeanVar <- function(dist_subject, dist_object=NULL, na.rm=FALSE, quantiles)
# for each quantile of the distribution SUBJECT gives back
# the mean and the standard deviation of distribution OBJECT
{
if( is.null(dist_object))
dist_object <- dist_subject
idx <- .which.quantile(values=dist_subject, na.rm=na.rm,
quantiles=quantiles)
distMean <- tapply(dist_object, idx, mean)
distVar <- tapply(dist_object, idx, stats::var)
return(cbind(mean=distMean, var=distVar))
}
## linearize the time-course matrices into vectors of values
dist_subject <- c(dist_subject)
dist_object <- c(dist_object)
if( na.rm ) {
tokeep <- is.finite(dist_subject) & is.finite(dist_object)
dist_subject <- dist_subject[tokeep]
dist_object <- dist_object[tokeep]
}
## number of quantile can't be too large in order that each quantile
## can host al least 4 elements
quantiles <- min(quantiles, floor(length(dist_subject)/4))
## sample the values
idx <- .which.quantile(
values = values_subject
, distribution = dist_subject
, quantiles = quantiles
, na.rm = na.rm
)
qmv <- quantileMeanVar(
dist_subject = dist_subject
, dist_object = dist_object
, quantiles = quantiles
, na.rm = na.rm
)
values_object <- rep(NA, length(values_subject))
for(i in 1:quantiles)
{
nobjects <- length(which(idx==i))
if(nobjects!=0){
values_object[idx==i] <- rnorm(
nobjects
, mean=qmv[as.character(i),'mean']
, sd=sqrt(qmv[as.character(i),'var'])
)
}
}
return(values_object)
}
sampleNorm2DQuantile <- function(values_subject1
, values_subject2
, dist_subject1
, dist_subject2
, dist_object
, na.rm=FALSE
, quantiles=10)
# sample values from the distribution OBJECT given that some values odf the
# distribution SUBJECT are known.
{
dist_subject1 <- c(dist_subject1)
dist_subject2 <- c(dist_subject2)
dist_object <- c(dist_object)
if( na.rm ) {
tokeep <- is.finite(dist_subject1) & is.finite(dist_subject2) &
is.finite(dist_object)
dist_subject1 <- dist_subject1[tokeep]
dist_subject2 <- dist_subject2[tokeep]
dist_object <- dist_object[tokeep]
}
## number of quantile can't be too large in order that each quantile
## can host al least 4 elements
quantiles <- min(quantiles, floor(sqrt(length(dist_subject1)/4)))
##
idx1 <- .which.quantile(values_subject1, dist_subject1,
na.rm=na.rm, quantiles=quantiles)
idx2 <- .which.quantile(values_subject2, dist_subject2,
na.rm=na.rm, quantiles=quantiles)
quantile2DMeanVar <- function(dist_subject1
, dist_subject2
, dist_object
, na.rm=FALSE
, quantiles=100)
# for each quantile of the distribution SUBJECT1 and SUBJECT2 gives
# back the mean and the standard deviation of distribution OBJECT.
# Returns the two square matrices of mean and variance corresponding
# to each pair of quantiles of SUBJECT1 and SUBJECT2.
{
idx1 <- .which.quantile(dist_subject1, na.rm=na.rm, quantiles=quantiles)
idx2 <- .which.quantile(dist_subject2, na.rm=na.rm, quantiles=quantiles)
meansTab <- matrix(NA, nrow=quantiles, ncol=quantiles)
varsTab <- matrix(NA, nrow=quantiles, ncol=quantiles)
for(i1 in unique(idx1))
{
for(i2 in unique(idx2))
{
# belonging to either quantiles
ix <- idx1 == i1 & idx2 == i2
meansTab[i1,i2] <- mean(dist_object[ix])
varsTab[i1,i2] <- stats::var(dist_object[ix])
}
}
# fill the missing values
na.fill <- function(mat)
# Fill the NA values of a matrix with the mean of the surroundings.
# Iterates until all the missing values are filled.
{
if( all(is.na(mat))) return(mat)
nRow <- nrow(mat)
nCol <- ncol(mat)
while(length(which(is.na(mat))) > 0){
for(i in 1:nrow(mat)){
for(j in 1:ncol(mat)){
if( is.na(mat[i,j]))
{
idx_top <- max(1,i-1)
idx_bottom <- min(nRow,i+1)
idx_left <- max(1,j-1)
idx_right <- min(nCol,j+1)
surroundingRows <- idx_top:idx_bottom
surroundingCols <- idx_left:idx_right
mat[i,j] <- mean(
mat[surroundingRows,surroundingCols],
na.rm=TRUE
)
} } } }
return(mat)
}
meansTab <- na.fill(meansTab)
varsTab <- na.fill(varsTab)
return(list(mean=meansTab,var=varsTab))
}
q2dmv <- quantile2DMeanVar(dist_subject1, dist_subject2, dist_object,
na.rm=na.rm, quantiles=quantiles)
sampledValues <- sapply(1:length(idx1), function(i) {
qtMean <- q2dmv$mean[idx1[i], idx2[i]]
qtVar <- q2dmv$var[idx1[i], idx2[i]]
########## Why not sqrt(qtVar) ?????????????
# changed to sd=sqrt(qtVar), previously was:
# sd=qtVar
return(rnorm(1, mean=qtMean, sd=sqrt(qtVar)))
})
return(sampledValues)
}
grepLogic <- function(text,obj,...){seq_along(obj)%in%grep(text,obj,...)}
# fromImpulseToSigmoid <- function(impulsesParameters,tpts,a,c,nIter)
# {
# impulseProfile <- impulseModel(x=log2(tpts+a)+c,par=impulsesParameters)
# internalError <- function(sigmoidsParameters,impulsesParameters,tpts,a,c)
# {
# impulseProfile <- impulseModel(x=log2(tpts+a)+c,par=impulsesParameters)
# sigmoidProfile <- sigmoidModel(x=log2(tpts+a)+c,par=sigmoidsParameters)
# chisqFunction(experiment=impulseProfile,model=sigmoidProfile,variance=impulseProfile)
# }
# optTmp <- optim(par=c(head(impulseProfile,1),tail(impulseProfile,1),max(log2(tpts+a)+c)/3,1)
# ,internalError
# ,impulsesParameters=impulsesParameters
# ,tpts=tpts
# ,a=a
# ,c=c
# ,control = list(maxit = nIter))
# return(optTmp$par)
# }
findttpar <- function(tpts)
{
cvLogTpts <- function(a , tpts)
{
newtime <- log2(tpts + a )
stats::sd(diff(newtime)) / mean(diff(newtime))
}
if(length(tpts)>2){return(optimize(f=cvLogTpts, interval=c(0,5), tpts=tpts )$minimum)}
else{return(1)}
}
timetransf <- function(t, log_shift, lin_shift = 0)
{
t[ t <= (-log_shift) ] <- NaN
newtime <- log2(t+log_shift) + lin_shift
return(newtime)
}
timetransf_inv <- function(t, log_shift, lin_shift=0) 2^(t - lin_shift) - log_shift
timetransf_NoNascent <- function(t, log_shift, c)
{
newtime <- log2(t+log_shift) + c
return(newtime)
}
chisqFunction <- function(experiment, model, variance=NULL)
{
if( is.null(variance)) variance <- stats::var(experiment)
sum((experiment - model )^2/variance )
}
logLikelihoodFunction <- function(experiment, model, variance=NULL)
{
if( is.null(variance)) variance <- stats::var(experiment)
sum(log(2*pnorm(-abs(experiment-model),mean=0,sd=sqrt(variance))))
}
.emptyGene <- function(error='')
{
emptyRate <- function() return(list(fun=NA, type=NA, df=0, params=NaN))
return(
list(alpha=emptyRate(), beta=emptyRate(), gamma=emptyRate()
, test=NaN, logLik=NaN, AIC=NaN, AICc=NaN, counts=NaN, convergence=1, message=error)
)
}
.makeEmptyModel <- function(tpts) {
model <- matrix(NA, nrow=length(tpts), 5)
colnames(model) <- c('alpha','beta','gamma','preMRNA','total')
as.data.frame(model)
}
.makeModel <- function(tpts, hyp, nascent = FALSE)
{
params <- list()
params$alpha <- function(x)
hyp$alpha$fun$value(x, hyp$alpha$par)
params$beta <- function(x)
hyp$beta$fun$value(x, hyp$beta$par)
params$gamma <- function(x)
hyp$gamma$fun$value(x, hyp$gamma$par)
cinit <- c(params$alpha(tpts[1]) / params$gamma(tpts[1]),
params$alpha(tpts[1]) / params$beta(tpts[1]))
if(nascent){cinit=c(0,0)}
names(cinit) <- c('p', 'm')
model <- as.data.frame(
ode(y=cinit, times=tpts, func=.rxnrate, parms=params))
model$alpha <- params$alpha(tpts)
model$beta <- params$beta(tpts)
model$gamma <- params$gamma(tpts)
colnames(model)[2:3] <- c('preMRNA','mature')
model[,3] <- apply(model[2:3],1,sum)
colnames(model)[2:3] <- c('preMRNA','total')
if(nrow(model)!=length(tpts)){return(matrix(rep(NaN,2*length(tpts)),nrow=tpts,ncol=2))}
return(model)
}
.rxnrate <- function(t,c,parms){
# rate constant passed through a list called parms
alpha <- parms$alpha
beta <- parms$beta
gamma <- parms$gamma
# derivatives dc/dt are computed below
r=rep(0,length(c))
r[1] <- alpha(t) - gamma(t) * c["p"]
r[2] <- gamma(t) * c["p"] - beta(t) * c["m"]
# c is the concentration of species
# the computed derivatives are returned as a list
# order of derivatives needs to be the same as the order of species in c
return(list(r))
}
.makeSimpleModel <- function(tpts, hyp, log_shift, timetransf, ode, .rxnrateSimple)
{
params <- list()
params$alpha <- function(x)
hyp$alpha$fun$value(timetransf(x, log_shift), hyp$alpha$params)
params$beta <- function(x)
hyp$beta$fun$value(timetransf(x, log_shift), hyp$beta$params)
#
cinit <- c(t = params$alpha(tpts[1]) / params$beta(tpts[1]))
names(cinit) <- 't'
model <- as.data.frame(
ode(y=cinit, times=tpts, func=.rxnrateSimple, parms=params))
model$alpha <- params$alpha(tpts)
model$beta <- params$beta(tpts)
model$gamma <- rep(NA, length(tpts))
model$preMRNA <- rep(NA, length(tpts))
colnames(model)[2] <- 'total'
return(model)
}
.makeEmptySimpleModel <- function(tpts) {
model <- matrix(NA, nrow=length(tpts), 3)
colnames(model) <- c('alpha','beta','total')
as.data.frame(model)
}
.rxnrateSimple <- function(t,c,parms){
# rate constant passed through a list called parms
alpha <- parms$alpha
beta <- parms$beta
# derivatives dc/dt are computed below
r=rep(0,length(c))
r[1] <- alpha(t) - beta(t) * c["t"]
# c is the concentration of species
# the computed derivatives are returned as a list
# order of derivatives needs to be the same as the order of species in c
return(list(r))
}
############### pointer function
newPointer <- function(inputValue){
object=new.env(parent=globalenv())
object$value=inputValue
class(object)='pointer'
return(object)
}
############### constant
constantModel <- function(x , par ) rep(par , length(x) )
constantModelP <- newPointer(constantModel)
############### sigmoid
# cppFunction('
# NumericVector sigmoidModelC(NumericVector x, NumericVector par) {
# int n = x.size();
# NumericVector ans(n);
# for(int i = 0; i < n; i++) {
# ans[i] = par[0]+(par[1]-par[0])*(1/(1+exp(-par[3]*(x[i]-par[2]))));
# }
# return ans;
# }
# ')
# sigmoidModel <- sigmoidModelC
.D2sigmoidModel <- function(x, par) {
h0= par[1]; h1=par[2]; t1=par[3]; b=par[4]
(2*b^2*(h1-h0)*exp(-2*b*(x-t1)))/(exp(-b*(x-t1))+1)^3-(b^2*(h1-h0)*exp(-b*(x-t1)))/(exp(-b*(x-t1))+1)^2
}
sigmoidModel <- function(x, par)
{
# h0= par[1]; h1=par[2]; h2=par[3]; t1=par[4]; t2=par[5]; b=par[6]
par[1]+(par[2]-par[1])*(1/(1+exp(-par[4]*(x-par[3]))))
}
## compiled version
#sigmoidModel <- cmpfun(sigmoidModel)
.DsigmoidModel <- function(x, par)
{
h0= par[1]; h1=par[2]; t1=par[3]; b=par[4]
S= function(b,t) 1/(1+exp(-b*(x-t)))
dSdx= function(b,t) b/(1/exp(-b*(x-t)) + 2 + exp(-b*(x-t)) )
s= function(x,t,h,b) h+(h1-h)*S(b,t)
dsdx= function(x,t,h,b) (h1-h)*dSdx(b,t)
1/h1*dsdx(x,t1,h0,b)
}
# 'pointer' for the sigmoidModel function
sigmoidModelP <- newPointer(sigmoidModel)
############### impulse
# cppFunction('
# NumericVector impulseModelC(NumericVector x, NumericVector par) {
# int n = x.size();
# NumericVector ans(n);
# for(int i = 0; i < n; i++) {
# ans[i] = 1/par[1]*(par[0]+(par[1]-par[0])*(1/(1+exp(-par[5]*(x[i]-par[3])))))*(par[2]+(par[1]-par[2])*(1/(1+exp(par[5]*(x[i]-par[4])))));
# }
# return ans;
# }
# ')
# impulseModel <- impulseModelC
impulseModel <- function(x, par)
{
# h0= par[1]; h1=par[2]; h2=par[3]; t1=par[4]; t2=par[5]; b=par[6]
1/par[2]*(par[1]+(par[2]-par[1])*(1/(1+exp(-par[6]*(x-par[4])))))*
(par[3]+(par[2]-par[3])*(1/(1+exp(par[6]*(x-par[5])))))
}
## compiled version
#impulseModel <- cmpfun(impulseModel)
.DimpulseModel <- function(x, par)
{
h0= par[1]; h1=par[2]; h2=par[3]; t1=par[4]; t2=par[5]; b=par[6]
S= function(b,t) 1/(1+exp(-b*(x-t)))
dSdx= function(b,t) b/(1/exp(-b*(x-t)) + 2 + exp(-b*(x-t)) )
s= function(x,t,h,b) h+(h1-h)*S(b,t)
dsdx= function(x,t,h,b) (h1-h)*dSdx(b,t)
1/h1*(dsdx(x,t1,h0,b)*s(x,t2,h2,-b) + s(x,t1,h0,b)*dsdx(x,t2,h2,-b) )
}
# 'pointer' for the impulseModel function
impulseModelP <- newPointer(impulseModel)
.D2impulseModel <- function(t, par) {
h0= par[1]; h1=par[2]; h2=par[3]; t1=par[4]; t2=par[5]; b=par[6]
-(2*b^2*(h1-h0)*(h1-h2)*exp(b*(t-t2)-b*(t-t1)))/(h1*(exp(-b*(t-t1))+1)^2*(exp(b*(t-t2))+1)^2)+((h1-h2)*((2*b^2*exp(2*b*(t-t2)))/(exp(b*(t-t2))+1)^3-(b^2*exp(b*(t-t2)))/(exp(b*(t-t2))+1)^2)*((h1-h0)/(exp(-b*(t-t1))+1)+h0))/h1+((h1-h0)*((2*b^2*exp(-2*b*(t-t1)))/(exp(-b*(t-t1))+1)^3-(b^2*exp(-b*(t-t1)))/(exp(-b*(t-t1))+1)^2)*((h1-h2)/(exp(b*(t-t2))+1)+h2))/h1
}
############### polynomial
.polynomialModel <- function(x, par)
sapply(x, function(x_i)
sum(sapply(1:length(par), function(i) x_i^(i-1) * par[i])))
.polynomialModelP <- newPointer(.polynomialModel)
############### oscillatory model
oscillatoryModel <- function(x, par)
{
freq = par[1]
initial_value = par[2]
amplitude = par[3]
x_shift = par[4]
initial_value + initial_value * amplitude * sin(freq * (x - x_shift))
}
oscillatoryModelP <- newPointer(oscillatoryModel)
# .chooseModel <- function(tpts, log_shift, experiment, variance=NULL, na.rm=TRUE
# , sigmoid=TRUE, impulse=TRUE, polynomial=TRUE, nInit=10, nIter=500
# , timetransf, impulseModel, sigmoidModel, sigmoidModelP, impulseModelP
# , .polynomialModelP)
# #### choose a functional form between impulse and sigmoid according
# #### to the one that has the gratest pvalue in the chi squared test
# {
# chisq.test.default <- function(experiment, model, variance=NULL, df)
# {
# if( is.null(variance) ) variance <- stats::var(experiment )
# D = chisqFunction(experiment, model, variance)
# modelDF <- max(0, length(experiment)-df)
# pchisq(D, modelDF, lower.tail=TRUE)
# }
# optimFailOut <- function(e)
# list(par=NA, value=NA, counts=NA, convergence=1, message=e)
# #
# # impulse model functions
# #
# im.parguess <- function(tpts , values ) {
# # values = expressions.avgd(eD)
# # tp = tpts(eD)
# ntp <- length(tpts)
# peaks <- which(diff(sign(diff(values)))!=0)+1
# if( length(peaks) == 1 ) peak <- peaks
# if( length(peaks) > 1 ) peak <- sample(peaks, 1)
# if( length(peaks) == 0 ) peak <- round(length(tpts)/2)
# #
# initial_values <- runif( 1, min=min(values[1:3])
# , max=max(values[1:3]))
# intermediate_values <- values[peak]
# if( intermediate_values==0 ) intermediate_values <- mean(values[seq(peak-1,peak+1)])
# end_values <- runif( 1, min=min(values[(ntp-2):ntp])
# , max=max(values[(ntp-2):ntp]))
# time_of_first_response <- tpts[peak-1]
# time_of_second_response <- tpts[peak+1]
# slope_of_response <- diff(range(tpts)) /
# (time_of_second_response-time_of_first_response)
# #
# return(c(h0=initial_values, h1=intermediate_values
# , h2=end_values, t1=time_of_first_response
# , t2=time_of_second_response, b=slope_of_response))
# }
# #
# im.chisq <- function(par, tpts, experiment, variance=NULL, impulseModel)
# {
# model <- impulseModel(tpts, par)
# chisqFunction(experiment, model, variance)
# }
# #
# im.optim.chisq <- function(tpts, experiment, variance=NULL, ninit=10
# , maxit=500)
# sapply(1:ninit, function(x)
# tryCatch(optim(
# par=im.parguess(tpts, experiment)
# , fn=im.chisq, tpts=tpts
# , experiment=experiment
# , variance=variance
# , impulseModel=impulseModel
# , control=list(maxit=maxit)
# ), error=function(e) optimFailOut(e)))
# #
# # sigmoid model functions
# #
# sm.parguess <- function(tpts , values ) {
# # values = expressions.avgd(eD)
# # tp = tpts(eD)
# time_span <- diff(range(tpts))
# # sample the time uniformely
# time_of_response <- runif( 1, min=min(tpts), max=max(tpts))
# # slope of response must be high if the time of response is close to one
# # of the two boundaries
# distance_from_boundary <- min(time_of_response - min(tpts)
# , max(tpts) - time_of_response)
# slope_of_response <- time_span / distance_from_boundary
# ntp <- length(tpts)
# initial_values <- runif( 1, min=min(values[1:3])
# , max=max(values[1:3]))
# end_values <- runif( 1, min=min(values[(ntp-2):ntp])
# , max=max(values[(ntp-2):ntp]))
# #
# return(c(h0=initial_values, h1=end_values, t1=time_of_response
# , b=slope_of_response))
# }
# #
# sm.chisq <- function(par, tpts, experiment, variance=NULL, sigmoidModel)
# {
# model <- sigmoidModel(tpts, par)
# chisqFunction(experiment, model, variance)
# }
# #
# sm.optim.chisq <- function(tpts, experiment, variance=NULL, ninit=10
# , maxit=500)
# sapply(1:ninit, function(x)
# tryCatch(optim(
# par=sm.parguess(tpts, experiment)
# , fn=sm.chisq, tpts=tpts
# , experiment=experiment
# , variance=variance
# , sigmoidModel=sigmoidModel
# , control=list(maxit=maxit)
# ), error=function(e) optimFailOut(e)))
# pn.optim.aic <- function(tpts , experiment, variance=NULL) {
# if( length(experiment) < 3 ) return(NA)
# polyOrderChisq <- function(i) {
# model <- lm(experiment~poly(tpts, i, raw=TRUE ))
# return(list(par=model$coeff, value=AIC(model)))}
# return(sapply(1:min(7,length(tpts)-2), polyOrderChisq))
# }
# # remove missing values
# if( na.rm) {
# idx <- is.finite(experiment)
# tpts <- tpts[idx]
# experiment <- experiment[idx]
# }
# ##
# if( length(experiment)==0 ) {
# stop('.chooseModel: no time points have a finite value.
# Impossible to evaluate any kind of model.')
# return(list(type='constant', fun=constantModelP
# , params=mean(experiment, na.rm=TRUE), pval=NA, df=1))
# }
# ##
# if( length(experiment)<=2 ) {
# warning('.chooseModel: less than three time points have a finite value.
# Impossible evaluate a variable model.
# Returning a constant model.')
# return(list(type='constant', fun=constantModelP
# , params=mean(experiment, na.rm=TRUE), pval=NA, df=1))
# }
# ## re-evaluate flags of function to evaluate according to the lenght
# ## of the experiment
# sigmoid <- sigmoid
# impulse <- impulse & length(experiment)>2
# polynomial <- polynomial & length(experiment)>2
# tptslog <- timetransf(tpts, log_shift)
# # sigmoid
# if( sigmoid ) {
# outSM <- sm.optim.chisq(tpts=tptslog, experiment=experiment
# , variance=variance, ninit=nInit, maxit=nIter)
# bestSM <- which.min(unlist(outSM[2,]))
# pvalSM <- chisq.test.default(experiment=experiment
# , model=sigmoidModel(tptslog, outSM[,bestSM]$par)
# , variance=variance, df=length(outSM[,bestSM]$par))
# dfSM <- length(outSM[,bestSM]$par)
# } else dfSM <- NA
# # impulse
# if( impulse ) {
# outIM <- im.optim.chisq(tpts=tptslog, experiment=experiment,
# variance=variance, ninit=nInit, maxit=nIter)
# bestIM <- which.min(unlist(outIM[2,]))
# pvalIM <- chisq.test.default(experiment=experiment
# , model=impulseModel(tptslog, outIM[,bestIM]$par)
# , variance=variance, df=length(outIM[,bestIM]$par))
# dfIM <- length(outIM[,bestIM]$par)
# } else dfIM <- NA
# # polynomial
# if( polynomial ) {
# outPN <- pn.optim.aic(tptslog, experiment, variance )
# bestPN <- which.min(unlist(outPN[2,]))
# pvalPN <- chisq.test.default(experiment=experiment
# , model=.polynomialModel(tptslog, outPN[,bestPN]$par)
# , variance=variance, df=length(outPN[,bestPN]$par))
# dfPN <- length(outPN[,bestPN]$par)
# } else dfPN <- NA
# pvals <- c(
# sigmoid=if( sigmoid ) pvalSM else NA
# , impulse=if( impulse ) pvalIM else NA
# , polynomial=if( polynomial ) pvalPN else NA
# )
# funcs <- c(sigmoidModelP, impulseModelP, .polynomialModelP)
# dfs <- c(dfSM, dfIM, dfPN)
# type <- names(pvals)[which.min(pvals)]
# df <- dfs[which.min(pvals)]
# if( type=='sigmoid' ) params <- outSM[,bestSM]$par
# if( type=='impulse' ) params <- outIM[,bestIM]$par
# if( type=='polynomial' ) params <- outPN[,bestPN]$par
# pval <- pvals[which.min(pvals)]
# fun <- funcs[[which.min(pvals)]]
# return(list(type=type, fun=fun , params=params, pval=pval, df=df))
# }
####################################################################################################k1KKK_NoNascent <- function(x, par){par[1]*par[3]}
fitSmooth <- function(tpts
, tt_c
, experiment
, variance
, nInit=20
, nIter=500
, mature = FALSE
, seed = NULL)
{
im_parguess <- function(tpts , values) {
ntp <- length(tpts)
peaks <- which(diff(sign(diff(values)))!=0)+1
if( length(peaks) == 1 ) peak <- peaks
if( length(peaks) > 1 ) peak <- sample(peaks, 1)
if( length(peaks) == 0 ) peak <- round(length(tpts)/2)
initial_values <- runif( 1, min=min(values[1:3]), max=max(values[1:3]))
intermediate_values <- values[peak]
if( intermediate_values==0 ) intermediate_values <- mean(values[seq(peak-1,peak+1)])
end_values <- runif( 1, min=min(values[(ntp-2):ntp]), max=max(values[(ntp-2):ntp]))
time_of_first_response <- tpts[peak-1]
time_of_second_response <- tpts[peak+1]
slope_of_response <- 1
par <- c(h0=initial_values
,h1=intermediate_values
,h2=end_values
,t1=time_of_first_response
,t2=time_of_second_response
,b=slope_of_response)
return(unlist(unname(par)))
}
im_chisq_mature <- function(par, tpts, experiment, variance=NULL, tt_c)
{
model <- impulseModel(tpts,par)
if( abs(par[6]) > Inf ) return(NaN)
if( any(model < 0) ) return(NaN)
chisqFunction(experiment, model, variance)
}
im_chisq <- function(par, tpts, experiment, variance=NULL, tt_c)
{
model <- impulseModel(tpts,par)
if( any(model < 0) ) return(NaN)
chisqFunction(experiment, model, variance)
}
if(is.numeric(seed)) set.seed(seed)
outIM <- sapply(1:nInit, function(x)
tryCatch(optim(
par=im_parguess(tpts, experiment)
, fn=if(mature) im_chisq_mature else im_chisq
, tpts=tpts
, experiment=experiment
, variance=variance
, tt_c = tt_c
, control=list(maxit=nIter)
), error=function(e) list(par=NA
, value=NA
, counts=NA
, convergence=1, message=e)))
bestIM <- which.min(unlist(outIM[2,]))
unlist(outIM[,bestIM])
}
prematureKKK_Int_NoNascent <- function(x, parameters)
{
matureParameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
return((k3Parameters*matureParameters)/k2Parameters)
}
k1KKK_Int_NoNascent <- function(x, par)
{
par[1]*par[3]
}
# systemSolution <- function(k1F,k2F,k3F,times)
# {
# system <- function(t,c,parms)
# {
# alpha <- parms$alpha
# beta <- parms$beta
# gamma <- parms$gamma
# r=rep(0,length(c))
# r[1] <- alpha(t) - beta(t) * c["p"]
# r[2] <- beta(t) * c["p"] - gamma(t) * c["m"]
# return(list(r))
# }
# cinit <- c(k1F(0)/k2F(0),k1F(0)/k3F(0))
# names(cinit) <- c("p","m")
# params <- list(alpha = k1F, beta = k2F, gamma = k3F)
# modData <- ode(y=cinit, times=times, func=system, parms=params)
# modData <- c(modData[,"m"],modData[,"p"])
# names(modData) <- c(rep("mature",length.out = length(times)),rep("premature",length.out = length(times)))
# return(modData)
# }
errorKKK_Int_NoNascent <- function(parameters, tpts, premature, mature, prematureVariance, matureVariance)
{
if(parameters[1]<0)return(NaN)
if(parameters[2]<0)return(NaN)
if(parameters[3]<0)return(NaN)
matureParameters <- parameters[1]
prematureEstimated <- prematureKKK_Int_NoNascent(x = tpts, parameters = parameters)
matureEstimated <- matureParameters
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
return(sum(c(prematureChiSquare,matureChiSquare)))
}
errorVKK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) return(parameters[7])
k3F <- function(x) return(parameters[8])
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) return(parameters[5])
k3F <- function(x) return(parameters[6])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorVKV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) return(parameters[7])
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[8:13])}
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) return(parameters[5])
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[6:9])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
# modelLm <- sapply(times,function(t)k1F(t)/k3F(t)*(1 - exp(-k3F(t)*1/6))+k1F(t)/(k3F(t) - k2F(t))*(exp(-k3F(t)*1/6) - exp(-k2F(t)*1/6)))
# modData <- c(modData, modelLm)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorVVV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==18)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[7:12])}
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[13:18])}
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[5:8])}
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[9:12])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
# modelLm <- sapply(times,function(t)k1F(t)/k3F(t)*(1 - exp(-k3F(t)*1/6))+k1F(t)/(k3F(t) - k2F(t))*(exp(-k3F(t)*1/6) - exp(-k2F(t)*1/6)))
# modData <- c(modData, modelLm)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorKVV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) return(parameters[1])
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[2:7])}
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[8:13])}
}else{
k1F <- function(x) return(parameters[1])
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[2:5])}
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[6:9])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
# modelLm <- sapply(times,function(t)k1F(t)/k3F(t)*(1 - exp(-k3F(t)*1/6))+k1F(t)/(k3F(t) - k2F(t))*(exp(-k3F(t)*1/6) - exp(-k2F(t)*1/6)))
# modData <- c(modData, modelLm)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorVVK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[7:12])}
k3F <- function(x) return(parameters[13])
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[5:8])}
k3F <- function(x) return(parameters[9])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorKVK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x)return(parameters[1])
k2F <- function(x){impulseModel(log2(x+a)+c,parameters[2:7])}
k3F <- function(x)return(parameters[8])
}else{
k1F <- function(x)return(parameters[1])
k2F <- function(x){sigmoidModel(log2(x+a)+c,parameters[2:5])}
k3F <- function(x)return(parameters[6])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
errorKKV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x) return(parameters[1])
k2F <- function(x) return(parameters[2])
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[3:8])}
}else{
k1F <- function(x) return(parameters[1])
k2F <- function(x) return(parameters[2])
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[3:6])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
chi2 <- chisqFunction(data,modData,datavar)
return(chi2)
}
loglikKKK_Int_NoNascent <- function(parameters
,tpts
,premature
,mature
,prematureVariance
,matureVariance)
{
matureParameters <- parameters[1]
prematureEstimated <- prematureKKK_Int_NoNascent(x = tpts, parameters = parameters)
matureEstimated <- matureParameters
logLikelihoodFunction(premature, prematureEstimated, prematureVariance) +
logLikelihoodFunction(mature, matureEstimated, matureVariance)
}
loglikVKK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) return(parameters[7])
k3F <- function(x) return(parameters[8])
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) return(parameters[5])
k3F <- function(x) return(parameters[6])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
loglikKVK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x)return(parameters[1])
k2F <- function(x){impulseModel(log2(x+a)+c,parameters[2:7])}
k3F <- function(x)return(parameters[8])
}else{
k1F <- function(x)return(parameters[1])
k2F <- function(x){sigmoidModel(log2(x+a)+c,parameters[2:5])}
k3F <- function(x)return(parameters[6])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
# modelLm <- sapply(times,function(t)k1F(t)/k3F(t)*(1 - exp(-k3F(t)*1/6))+k1F(t)/(k3F(t) - k2F(t))*(exp(-k3F(t)*1/6) - exp(-k2F(t)*1/6)))
# modData <- c(modData, modelLm)
logLikelihoodFunction(data, modData, datavar)
}
loglikKKV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==8)
{
k1F <- function(x) return(parameters[1])
k2F <- function(x) return(parameters[2])
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[3:8])}
}else{
k1F <- function(x) return(parameters[1])
k2F <- function(x) return(parameters[2])
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[3:6])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
loglikVVK_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[7:12])}
k3F <- function(x) return(parameters[13])
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[5:8])}
k3F <- function(x) return(parameters[9])
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
loglikVKV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) return(parameters[7])
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[8:13])}
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) return(parameters[5])
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[6:9])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
loglikKVV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==13)
{
k1F <- function(x) return(parameters[1])
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[2:7])}
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[8:13])}
}else{
k1F <- function(x) return(parameters[1])
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[2:5])}
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[6:9])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
loglikVVV_Int_NoNascent <- function(parameters, times, data, datavar, a, c)
{
if(length(parameters)==18)
{
k1F <- function(x) {impulseModel(log2(x+a)+c,parameters[1:6])}
k2F <- function(x) {impulseModel(log2(x+a)+c,parameters[7:12])}
k3F <- function(x) {impulseModel(log2(x+a)+c,parameters[13:18])}
}else{
k1F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[1:4])}
k2F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[5:8])}
k3F <- function(x) {sigmoidModel(log2(x+a)+c,parameters[9:12])}
}
if( any(c(k1F(times),k2F(times),k3F(times))<0) ) return(NaN)
modData <- systemSolution(k1F,k2F,k3F,times)
logLikelihoodFunction(data, modData, datavar)
}
###########################################################################
k1VKK_Der_NoNascent <- function(x, par, c)
{
t_fact <- 2^(x-c)*log(2)
.D2impulseModel(x, par[1:6])*t_fact^2/par[7] + .DimpulseModel(x, par[1:6])*(1+par[8]/par[7])*t_fact + par[8]*impulseModel(x, par[1:6])
}
prematureVKK_Der_NoNascent <- function(x, parameters, c)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8]
t_fact <- 2^(x-c)*log(2)
(.DimpulseModel(x, matureParameters)*t_fact + k3Parameters * impulseModel(x, matureParameters))/k2Parameters
}
errorVKK_Der_NoNascent <- function(parameters
,tpts
,premature
,mature
,prematureVariance
,matureVariance
,c)
{
matureParameters <- parameters[1:6]
if( abs(matureParameters[6]) > Inf ) return(NaN)
D2 <- .D2impulseModel(tpts,matureParameters)
k1 <- k1VKK_Der_NoNascent(tpts,parameters, c)
prematureEstimated <- prematureVKK_Der_NoNascent(x = tpts, parameters = parameters, c = c)
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
if( any(is.na(D2)) | any(k1<0) | any(prematureEstimated<0) | any(matureEstimated<0) ) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
return(sum(c(prematureChiSquare,matureChiSquare)))
}
k1VVK_Der_NoNascent <- function(x, par, c)
{
t_fact <- 2^(x-c)*log(2)
.D2impulseModel(x, par[1:6])/impulseModel(x, par[7:12])*t_fact^2 +
.DimpulseModel(x, par[1:6])*t_fact*(1 - log(2)*.DimpulseModel(x, par[7:12])/impulseModel(x, par[7:12])^2 + par[13]/impulseModel(x, par[7:12])) +
log(2)*impulseModel(x, par[1:6])*(par[13]/log(2) - (par[13]*.DimpulseModel(x, par[7:12]))/impulseModel(x, par[7:12])^2 )
}
prematureVVK_Der_NoNascent <- function(x, parameters, c)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13]
t_fact <- 2^(x-c)*log(2)
return((.DimpulseModel(x, matureParameters)*t_fact
+ k3Parameters * impulseModel(x, matureParameters))/impulseModel(x, k2Parameters))
}
errorVVK_Der_NoNascent <- function(parameters
,tpts
,premature
,mature
,prematureVariance
,matureVariance
,c)
{
matureParameters <- parameters[1:6]
if( abs(matureParameters[6]) > Inf ) return(NaN)
if( abs(parameters[12]) > Inf ) return(NaN)
D2 <- .D2impulseModel(tpts,matureParameters)
k1 <- k1VVK_Der_NoNascent(tpts,parameters, c)
prematureEstimated <- prematureVVK_Der_NoNascent(x = tpts, parameters = parameters, c = c)
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
if( any(is.na(D2)) | any(k1<0) | any(prematureEstimated<0) | any(matureEstimated<0) ) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
return(sum(c(prematureChiSquare,matureChiSquare)))
}
k1VKV_Der_NoNascent <- function(x, par, c)
{
t_fact <- 2^(x-c)*log(2)
.D2impulseModel(x, par[1:6])/par[7]*t_fact^2 +
.DimpulseModel(x, par[1:6])*t_fact*(1 + impulseModel(x, par[8:13])/par[7]) +
log(2)*impulseModel(x, par[1:6])*( .DimpulseModel(x, par[8:13])/par[7] + impulseModel(x, par[8:13])/log(2) )
}
prematureVKV_Der_NoNascent <- function(x, parameters, c)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
t_fact <- 2^(x-c)*log(2)
(.DimpulseModel(x, matureParameters)*t_fact + impulseModel(x, k3Parameters) * impulseModel(x, matureParameters))/k2Parameters
}
errorVKV_Der_NoNascent <- function(parameters
,tpts
,premature
,mature
,prematureVariance
,matureVariance
,c)
{
matureParameters <- parameters[1:6]
if( abs(matureParameters[6]) > Inf ) return(NaN)
if( abs(parameters[13]) > Inf ) return(NaN)
D2 <- .D2impulseModel(tpts,matureParameters)
k1 <- k1VKV_Der_NoNascent(tpts,parameters, c)
prematureEstimated <- prematureVKV_Der_NoNascent(x = tpts, parameters = parameters, c = c)
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
if( any(is.na(D2)) | any(k1<0) | any(prematureEstimated<0) | any(matureEstimated<0) ) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
return(sum(c(prematureChiSquare,matureChiSquare)))
}
k1VVV_Der_NoNascent <- function(x, par, c)
{
t_fact <- 2^(x-c)*log(2)
.D2impulseModel(x, par[1:6])/impulseModel(x, par[7:12])*t_fact^2 +
.DimpulseModel(x, par[1:6])*t_fact*(1 - log(2)*.DimpulseModel(x, par[7:12])/impulseModel(x, par[7:12])^2 + impulseModel(x, par[13:18])/impulseModel(x, par[7:12])) +
log(2)*impulseModel(x, par[1:6])*(.DimpulseModel(x, par[13:18])/impulseModel(x, par[7:12]) + impulseModel(x, par[13:18])/log(2) - (impulseModel(x, par[13:18])*.DimpulseModel(x, par[7:12]))/impulseModel(x, par[7:12])^2 )
}
prematureVVV_Der_NoNascent <- function(x, parameters, c)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13:18]
t_fact <- 2^(x-c)*log(2)
return((.DimpulseModel(x, matureParameters)*t_fact
+ impulseModel(x, k3Parameters)*impulseModel(x, matureParameters))/impulseModel(x, k2Parameters))
}
errorVVV_Der_NoNascent <- function(parameters
,tpts
,premature
,mature
,prematureVariance
,matureVariance
,c)
{
matureParameters <- parameters[1:6]
if( abs(matureParameters[6]) > Inf ) return(NaN)
if( abs(parameters[12]) > Inf ) return(NaN)
if( abs(parameters[18]) > Inf ) return(NaN)
D2 <- .D2impulseModel(tpts,matureParameters)
k1 <- k1VVV_Der_NoNascent(tpts,parameters, c)
prematureEstimated <- prematureVVV_Der_NoNascent(x = tpts, parameters = parameters, c = c)
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
if( any(is.na(D2)) | any(k1<0) | any(prematureEstimated<0) | any(matureEstimated<0) ) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
return(sum(c(prematureChiSquare,matureChiSquare)))
}
inferKBetaFromIntegralWithPre <- function(tpts, alpha, total, preMRNA, maxBeta=75, BPPARAM=SerialParam())
####### accurate function for estimating the degradation rates
####### using the solution of the differential equation system under
####### the condtion that degradation rate is constant between two
####### consecutive time points - more stable that using derivatives
####### estimates
{
solveBeta <- function(beta, t0, t1, alpha_t0, alpha_t1, X_t0, X_t1, P_t0, P_t1 )
{
mAlpha <- (alpha_t0 - alpha_t1 ) / (t0 - t1 )
qAlpha <- alpha_t0 - mAlpha * t0
#
mPreMRNA <- (P_t0 - P_t1 ) / (t0 - t1 )
qPreMRNA <- P_t0 - mPreMRNA * t0
#
X_t1 - X_t0 * exp(-beta*(t1-t0)) -
((mAlpha*t1*beta + qAlpha*beta - mAlpha ) / (beta^2 ) - (mAlpha*t0*beta + qAlpha*beta - mAlpha ) * exp(-beta*(t1-t0)) / (beta^2 )) -
beta*((mPreMRNA*t1*beta + qPreMRNA*beta - mPreMRNA ) / (beta^2 ) - (mPreMRNA*t0*beta + qPreMRNA*beta - mPreMRNA ) * exp(-beta*(t1-t0)) / (beta^2 ))
}
bplapply(2:length(tpts), function(j)
lapply(1:nrow(total), function(i) {
tryCatch(
uniroot(solveBeta
, c(1e-5, maxBeta)
, t0 = tpts[j-1]
, t1 = tpts[j]
, alpha_t0 = alpha[i,j-1]
, alpha_t1 = alpha[i,j]
, X_t0 = total[i,j-1]
, X_t1 = total[i,j]
, P_t0 = preMRNA[i,j-1]
, P_t1 = preMRNA[i,j]
)
, error=function(e) return(list(root=NA, estim.prec=NA, error=e))
)})
, BPPARAM=BPPARAM)
}
counts2expressions <- function(counts, widths, libsize) counts*(10^9/(widths[rownames(counts)]%o%libsize))
countVar2expressions <- function(vars, widths, libsize) vars*(10^9/(widths%o%libsize))^2
inferKGammaFromIntegral <- function(tpts, alpha, preMRNA, maxGamma=150, BPPARAM=SerialParam())
####### accurate function for estimating the degradation rates
####### using the solution of the differential equation system under
####### the condtion that processing rate is constant between two
####### consecutive time points - more stable that using derivatives
####### estimates
{
solveFun <- function(beta, t0, t1, alpha_t0, alpha_t1, X_t0, X_t1 )
{
m <- (alpha_t0 - alpha_t1 ) / (t0 - t1 )
q <- alpha_t0 - m * t0
X_t1 - X_t0*exp(-beta*(t1 - t0)) - (
(m*t1*beta + q*beta - m ) / (beta^2) -
(m*t0*beta + q*beta - m ) * exp(-beta*(t1 - t0)) / (beta^2)
)
}
bplapply(2:length(tpts), function(j)
lapply(1:nrow(alpha), function(i) {
tryCatch(
uniroot(solveFun
, c(1e-5, maxGamma)
, t0 = tpts[j-1]
, t1 = tpts[j]
, alpha_t0 = alpha[i,j-1]
, alpha_t1 = alpha[i,j]
, X_t0 = preMRNA[i,j-1]
, X_t1 = preMRNA[i,j]
)
, error=function(e) return(list(root=NA, estim.prec=NA, error=e))
)})
, BPPARAM=BPPARAM)
}
impute_na_tc <- function(tpts, tcdata) {
# impute NA values in a time course data as a linear model between non-NA values
tc_impute_NA_linearmodel <- function(tpts, tcdata) {
for( j in seq_along(tcdata) ) {
if( is.na(tcdata[j]) ) {
lower_boundary_j <- j-1
higher_boundary_j <- j+1
while( is.na(tcdata[higher_boundary_j]) & higher_boundary_j <= length(tcdata) ) {
higher_boundary_j <- higher_boundary_j + 1
}
if( lower_boundary_j > 0 & higher_boundary_j <= length(tcdata) )
if ( is.finite(tcdata[lower_boundary_j]) ) {
x <- tpts[c(lower_boundary_j,higher_boundary_j)]
y <- tcdata[c(lower_boundary_j,higher_boundary_j)]
tcdata[(lower_boundary_j+1):(higher_boundary_j-1)] <- predict(lm(y ~ x),
data.frame(x=tpts[(lower_boundary_j+1):(higher_boundary_j-1)]))
}
}
}
return(tcdata)
}
# impute NA values in a time course from boundary values
tc_impute_NA_boundaries <- function(tcdata) {
forward_direction <- function(tcdata) {
if( is.na(tcdata[1]) & !all(is.na(tcdata)) ) {
lower_boundary_j <- higher_boundary_j <- 1
while( is.na(tcdata[higher_boundary_j] & higher_boundary_j < length(tcdata) ) ) {
higher_boundary_j <- higher_boundary_j + 1
}
tcdata[lower_boundary_j:(higher_boundary_j-1)] <- tcdata[higher_boundary_j]
}
return(tcdata)
}
tcdata <- forward_direction(tcdata)
tcdata <- rev(forward_direction(rev(tcdata)))
return(tcdata)
}
tcdata <- tc_impute_NA_linearmodel(tpts, tcdata)
tcdata <- tc_impute_NA_boundaries(tcdata)
return(tcdata)
}
########## Compare steady state no nascent
standardCurveFitFunction <- function(p,m,err)
{
n_outliers <- function(alpha, x, y, err) {
#Conversion
pi_angle <- alpha * pi/180
#Angular coefficient
coef_ang <- tan(pi_angle)
delta_intercept <- err/cos(pi_angle)
intercept <- median(y,na.rm=TRUE) - coef_ang*median(x,na.rm=TRUE)
outliers <- y > coef_ang * x + intercept + delta_intercept |
y < coef_ang * x + intercept - delta_intercept
length(which(outliers))
}
all_alphas <- seq(-89,90)
all_alphas_outliers <- sapply(all_alphas, function(i) n_outliers(alpha = i, x=log2(p), y=log2(m), err = err))
return(seq(-89,90)[which.min(all_alphas_outliers)])
}
classificationFunction <- function(p,m,alpha,ref=NULL)
{
standardCurveFit <- alpha
classificationTmp <- sapply(rownames(p),function(g)
{
x <- log2(p[g,])
y <- log2(m[g,])
pi_angle <- standardCurveFit * pi/180
coef_ang <- tan(pi_angle)
if(is.null(ref)) {
ref_x <- median(x,na.rm=TRUE)
ref_y <- median(y,na.rm=TRUE)
} else {
ref_x <- x[ref]
ref_y <- y[ref]
}
intercept <- ref_y - coef_ang*ref_x
return(coef_ang * x + intercept)
# return(y - (coef_ang * x + intercept))
})
return(t(classificationTmp))
}
# plotRegressionCurve <- function(premature, mature, alpha, err, main, xlimU, ylimU, smooth=TRUE, outliers=FALSE)
# {
# if(is.matrix(premature)&is.matrix(mature))
# {
# x <- log2(apply(premature,1,median,na.rm=TRUE))
# y <- log2(apply(mature,1,median,na.rm=TRUE))
# }else{
# x <- log2(premature)
# y <- log2(mature)
# }
# pi_angle <- alpha * pi/180
# coef_ang <- tan(pi_angle)
# delta_intercept <- err/cos(pi_angle)
# intercept <- median(y,na.rm=TRUE) - coef_ang*median(x,na.rm=TRUE)
# if(smooth){
# smoothScatter(x,y,xlab="Log2 median premature RNA",ylab="Log2 median mature RNA",main=main)
# abline(intercept,coef_ang,col=2,lw=3)
# abline(intercept + delta_intercept,coef_ang,col=2,lw=3,lty=2)
# abline(intercept - delta_intercept,coef_ang,col=2,lw=3,lty=2)
# }else{
# if(!outliers)
# {
# df <- data.frame(x = x
# , y = y
# , d = densCols(x, y, colramp = colorRampPalette(rev(rainbow(10, end = 4/6))))
# , cyl = rep(15,length(x)))
# p <- ggplot(df) + xlim(xlimU) + ylim(ylimU) +
# geom_point(aes(x, y, col = d), size = 2, shape=df$cyl) +
# scale_color_identity() +
# theme_bw() + labs(x = "Log2 premature RNA", y = "Log2 mature RNA", title = main)+
# geom_abline(intercept = intercept, slope = coef_ang, color="red", size=1.5)+
# geom_abline(intercept = intercept+ delta_intercept,linetype="dashed", slope = coef_ang, color="red", size=1.5)+
# geom_abline(intercept = intercept- delta_intercept,linetype="dashed", slope = coef_ang, color="red", size=1.5)
# message(p)
# }
# if(outliers)
# {
# x <- x[is.finite(x)&is.finite(y)]
# y <- y[names(x)]
# df <- data.frame(x = x, y = y)
# boolTmp <- apply(as.matrix(df),1,function(r)
# {
# as.numeric(r[1])*coef_ang + (intercept + delta_intercept) > as.numeric(r[2]) & as.numeric(r[1]) * coef_ang + (intercept- delta_intercept) < as.numeric(r[2])
# })
# dfT <- data.frame(x=df$x[boolTmp],y=df$y[boolTmp], col = densCols(df$x[boolTmp], df$y[boolTmp], colramp = colorRampPalette(rev(c("gray46","gray88")))))
# dfF <- data.frame(x=df$x[!boolTmp],y=df$y[!boolTmp], col = densCols(df$x[!boolTmp], df$y[!boolTmp], colramp = colorRampPalette(rev(rainbow(10, end = 4/6)))))
# p <- ggplot()
# p <- p + xlim(xlimU) + ylim(ylimU)
# p <- p + geom_point(aes(dfT$x, dfT$y, col = dfT$col), size = 2, shape=15)
# p <- p + geom_point(aes(dfF$x, dfF$y, col = dfF$col), size = 2, shape=15)
# p <- p + scale_color_identity()
# p <- p + labs(x = "Log2 premature RNA", y = "Log2 mature RNA", title = main) +
# geom_abline(intercept = intercept, slope = coef_ang, color="red", size=1.5)+
# geom_abline(intercept = intercept+ delta_intercept,linetype="dashed", slope = coef_ang, color="red", size=1.5)+
# geom_abline(intercept = intercept- delta_intercept,linetype="dashed", slope = coef_ang, color="red", size=1.5)
# p <- p + theme_light()
# message(p)
# }
# }
# }
# optimization with constrain for all parameteres to be positive
optimPositive <- function(par, fn, ...) {
N <- length(par)
ui <- diag(N)
ci <- rep(0, N)
out <- tryCatch(
constrOptim(theta=par, f=fn, grad=NULL, ui=ui, ci=ci, ...),
error=function(e) list(par=rep(NaN, N), value=NaN, counts=c("function"=NaN, gradient=NaN), convergence=NaN, outer.iterations=NaN, barrier.value=NaN)
)
out[names(out)!='message']
}
### Choose among constant, sigmoid and impulsive function ###
.chooseModel <- function(tpts
, experiment
, variance=NULL
, na.rm=TRUE
, sigmoid=TRUE
, impulse=TRUE
, polynomial=TRUE
, nInit=10
, nIter=500
, impulseModel
, sigmoidModel
, sigmoidModelP
, impulseModelP
, .polynomialModelP
, seed = 1
, computeDerivatives = TRUE)
{
if(is.null(seed))seed <- 1
chisq.test.default <- function(experiment, model, variance=NULL, df)
{
if( is.null(variance) ) variance <- stats::var(experiment )
D = chisqFunction(experiment, model, variance)
modelDF <- max(0, length(experiment)-df)
pchisq(D, modelDF, lower.tail=TRUE)
}
optimFailOut <- function(e)
list(par=NA, value=NA, counts=NA, convergence=1, message=e)
#
# impulse model functions
#
im.parguess <- function(tpts , values ) {
# values = expressions.avgd(eD)
# tp = tpts(eD)
ntp <- length(tpts)
peaks <- which(diff(sign(diff(values)))!=0)+1
if( length(peaks) == 1 ) peak <- peaks
if( length(peaks) > 1 ) peak <- sample(peaks, 1)
if( length(peaks) == 0 ) peak <- round(length(tpts)/2)
#
initial_values <- runif( 1, min=min(values[1:3])
, max=max(values[1:3]))
intermediate_values <- values[peak]
if( intermediate_values==0 ) intermediate_values <- mean(values[seq(peak-1,peak+1)])
end_values <- runif( 1, min=min(values[(ntp-2):ntp])
, max=max(values[(ntp-2):ntp]))
time_of_first_response <- tpts[peak-1]
time_of_second_response <- tpts[peak+1]
slope_of_response <- diff(range(tpts)) /
(time_of_second_response-time_of_first_response)
#
return(c(h0=initial_values, h1=intermediate_values
, h2=end_values, t1=time_of_first_response
, t2=time_of_second_response, b=slope_of_response))
}
#
im.chisq <- function(par, tpts, experiment, variance=NULL, impulseModel)
{
model <- impulseModel(tpts, par)
D <- abs(.DimpulseModel(tpts, par))
D2 <- abs(.D2impulseModel(tpts, par))
D0 <- .DimpulseModel(0, par)
if(!is.finite(D0))return(NaN)
if(computeDerivatives)
{
if(all(is.finite(D)) & all(is.finite(D2))) return(chisqFunction(experiment, model, variance)+abs(D0)+max(D)+max(D2))
else(return(NaN))
}else{
return(chisqFunction(experiment, model, variance)+abs(D0))
}
}
#
im.optim.chisq <- function(tpts, experiment, variance=NULL, ninit=10
, maxit=500){
set.seed(seed)
sapply(1:ninit, function(x)
tryCatch(optim(
par=im.parguess(tpts, experiment)
, fn=im.chisq, tpts=tpts
, experiment=experiment
, variance=variance
, impulseModel=impulseModel
, control=list(maxit=maxit)
), error=function(e) optimFailOut(e)))}
#
# sigmoid model functions
#
sm.parguess <- function(tpts , values ) {
# values = expressions.avgd(eD)
# tp = tpts(eD)
time_span <- diff(range(tpts))
# sample the time uniformely
time_of_response <- runif( 1, min=min(tpts), max=max(tpts))
# slope of response must be high if the time of response is close to one
# of the two boundaries
distance_from_boundary <- min(time_of_response - min(tpts)
, max(tpts) - time_of_response)
slope_of_response <- time_span / distance_from_boundary
ntp <- length(tpts)
initial_values <- runif( 1, min=min(values[1:3])
, max=max(values[1:3]))
end_values <- runif( 1, min=min(values[(ntp-2):ntp])
, max=max(values[(ntp-2):ntp]))
#
return(c(h0=initial_values, h1=end_values, t1=time_of_response
, b=slope_of_response))
}
#
sm.chisq <- function(par, tpts, experiment, variance=NULL, sigmoidModel)
{
model <- sigmoidModel(tpts, par)
D <- abs(.DsigmoidModel(tpts, par))
D2 <- abs(.D2sigmoidModel(tpts, par))
D0 <- .DsigmoidModel(0, par)
if(!is.finite(D0))return(NaN)
if(computeDerivatives)
{
if(all(is.finite(D)) & all(is.finite(D2))) return(chisqFunction(experiment, model, variance)+abs(D0)+max(D)+max(D2))
else(return(NaN))
}else{
return(chisqFunction(experiment, model, variance)+abs(D0))
}
}
#
sm.optim.chisq <- function(tpts, experiment, variance=NULL, ninit=10
, maxit=500){
set.seed(seed)
sapply(1:ninit, function(x)
tryCatch(optim(
par=sm.parguess(tpts, experiment)
, fn=sm.chisq, tpts=tpts
, experiment=experiment
, variance=variance
, sigmoidModel=sigmoidModel
, control=list(maxit=maxit)
), error=function(e) optimFailOut(e)))
}
pn.optim.aic <- function(tpts , experiment, variance=NULL) {
if( length(experiment) < 3 ) return(NA)
polyOrderChisq <- function(i) {
model <- lm(experiment~poly(tpts, i, raw=TRUE ))
return(list(par=model$coeff, value=AIC(model)))}
return(sapply(1:min(7,length(tpts)-2), polyOrderChisq))
}
# remove missing values
if( na.rm) {
idx <- is.finite(experiment)
tpts <- tpts[idx]
experiment <- experiment[idx]
}
##
if( length(experiment)==0 ) {
stop('.chooseModel: no time points have a finite value.
Impossible to evaluate any kind of model.')
return(list(type='constant', fun=constantModelP
, params=mean(experiment, na.rm=TRUE), pval=NA, df=1))
}
##
if( length(experiment)<=2 ) {
warning('.chooseModel: less than three time points have a finite value.
Impossible evaluate a variable model.
Returning a constant model.')
return(list(type='constant', fun=constantModelP
, params=mean(experiment, na.rm=TRUE), pval=NA, df=1))
}
## re-evaluate flags of function to evaluate according to the length
## of the experiment
sigmoid <- sigmoid
impulse <- impulse & length(experiment)>2
polynomial <- polynomial & length(experiment)>2
# sigmoid
if( sigmoid ) {
outSM <- sm.optim.chisq(tpts=tpts, experiment=experiment
, variance=variance, ninit=nInit, maxit=nIter)
bestSM <- which.min(unlist(outSM[2,]))
pvalSM <- tryCatch(chisq.test.default(experiment=experiment
, model=sigmoidModel(tpts, outSM[,bestSM]$par)
, variance=variance, df=length(outSM[,bestSM]$par)),error=function(e)NaN)
dfSM <- length(outSM[,bestSM]$par)
} else dfSM <- NA
# impulse
if( impulse ) {
outIM <- im.optim.chisq(tpts=tpts, experiment=experiment,
variance=variance, ninit=nInit, maxit=nIter)
bestIM <- which.min(unlist(outIM[2,]))
pvalIM <- tryCatch(chisq.test.default(experiment=experiment
, model=impulseModel(tpts, outIM[,bestIM]$par)
, variance=variance, df=length(outIM[,bestIM]$par)),error=function(e)NaN)
dfIM <- length(outIM[,bestIM]$par)
} else dfIM <- NA
# polynomial
if( polynomial ) {
outPN <- pn.optim.aic(tpts, experiment, variance )
bestPN <- which.min(unlist(outPN[2,]))
pvalPN <- tryCatch(chisq.test.default(experiment=experiment
, model=.polynomialModel(tpts, outPN[,bestPN]$par)
, variance=variance, df=length(outPN[,bestPN]$par)),error=function(e)NaN)
dfPN <- length(outPN[,bestPN]$par)
} else dfPN <- NA
pvals <- c(
sigmoid=if( sigmoid ) pvalSM else NA
, impulse=if( impulse ) pvalIM else NA
, polynomial=if( polynomial ) pvalPN else NA
)
# if(pvals["impulse"]>0.05&is.finite(pvals["sigmoid"])){pvals["impulse"] <- NA} # I prefer the sigmoid function if the impulse is not good enough
funcs <- c(sigmoidModelP, impulseModelP, .polynomialModelP)
dfs <- c(dfSM, dfIM, dfPN)
type <- names(pvals)[which.min(pvals)]
df <- dfs[which.min(pvals)]
if( type=='sigmoid' ) params <- outSM[,bestSM]$par
if( type=='impulse' ) params <- outIM[,bestIM]$par
if( type=='polynomial' ) params <- outPN[,bestPN]$par
pval <- pvals[which.min(pvals)]
fun <- funcs[[which.min(pvals)]]
return(list(type=type, fun=fun , params=params, pval=pval, df=df))
}
### Numerical solution of the complete ODE system both for unlabled and labled RNA ###
systemSolution <- function(k1F,k2F,k3F,times,nascent=FALSE)
{
system <- function(t,c,parms)
{
alpha <- parms$alpha
beta <- parms$beta
gamma <- parms$gamma
r=rep(0,length(c))
r[1] <- alpha(t) - beta(t) * c["p"]
r[2] <- beta(t) * c["p"] - gamma(t) * c["m"]
return(list(r))
}
if(nascent){cinit <- c(0,0)}else{cinit <- c(k1F(0)/k2F(0),k1F(0)/k3F(0))}
names(cinit) <- c("p","m")
params <- list(alpha = k1F, beta = k2F, gamma = k3F)
modData <- ode(y=cinit, times=times, func=system, parms=params)
modData <- c(modData[,"m"],modData[,"p"])
if(length(modData)!=2*length(times)){modData <- rep(NaN,2*length(times))}
names(modData) <- c(rep("mature",length.out = length(times)),rep("premature",length.out = length(times)))
return(modData)
}
systemSolution_Simple <- function(k1F,k3F,times,nascent=FALSE)
{
system <- function(t,c,parms)
{
alpha <- parms$alpha
gamma <- parms$gamma
r=rep(0,length(c))
r[1] <- alpha(t) - gamma(t) * c["t"]
return(list(r))
}
if(nascent){cinit <- 0}else{cinit <- k1F(0)/k3F(0)}
names(cinit) <- c("t")
params <- list(alpha = k1F, gamma = k3F)
modData <- ode(y=cinit, times=times, func=system, parms=params)
modData <- c(modData[,"t"])
### POSSIBLE REQUEST FOR A CHECK LIKE:
#
# if(length(modData)!=2*length(times)){modData <- rep(NaN,2*length(times))}
names(modData) <- rep("total",length.out = length(times))
return(modData)
}
### Genesis of an object reporting expression data, kinetic rates and the temporal profile ###
.makeModel_Derivative <- function(tpts, hyp, geneBestModel)
{
if(!any(geneBestModel %in% c("b","c","bc")))
{
params <- list()
params$mature <- function(x)
hyp$mature$fun$value(x, hyp$mature$par)
params$beta <- function(x)
hyp$beta$fun$value(x, hyp$beta$par)
params$gamma <- function(x)
hyp$gamma$fun$value(x, hyp$gamma$par)
matureTemp <- params$mature(tpts)
k2Temp <- params$gamma(tpts)
k3Temp <- params$beta(tpts)
if(geneBestModel == "0")
{
prematureTemp <- sapply(tpts,function(t)prematureKKK_Der(t,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params)))
k1Temp <- sapply(tpts,function(t)k1KKK_Der(t,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params)))
}else if(geneBestModel == "a")
{
prematureTemp <- prematureVKK_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
k1Temp <- k1VKK_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
}else if(geneBestModel == "ac")
{
prematureTemp <- prematureVVK_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
k1Temp <- k1VVK_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
}else if(geneBestModel == "ab")
{
prematureTemp <- prematureVKV_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
k1Temp <- k1VKV_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
}else if(geneBestModel == "abc")
{
prematureTemp <- prematureVVV_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
k1Temp <- k1VVV_Der(tpts,c(hyp$mature$params,hyp$gamma$params,hyp$beta$params))
}
totalTemp <- matureTemp + prematureTemp
}
if(geneBestModel == "b")
{
params <- list()
params$total <- function(x)
hyp$total$fun$value(x, hyp$total$par)
params$alpha <- function(x)
hyp$alpha$fun$value(x, hyp$alpha$par)
params$gamma <- function(x)
hyp$gamma$fun$value(x, hyp$gamma$par)
totalTemp <- params$total(tpts)
prematureTemp <- sapply(tpts, function(t) prematureKKV_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$gamma$params)))
k1Temp <- params$alpha(tpts)
k2Temp <- params$gamma(tpts)
k3Temp <- sapply(tpts, function(t) k3KKV_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$gamma$params)))
}else if(geneBestModel == "c"){
params <- list()
params$total <- function(x)
hyp$total$fun$value(x, hyp$total$par)
params$alpha <- function(x)
hyp$alpha$fun$value(x, hyp$alpha$par)
params$beta <- function(x)
hyp$beta$fun$value(x, hyp$beta$par)
totalTemp <- params$total(tpts)
prematureTemp <- sapply(tpts, function(t) prematureKVK_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$beta$params)))
k1Temp <- params$alpha(tpts)
k3Temp <- params$beta(tpts)
k2Temp <- sapply(tpts, function(t) k2KVK_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$beta$params)))
}else if(geneBestModel == "bc"){
params <- list()
params$total <- function(x)
hyp$total$fun$value(x, hyp$total$par)
params$alpha <- function(x)
hyp$alpha$fun$value(x, hyp$alpha$par)
params$beta <- function(x)
hyp$beta$fun$value(x, hyp$beta$par)
totalTemp <- params$total(tpts)
prematureTemp <- sapply(tpts, function(t) prematureKVV_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$beta$params)))
k1Temp <- params$alpha(tpts)
k3Temp <- params$beta(tpts)
k2Temp <- sapply(tpts, function(t) k2KVV_Der(t, c(hyp$total$params,hyp$alpha$params,hyp$beta$params)))
}
data.frame(time = tpts
, preMRNA = prematureTemp
, total = totalTemp
, alpha = k1Temp
, beta = k3Temp
, gamma = k2Temp)
}
# .makeModel_Derivative_Simple <- function(tpts, hyp, geneBestModel)
# {
# if(geneBestModel != "b")
# {
# params <- list()
# params$total <- function(x)
# hyp$total$fun$value(x, hyp$total$par)
# params$beta <- function(x)
# hyp$beta$fun$value(x, hyp$beta$par)
#
# totalTemp <- params$total(tpts)
# k3Temp <- params$beta(tpts)
#
# if(geneBestModel == "0")
# {
# k1Temp <- sapply(tpts,function(t)k1KKK_Der_Simple(t,c(hyp$total$params,hyp$beta$params)))
# }else if(geneBestModel == "a")
# {
# k1Temp <- k1VKK_Der_Simple(tpts,c(hyp$total$params,hyp$beta$params))
# }else if(geneBestModel == "ab")
# {
# k1Temp <- k1VKV_Der_Simple(tpts,c(hyp$total$params,hyp$beta$params))
# }
# }else{
# params <- list()
# params$total <- function(x)
# hyp$total$fun$value(x, hyp$total$par)
# params$alpha <- function(x)
# hyp$alpha$fun$value(x, hyp$alpha$par)
#
# totalTemp <- params$total(tpts)
#
# k1Temp <- params$alpha(tpts)
# k3Temp <- sapply(tpts, function(t) k3KKV_Der_Simple(t, c(hyp$total$params,hyp$alpha$params)))
# }
#
# data.frame(time = tpts
# , preMRNA = unname(rep(NaN,length(tpts)))
# , total = totalTemp
# , alpha = k1Temp
# , beta = k3Temp
# , gamma = unname(rep(NaN,length(tpts))))
# }
#############################################################################
### NEW INSPEcT FUNCTIONS FOR THE COMPUTATION ON THE CONFIDENCE INTERVALS ###
#############################################################################
logLikelihoodCIerror <- function(parameter,name,parameters,class,tpts,experimentalP,experimentalM,experimentalA=NULL,varianceP,varianceM,varianceA=NULL,confidenceThreshold,derivative=TRUE,app=FALSE)
{
if(derivative)
{
maximumLogLikelihoodTmp <- logLikelihood_derivativeModels(tpts=tpts
,class=class
,parameters=parameters
,premature=experimentalP
,mature=experimentalM
,alpha=experimentalA
,prematureVariance=varianceP
,matureVariance=varianceM
,alphaVariance=varianceA
,app=app)
perturbedParameters <- parameters
perturbedParameters[name] <- parameter
perturbedLogLikelihoodTmp <- logLikelihood_derivativeModels(tpts=tpts
,class=class
,parameters=perturbedParameters
,premature=experimentalP
,mature=experimentalM
,alpha=experimentalA
,prematureVariance=varianceP
,matureVariance=varianceM
,alphaVariance=varianceA
,app=app)
}else{
maximumLogLikelihoodTmp <- logLikelihood_integrativeModels(tpts=tpts
,class=class
,parameters=parameters
,premature=experimentalP
,mature=experimentalM
,alpha=experimentalA
,prematureVariance=varianceP
,matureVariance=varianceM
,alphaVariance=varianceA)
perturbedParameters <- parameters
perturbedParameters[name] <- parameter
perturbedLogLikelihoodTmp <- logLikelihood_integrativeModels(tpts=tpts
,class=class
,parameters=perturbedParameters
,premature=experimentalP
,mature=experimentalM
,alpha=experimentalA
,prematureVariance=varianceP
,matureVariance=varianceM
,alphaVariance=varianceA)
}
return(abs(confidenceThreshold - 2*(maximumLogLikelihoodTmp - perturbedLogLikelihoodTmp)))
}
logLikelihood_derivativeModels <- function(tpts,class,parameters,premature,mature,alpha,prematureVariance,matureVariance,alphaVariance,app=FALSE)
{
if(class=="0")
{
prematureKKKTemp <- c(sapply(seq_along(tpts),function(t)prematureKKK_Der(x = tpts[t], parameters = parameters)))
matureKKKTemp <- rep(parameters[[1]],length(tpts))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKKK <- c(matureKKKTemp,prematureKKKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKKK, variance = c(matureVariance,prematureVariance)))
}
alphaKKKTemp <- c(sapply(seq_along(tpts),function(t)k1KKK_Der(x = tpts[t], parameters = parameters)))
modelKKK <- c(matureKKKTemp,prematureKKKTemp,alphaKKKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha), model = modelKKK, variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="a")
{
prematureVKKTemp <- c(sapply(seq_along(tpts),function(t)prematureVKK_Der(x = tpts[t], parameters = parameters)))
matureVKKTemp <- c(sapply(seq_along(tpts),function(t)matureVKK_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelVKK <- c(matureVKKTemp,prematureVKKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelVKK, variance = c(matureVariance,prematureVariance)))
}
alphaVKKTemp <- c(sapply(seq_along(tpts),function(t)k1VKK_Der(x = tpts[t], parameters = parameters)))
modelVKK <- c(matureVKKTemp,prematureVKKTemp,alphaVKKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelVKK , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="c" & !app)
{
prematureKVKTemp <- c(sapply(seq_along(tpts),function(t)prematureKVK_Der(x = tpts[t], parameters = parameters)))
matureKVKTemp <- c(sapply(seq_along(tpts),function(t)matureKVK_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKVK <- c(matureKVKTemp,prematureKVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKVK, variance = c(matureVariance,prematureVariance)))
}
alphaKVKTemp <- c(sapply(seq_along(tpts),function(t)k1KVK_Der(x = tpts[t], parameters = parameters)))
modelKVK <- c(matureKVKTemp,prematureKVKTemp,alphaKVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKVK , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="c" & app)
{
prematureKVKTemp <- prematureKVK_Der_App(x = tpts, parameters = parameters)
matureKVKTemp <- rep(parameters[1], length(tpts))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKVK <- c(matureKVKTemp,prematureKVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKVK, variance = c(matureVariance,prematureVariance)))
}
alphaKVKTemp <- k1KVK_Der_App(x = tpts, parameters = parameters)
modelKVK <- c(matureKVKTemp,prematureKVKTemp,alphaKVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKVK , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="b" & !app)
{
prematureKKVTemp <- c(sapply(seq_along(tpts),function(t)prematureKKV_Der(x = tpts[t], parameters = parameters)))
matureKKVTemp <- c(sapply(seq_along(tpts),function(t)matureKKV_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKKV <- c(matureKKVTemp,prematureKKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKKV, variance = c(matureVariance,prematureVariance)))
}
alphaKKVTemp <- c(sapply(seq_along(tpts),function(t)k1KKV_Der(x = tpts[t], parameters = parameters)))
modelKKV <- c(matureKKVTemp,prematureKKVTemp,alphaKKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKKV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="b" & app)
{
prematureKKVTemp <- prematureKKV_Der_App(x = tpts, parameters = parameters)
matureKKVTemp <- rep(parameters[1], length(tpts))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKKV <- c(matureKKVTemp,prematureKKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKKV, variance = c(matureVariance,prematureVariance)))
}
alphaKKVTemp <- k1KKV_Der_App(x = tpts, parameters = parameters)
modelKKV <- c(matureKKVTemp,prematureKKVTemp,alphaKKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKKV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="ac")
{
prematureVVKTemp <- c(sapply(seq_along(tpts),function(t)prematureVVK_Der(x = tpts[t], parameters = parameters)))
matureVVKTemp <- c(sapply(seq_along(tpts),function(t)matureVVK_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelVVK <- c(matureVVKTemp,prematureVVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelVVK, variance = c(matureVariance,prematureVariance)))
}
alphaVVKTemp <- c(sapply(seq_along(tpts),function(t)k1VVK_Der(x = tpts[t], parameters = parameters)))
modelVVK <- c(matureVVKTemp,prematureVVKTemp,alphaVVKTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelVVK , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="ab")
{
prematureVKVTemp <- c(sapply(seq_along(tpts),function(t)prematureVKV_Der(x = tpts[t], parameters = parameters)))
matureVKVTemp <- c(sapply(seq_along(tpts),function(t)matureVKV_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelVKV <- c(matureVKVTemp,prematureVKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelVKV, variance = c(matureVariance,prematureVariance)))
}
alphaVKVTemp <- c(sapply(seq_along(tpts),function(t)k1VKV_Der(x = tpts[t], parameters = parameters)))
modelVKV <- c(matureVKVTemp,prematureVKVTemp,alphaVKVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelVKV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="bc" & !app)
{
prematureKVVTemp <- c(sapply(seq_along(tpts),function(t)prematureKVV_Der(x = tpts[t], parameters = parameters)))
matureKVVTemp <- c(sapply(seq_along(tpts),function(t)matureKVV_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKVV <- c(matureKVVTemp,prematureKVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKVV, variance = c(matureVariance,prematureVariance)))
}
alphaKVVTemp <- c(sapply(seq_along(tpts),function(t)k1KVV_Der(x = tpts[t], parameters = parameters)))
modelKVV <- c(matureKVVTemp,prematureKVVTemp,alphaKVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKVV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else if(class=="bc" & app)
{
prematureKVVTemp <- prematureKVV_Der_App(x = tpts, parameters = parameters)
matureKVVTemp <- rep(parameters[1], length(tpts))
if(is.null(alpha)&is.null(alphaVariance))
{
modelKVV <- c(matureKVVTemp,prematureKVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelKVV, variance = c(matureVariance,prematureVariance)))
}
alphaKVVTemp <- k1KVV_Der_App(x = tpts, parameters = parameters)
modelKVV <- c(matureKVVTemp,prematureKVVTemp,alphaKVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelKVV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}else{
prematureVVVTemp <- c(sapply(seq_along(tpts),function(t)prematureVVV_Der(x = tpts[t], parameters = parameters)))
matureVVVTemp <- c(sapply(seq_along(tpts),function(t)matureVVV_Der(x = tpts[t], parameters = parameters)))
if(is.null(alpha)&is.null(alphaVariance))
{
modelVVV <- c(matureVVVTemp,prematureVVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature), model = modelVVV, variance = c(matureVariance,prematureVariance)))
}
alphaVVVTemp <- c(sapply(seq_along(tpts),function(t)k1VVV_Der(x = tpts[t], parameters = parameters)))
modelVVV <- c(matureVVVTemp,prematureVVVTemp,alphaVVVTemp)
return(logLikelihoodFunction(experiment = c(mature,premature,alpha) , model = modelVVV , variance = c(matureVariance,prematureVariance,alphaVariance)))
}
}
logLikelihood_integrativeModels <- function(tpts,class,parameters,premature,mature,alpha,prematureVariance,matureVariance,alphaVariance)
{
if(class=="KKK"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
k1F <- function(x) {k1Parameters}
k2F <- function(x) {k2Parameters}
k3F <- function(x) {k3Parameters}
}else if(class=="VKK"){
k1Parameters <- parameters[1:(length(parameters)-2)]
k2Parameters <- parameters[length(parameters)-1]
k3Parameters <- parameters[length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
k2F <- function(x) {k2Parameters}
k3F <- function(x) {k3Parameters}
}else if(class=="KKV"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3:length(parameters)]
k1F <- function(x) {k1Parameters}
k2F <- function(x) {k2Parameters}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else if(class=="KVK"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
k1F <- function(x) {k1Parameters}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
k3F <- function(x) {k3Parameters}
}else if(class=="VKV"){
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[1+(length(parameters)-1)/2]
k3Parameters <- parameters[(2+(length(parameters)-1)/2):length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
k2F <- function(x) {k2Parameters}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else if(class=="VVK"){
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[(1+(length(parameters)-1)/2):(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
k3F <- function(x) {k3Parameters}
}else if(class=="KVV"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(1+(length(parameters)-1)/2)]
k3Parameters <- parameters[(1+(1+(length(parameters)-1)/2)):length(parameters)]
k1F <- function(x) {k1Parameters}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else{
k1Parameters <- parameters[1:(length(parameters)/3)]
k2Parameters <- parameters[(1+length(parameters)/3):(2*(length(parameters)/3))]
k3Parameters <- parameters[(1+2*(length(parameters)/3)):length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}
modData <- systemSolution(k1F,k2F,k3F,tpts)
if(!is.null(alpha))modData <- c(modData,sapply(tpts,k1F))
return(logLikelihoodFunction(experiment = c(mature,premature,alpha), model = modData, variance = c(matureVariance,prematureVariance,alphaVariance)))
}
rates_derivativeModels <- function(tpts,class,parameters,app=FALSE)
{
if(class=="0")
{
alphaKKKTemp <- c(sapply(seq_along(tpts),function(t)k1KKK_Der(x = tpts[t], parameters = parameters)))
betaKKKTemp <- c(sapply(seq_along(tpts),function(t)k3KKK_Der(x = tpts[t], parameters = parameters)))
gammaKKKTemp <- c(sapply(seq_along(tpts),function(t)k2KKK_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKKKTemp), beta=unname(betaKKKTemp), gamma=unname(gammaKKKTemp)))
}else if(class=="a")
{
alphaVKKTemp <- c(sapply(seq_along(tpts),function(t)k1VKK_Der(x = tpts[t], parameters = parameters)))
betaVKKTemp <- c(sapply(seq_along(tpts),function(t)k3VKK_Der(x = tpts[t], parameters = parameters)))
gammaVKKTemp <- c(sapply(seq_along(tpts),function(t)k2VKK_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaVKKTemp), beta=unname(betaVKKTemp), gamma=unname(gammaVKKTemp)))
}else if(class=="c" & !app)
{
alphaKVKTemp <- c(sapply(seq_along(tpts),function(t)k1KVK_Der(x = tpts[t], parameters = parameters)))
betaKVKTemp <- c(sapply(seq_along(tpts),function(t)k3KVK_Der(x = tpts[t], parameters = parameters)))
gammaKVKTemp <- c(sapply(seq_along(tpts),function(t)k2KVK_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKVKTemp), beta=unname(betaKVKTemp), gamma=unname(gammaKVKTemp)))
}else if(class=="c" & app)
{
alphaKVKTemp <- c(sapply(seq_along(tpts),function(t)k1KVK_Der_App(x = tpts[t], parameters = parameters)))
betaKVKTemp <- c(sapply(seq_along(tpts),function(t)k3KVK_Der_App(x = tpts[t], parameters = parameters)))
gammaKVKTemp <- c(sapply(seq_along(tpts),function(t)k2KVK_Der_App(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKVKTemp), beta=unname(betaKVKTemp), gamma=unname(gammaKVKTemp)))
}else if(class=="b" & !app)
{
alphaKKVTemp <- c(sapply(seq_along(tpts),function(t)k1KKV_Der(x = tpts[t], parameters = parameters)))
betaKKVTemp <- c(sapply(seq_along(tpts),function(t)k3KKV_Der(x = tpts[t], parameters = parameters)))
gammaKKVTemp <- c(sapply(seq_along(tpts),function(t)k2KKV_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKKVTemp), beta=unname(betaKKVTemp), gamma=unname(gammaKKVTemp)))
}else if(class=="b" & app)
{
alphaKKVTemp <- c(sapply(seq_along(tpts),function(t)k1KKV_Der_App(x = tpts[t], parameters = parameters)))
betaKKVTemp <- c(sapply(seq_along(tpts),function(t)k3KKV_Der_App(x = tpts[t], parameters = parameters)))
gammaKKVTemp <- c(sapply(seq_along(tpts),function(t)k2KKV_Der_App(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKKVTemp), beta=unname(betaKKVTemp), gamma=unname(gammaKKVTemp)))
}else if(class=="ac")
{
alphaVVKTemp <- c(sapply(seq_along(tpts),function(t)k1VVK_Der(x = tpts[t], parameters = parameters)))
betaVVKTemp <- c(sapply(seq_along(tpts),function(t)k3VVK_Der(x = tpts[t], parameters = parameters)))
gammaVVKTemp <- c(sapply(seq_along(tpts),function(t)k2VVK_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaVVKTemp), beta=unname(betaVVKTemp), gamma=unname(gammaVVKTemp)))
}else if(class=="ab")
{
alphaVKVTemp <- c(sapply(seq_along(tpts),function(t)k1VKV_Der(x = tpts[t], parameters = parameters)))
betaVKVTemp <- c(sapply(seq_along(tpts),function(t)k3VKV_Der(x = tpts[t], parameters = parameters)))
gammaVKVTemp <- c(sapply(seq_along(tpts),function(t)k2VKV_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaVKVTemp), beta=unname(betaVKVTemp), gamma=unname(gammaVKVTemp)))
}else if(class=="bc" & !app)
{
alphaKVVTemp <- c(sapply(seq_along(tpts),function(t)k1KVV_Der(x = tpts[t], parameters = parameters)))
betaKVVTemp <- c(sapply(seq_along(tpts),function(t)k3KVV_Der(x = tpts[t], parameters = parameters)))
gammaKVVTemp <- c(sapply(seq_along(tpts),function(t)k2KVV_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKVVTemp), beta=unname(betaKVVTemp), gamma=unname(gammaKVVTemp)))
}else if(class=="bc" & app)
{
alphaKVVTemp <- c(sapply(seq_along(tpts),function(t)k1KVV_Der_App(x = tpts[t], parameters = parameters)))
betaKVVTemp <- c(sapply(seq_along(tpts),function(t)k3KVV_Der_App(x = tpts[t], parameters = parameters)))
gammaKVVTemp <- c(sapply(seq_along(tpts),function(t)k2KVV_Der_App(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaKVVTemp), beta=unname(betaKVVTemp), gamma=unname(gammaKVVTemp)))
}else
{
alphaVVVTemp <- c(sapply(seq_along(tpts),function(t)k1VVV_Der(x = tpts[t], parameters = parameters)))
betaVVVTemp <- c(sapply(seq_along(tpts),function(t)k3VVV_Der(x = tpts[t], parameters = parameters)))
gammaVVVTemp <- c(sapply(seq_along(tpts),function(t)k2VVV_Der(x = tpts[t], parameters = parameters)))
return(c(alpha=unname(alphaVVVTemp), beta=unname(betaVVVTemp), gamma=unname(gammaVVVTemp)))
}
}
rates_integrativeModels <- function(tpts, class, parameters)
{
rate <- function(tpts,parameters){if(length(parameters)==6){return(impulseModel(tpts,parameters))}
else if(length(parameters)==4){return(sigmoidModel(tpts,parameters))}
else{return(rep(parameters,length(tpts)))}}
if(class=="KKK")
{
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
}else if(class=="VKK")
{
k1Parameters <- parameters[1:(length(parameters)-2)]
k2Parameters <- parameters[length(parameters)-1]
k3Parameters <- parameters[length(parameters)]
}else if(class=="KKV")
{
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3:length(parameters)]
}else if(class=="KVK")
{
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
}else if(class=="VKV")
{
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[1+(length(parameters)-1)/2]
k3Parameters <- parameters[(2+(length(parameters)-1)/2):length(parameters)]
}else if(class=="VVK")
{
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[(1+(length(parameters)-1)/2):(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
}else if(class=="KVV")
{
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(1+(length(parameters)-1)/2)]
k3Parameters <- parameters[(1+(1+(length(parameters)-1)/2)):length(parameters)]
}else if(class=="VVV")
{
k1Parameters <- parameters[1:(length(parameters)/3)]
k2Parameters <- parameters[(1+length(parameters)/3):(2*(length(parameters)/3))]
k3Parameters <- parameters[(1+2*(length(parameters)/3)):length(parameters)]
}
return(c("alpha"=rate(tpts,k1Parameters),"gamma"=rate(tpts,k2Parameters),"beta"=rate(tpts,k3Parameters)))
}
expressionData_integrativeModels <- function(tpts,class,parameters)
{
if(class=="KKK"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
k1F <- function(x) {k1Parameters}
k2F <- function(x) {k2Parameters}
k3F <- function(x) {k3Parameters}
}else if(class=="VKK"){
k1Parameters <- parameters[1:(length(parameters)-2)]
k2Parameters <- parameters[length(parameters)-1]
k3Parameters <- parameters[length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
k2F <- function(x) {k2Parameters}
k3F <- function(x) {k3Parameters}
}else if(class=="KKV"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3:length(parameters)]
k1F <- function(x) {k1Parameters}
k2F <- function(x) {k2Parameters}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else if(class=="KVK"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
k1F <- function(x) {k1Parameters}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
k3F <- function(x) {k3Parameters}
}else if(class=="VKV"){
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[1+(length(parameters)-1)/2]
k3Parameters <- parameters[(2+(length(parameters)-1)/2):length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
k2F <- function(x) {k2Parameters}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else if(class=="VVK"){
k1Parameters <- parameters[1:((length(parameters)-1)/2)]
k2Parameters <- parameters[(1+(length(parameters)-1)/2):(length(parameters)-1)]
k3Parameters <- parameters[length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
k3F <- function(x) {k3Parameters}
}else if(class=="KVV"){
k1Parameters <- parameters[1]
k2Parameters <- parameters[2:(1+(length(parameters)-1)/2)]
k3Parameters <- parameters[(1+(1+(length(parameters)-1)/2)):length(parameters)]
k1F <- function(x) {k1Parameters}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}else{
k1Parameters <- parameters[1:(length(parameters)/3)]
k2Parameters <- parameters[(1+length(parameters)/3):(2*(length(parameters)/3))]
k3Parameters <- parameters[(1+2*(length(parameters)/3)):length(parameters)]
if(length(k1Parameters)==6){k1F <- function(x){impulseModel(x, k1Parameters)}}else{k1F <- function(x){sigmoidModel(x, k1Parameters)}}
if(length(k2Parameters)==6){k2F <- function(x){impulseModel(x, k2Parameters)}}else{k2F <- function(x){sigmoidModel(x, k2Parameters)}}
if(length(k3Parameters)==6){k3F <- function(x){impulseModel(x, k3Parameters)}}else{k3F <- function(x){sigmoidModel(x, k3Parameters)}}
}
modData <- systemSolution(k1F,k2F,k3F,tpts)
return(modData)
}
emptyList <- list(root = NaN, f.root = NaN, iter = NaN, estim.precis = NaN)
k_score_fun <- function(k, rate_conf_int)
{
sum(apply(rate_conf_int, 1, function(x) {
if( k < x[2] ) (k - x[2])^2/(x[2]-x[1])^2
else (k - x[2])^2/(x[2]-x[3])^2
}), na.rm=T)
}
#####################################################################
################ NEW INSPEcT INTEGRATIVE APPROACHES #################
#####################################################################
.inspect.engine_Integrative_Nascent <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
alphaVariance <- rates$alpha_var
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(mature)
KKK <- bplapply(eiGenes,function(row){
k1Parameters <- mean(alpha[row,])
k2Parameters <- mean(gamma[row,])
k3Parameters <- mean(beta[row,])
unlist(
tryCatch(
optim(c(k1Parameters, k2Parameters, k3Parameters)
,errorKKK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,control = list(maxit = nIter)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e$message)
)
)
}, BPPARAM=BPPARAM)
names(KKK) <- eiGenes
VVV <- bplapply(eiGenes, function(row){
if(useSigmoidFun)
{
k1Parameters <- c(rep(KKK[[row]][1],2), max(tpts)/3,1)
k2Parameters <- c(rep(KKK[[row]][2],2), max(tpts)/3,1)
k3Parameters <- c(rep(KKK[[row]][3],2), max(tpts)/3,1)
sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e$message)
)
)
k1Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[1:4]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)})
k2Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[5:8]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)})
k3Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[9:12]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)})
}else{
k1Parameters <- c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)
k2Parameters <- c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)
k3Parameters <- c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)
}
impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, par14 = NaN
, par15 = NaN
, par16 = NaN
, par17 = NaN
, par18 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e$message)
)
)
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,3*length(tpts) - 18)) < pchisq(sigmoidsParameters[["value"]],max(0,3*length(tpts) - 12))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
### Confidence intervals
message("Confidence intervals.")
confidenceIntervals <- bplapply(eiGenes,function(g)
{
classTmp <- "VVV"
parameters <- unlist(VVV[[g]][grep("par",names(VVV[[g]]))])
optTmp <- rates_integrativeModels(tpts=tpts, class=classTmp, parameters=parameters)
foe <- capture.output({ # Just to capture the output of multiroot function
suppressWarnings({
intervals <- sapply(names(parameters),function(parname)
{
par <- parameters[parname]
mOut = list(
left_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e-2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
left_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1/2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
center = tryCatch(multiroot(f = logLikelihoodCIerror, start = par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
right_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1.5*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
right_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList))
)
precis = sapply(mOut, '[[', 'f.root')
if( length(which(precis<1e-2))>0 ) {
conf_int = sapply(mOut[which(precis<1e-2)], '[[', 'root')
low_int = min(conf_int)
high_int = max(conf_int)
left = ifelse( low_int < par, low_int, NA)
right = ifelse( high_int > par, high_int, NA)
left = unname(left)
right = unname(right)
} else {
left = NA
right = NA
}
return(c(left,right))
})
intervals[1,!is.finite(intervals[2,])] <- NaN
intervals[2,!is.finite(intervals[1,])] <- NaN
})
})
perturbedRates <- matrix(rep(NaN,3*length(tpts)),ncol=1)
for(parname in names(parameters))
{
for(extremePar in intervals[,parname])
{
perturbedParameters <- parameters
perturbedParameters[parname] <- extremePar
perturbedRates <- cbind(perturbedRates,rates_integrativeModels(tpts=tpts, class=classTmp, parameters=perturbedParameters))
}
};perturbedRates <- perturbedRates[,-1]
perturbedRates[perturbedRates<0] <- 0
k1left <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k1TC <- optTmp[grep("alpha",names(optTmp))]
k1right <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k2left <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k2TC <- optTmp[grep("gamma",names(optTmp))]
k2right <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k3left <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k3TC <- optTmp[grep("beta",names(optTmp))]
k3right <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,max,na.rm=TRUE)
return(list(
k1 = cbind(left=k1left, opt=k1TC, right=k1right),
k2 = cbind(left=k2left, opt=k2TC, right=k2right),
k3 = cbind(left=k3left, opt=k3TC, right=k3right)
))
},BPPARAM=BPPARAM)
names(confidenceIntervals) <- eiGenes
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if((!is.finite(row[1])|row[1]==row[2])&(is.finite(row[3])&row[3]!=row[2])) row[1] <- row[2] - (row[3]-row[2])
if((!is.finite(row[3])|row[3]==row[2])&(is.finite(row[1])&row[1]!=row[2])) row[3] <- row[2] + (row[2]-row[1])
row
}))
}
}
k1_low <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k1_high <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k2_low <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k2_high <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k3_low <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
k3_high <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
### Possible for very few genes
#
if(k1_low==0)k1_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k1_high==0)k1_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k2_low==0)k2_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k2_high==0)k2_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k3_low==0)k3_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
if(k3_high==0)k3_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
median_low <- c(k1=k1_low,k2=k2_low,k3=k3_low)
median_high <- c(k1=k1_high,k2=k2_high,k3=k3_high)
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if(is.finite(row[2]))
{
if(row[1]==row[2] & row[1]==row[3]) {row[1] <- row[2]*(1-median_low[[r]]); row[3] <- row[2]*(1+median_high[[r]])}
}
row
}))
}
}
# Removal of not modeled genes
eiGenes <- eiGenes[sapply(confidenceIntervals,function(g)all(is.finite(g[[1]]))&all(is.finite(g[[2]]))&all(is.finite(g[[3]])))]
confidenceIntervals <- confidenceIntervals[eiGenes]
VVV <- VVV[eiGenes]
# I compute che constant rates
fitResults_synthesis <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k1"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_processing <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k2"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_degradation <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k3"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
names(fitResults_synthesis) <-
names(fitResults_processing) <-
names(fitResults_degradation) <- eiGenes
confidenceIntervals <- lapply(eiGenes,function(g)
{
confidenceIntervals[[g]][['k1']] <- cbind(confidenceIntervals[[g]][['k1']],'constant'=rep(fitResults_synthesis[[g]],length(tpts)))
confidenceIntervals[[g]][['k2']] <- cbind(confidenceIntervals[[g]][['k2']],'constant'=rep(fitResults_processing[[g]],length(tpts)))
confidenceIntervals[[g]][['k3']] <- cbind(confidenceIntervals[[g]][['k3']],'constant'=rep(fitResults_degradation[[g]],length(tpts)))
confidenceIntervals[[g]]
})
### Standard outputs
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
modelVVV <- expressionData_integrativeModels(tpts, class = "VVV", parameters = VVV[[g]][grep("par",names(VVV[[g]]))])
ratesVVV <- rates_integrativeModels(tpts, class = "VVV", parameters = VVV[[g]][grep("par",names(VVV[[g]]))])
matureModel <- modelVVV[grep("^mature",names(modelVVV))]
prematureModel <- modelVVV[grep("^premature",names(modelVVV))]
alphaModel <- ratesVVV[grep("alpha",names(ratesVVV))]
modelVVV <- c(matureModel,prematureModel,alphaModel)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,],alpha[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,],alphaVariance[g,])),error=function(e)NaN)
c("KKK" = NaN,"VKK" = NaN,"KVK" = NaN,"KKV" = NaN,"VVK" = NaN,"VKV" = NaN,"KVV" = NaN,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
dof <- cbind(KKK = NaN
,VKK = NaN
,KVK = NaN
,KKV = NaN
,VVK = NaN
,VKV = NaN
,KVV = NaN
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- NaN
VKKTemp <- NaN
KVKTemp <- NaN
KKVTemp <- NaN
VVKTemp <- NaN
VKVTemp <- NaN
KVVTemp <- NaN
VVVTemp <- tryCatch(errorVVV_Int(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = alpha[g,]
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = alphaVariance[g,]
,clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp,VKK = VKKTemp,KVK = KVKTemp,KKV = KKVTemp,VVK = VVKTemp,VKV = VKVTemp,KVV = KVVTemp,VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,3*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,3*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,3*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,3*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,3*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,3*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,3*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,3*length(tpts)-dof[g,'VVV'])))))
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
,"a" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"b" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"c" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ab" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ac" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"bc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
out <- list(ratesSpecs=ratesSpecs[eiGenes],
confidenceIntervals=confidenceIntervals)
return(out)
}
.inspect.engine_Integrative_Nascent_sdp <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
alphaVariance <- rates$alpha_var
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(mature)
KKK <- bplapply(eiGenes,function(row){
k1Parameters <- mean(alpha[row,])
k2Parameters <- mean(gamma[row,])
k3Parameters <- mean(beta[row,])
unlist(
tryCatch(
optim(c(k1Parameters, k2Parameters, k3Parameters)
,errorKKK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,control = list(maxit = nIter)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
)
}, BPPARAM=BPPARAM)
names(KKK) <- eiGenes
VVV <- bplapply(eiGenes, function(row){
if(useSigmoidFun)
{
k1Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=alpha[row,]
, variance=alpha[row,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][1],2), max(tpts)/3,1))
k2Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=gamma[row,]
, variance=gamma[row,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][2],2), max(tpts)/3,1))
k3Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=beta[row,]
, variance=beta[row,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][3],2), max(tpts)/3,1))
sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
)
}
k1Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=alpha[row,]
, variance=alpha[row,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1))
k2Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=gamma[row,]
, variance=gamma[row,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1))
k3Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=beta[row,]
, variance=beta[row,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1))
impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, par14 = NaN
, par15 = NaN
, par16 = NaN
, par17 = NaN
, par18 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
)
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,3*length(tpts) - 18)) < pchisq(sigmoidsParameters[["value"]],max(0,3*length(tpts) - 12))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
### Confidence intervals
message("Confidence intervals.")
confidenceIntervals <- bplapply(eiGenes,function(g)
{
classTmp <- "VVV"
parameters <- unlist(VVV[[g]][grep("par",names(VVV[[g]]))])
optTmp <- rates_integrativeModels(tpts=tpts, class=classTmp, parameters=parameters)
foe <- capture.output({ # Just to capture the output of multiroot function
suppressWarnings({
intervals <- sapply(names(parameters),function(parname)
{
par <- parameters[parname]
mOut = list(
left_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e-2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
left_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1/2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
center = tryCatch(multiroot(f = logLikelihoodCIerror, start = par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
right_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1.5*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList)),
right_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = FALSE),error=function(e)return(emptyList))
)
precis = sapply(mOut, '[[', 'f.root')
if( length(which(precis<1e-2))>0 ) {
conf_int = sapply(mOut[which(precis<1e-2)], '[[', 'root')
low_int = min(conf_int)
high_int = max(conf_int)
left = ifelse( low_int < par, low_int, NA)
right = ifelse( high_int > par, high_int, NA)
left = unname(left)
right = unname(right)
} else {
left = NA
right = NA
}
return(c(left,right))
})
intervals[1,!is.finite(intervals[2,])] <- NaN
intervals[2,!is.finite(intervals[1,])] <- NaN
})
})
perturbedRates <- matrix(rep(NaN,3*length(tpts)),ncol=1)
for(parname in names(parameters))
{
for(extremePar in intervals[,parname])
{
perturbedParameters <- parameters
perturbedParameters[parname] <- extremePar
perturbedRates <- cbind(perturbedRates,rates_integrativeModels(tpts=tpts, class=classTmp, parameters=perturbedParameters))
}
};perturbedRates <- perturbedRates[,-1]
perturbedRates[perturbedRates<0] <- 0
k1left <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k1TC <- optTmp[grep("alpha",names(optTmp))]
k1right <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k2left <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k2TC <- optTmp[grep("gamma",names(optTmp))]
k2right <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k3left <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k3TC <- optTmp[grep("beta",names(optTmp))]
k3right <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,max,na.rm=TRUE)
return(list(
k1 = cbind(left=k1left, opt=k1TC, right=k1right),
k2 = cbind(left=k2left, opt=k2TC, right=k2right),
k3 = cbind(left=k3left, opt=k3TC, right=k3right)
))
},BPPARAM=BPPARAM)
names(confidenceIntervals) <- eiGenes
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if((!is.finite(row[1])|row[1]==row[2])&(is.finite(row[3])&row[3]!=row[2])) row[1] <- row[2] - (row[3]-row[2])
if((!is.finite(row[3])|row[3]==row[2])&(is.finite(row[1])&row[1]!=row[2])) row[3] <- row[2] + (row[2]-row[1])
row
}))
}
}
k1_low <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k1_high <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k2_low <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k2_high <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k3_low <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
k3_high <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
### Possible for very few genes
#
if(k1_low==0)k1_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k1_high==0)k1_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k2_low==0)k2_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k2_high==0)k2_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k3_low==0)k3_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
if(k3_high==0)k3_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
median_low <- c(k1=k1_low,k2=k2_low,k3=k3_low)
median_high <- c(k1=k1_high,k2=k2_high,k3=k3_high)
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if(is.finite(row[2]))
{
if(row[1]==row[2] & row[1]==row[3]) {row[1] <- row[2]*(1-median_low[[r]]); row[3] <- row[2]*(1+median_high[[r]])}
}
row
}))
}
}
# Removal of not modeled genes
eiGenes <- eiGenes[sapply(confidenceIntervals,function(g)all(is.finite(g[[1]]))&all(is.finite(g[[2]]))&all(is.finite(g[[3]])))]
confidenceIntervals <- confidenceIntervals[eiGenes]
VVV <- VVV[eiGenes]
# I compute che constant rates
fitResults_synthesis <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k1"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_processing <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k2"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_degradation <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k3"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
names(fitResults_synthesis) <-
names(fitResults_processing) <-
names(fitResults_degradation) <- eiGenes
confidenceIntervals <- lapply(eiGenes,function(g)
{
confidenceIntervals[[g]][['k1']] <- cbind(confidenceIntervals[[g]][['k1']],'constant'=rep(fitResults_synthesis[[g]],length(tpts)))
confidenceIntervals[[g]][['k2']] <- cbind(confidenceIntervals[[g]][['k2']],'constant'=rep(fitResults_processing[[g]],length(tpts)))
confidenceIntervals[[g]][['k3']] <- cbind(confidenceIntervals[[g]][['k3']],'constant'=rep(fitResults_degradation[[g]],length(tpts)))
confidenceIntervals[[g]]
})
### Standard outputs
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
modelVVV <- expressionData_integrativeModels(tpts, class = "VVV", parameters = VVV[[g]][grep("par",names(VVV[[g]]))])
ratesVVV <- rates_integrativeModels(tpts, class = "VVV", parameters = VVV[[g]][grep("par",names(VVV[[g]]))])
matureModel <- modelVVV[grep("^mature",names(modelVVV))]
prematureModel <- modelVVV[grep("^premature",names(modelVVV))]
alphaModel <- ratesVVV[grep("alpha",names(ratesVVV))]
modelVVV <- c(matureModel,prematureModel,alphaModel)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,],alpha[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,],alphaVariance[g,])),error=function(e)NaN)
c("KKK" = NaN,"VKK" = NaN,"KVK" = NaN,"KKV" = NaN,"VVK" = NaN,"VKV" = NaN,"KVV" = NaN,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
dof <- cbind(KKK = NaN
,VKK = NaN
,KVK = NaN
,KKV = NaN
,VVK = NaN
,VKV = NaN
,KVV = NaN
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- NaN
VKKTemp <- NaN
KVKTemp <- NaN
KKVTemp <- NaN
VVKTemp <- NaN
VKVTemp <- NaN
KVVTemp <- NaN
VVVTemp <- tryCatch(errorVVV_Int(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = alpha[g,]
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = alphaVariance[g,]
,clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp,VKK = VKKTemp,KVK = KVKTemp,KKV = KKVTemp,VVK = VVKTemp,VKV = VKVTemp,KVV = KVVTemp,VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,3*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,3*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,3*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,3*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,3*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,3*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,3*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,3*length(tpts)-dof[g,'VVV'])))))
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
,"a" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"b" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"c" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ab" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ac" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"bc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
out <- list(ratesSpecs=ratesSpecs[eiGenes],
confidenceIntervals=confidenceIntervals)
return(out)
}
.inspect.engine_Integrative_NoNascent <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
alphaVariance <- rates$alpha_var
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(mature)
KKK <- bplapply(eiGenes,function(row){
k1Parameters <- mean(alpha[row,])
k2Parameters <- mean(gamma[row,])
k3Parameters <- mean(beta[row,])
unlist(
tryCatch(
optim(c(k1Parameters, k2Parameters, k3Parameters)
,errorKKK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,control = list(maxit = nIter)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
)
}, BPPARAM=BPPARAM)
names(KKK) <- eiGenes
message("Model 'no-reg' finished.")
VKK <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- c(rep(KKK[[row]][1],2), max(tpts)/3,1)
k2Parameters <- KKK[[row]][2]
k3Parameters <- KKK[[row]][3]
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelVKK <- expressionData_integrativeModels(tpts, class = "VKK", parameters = parameters)
ratesVKK <- rates_integrativeModels(0, class = "VKK", parameters = parameters)
prematureEstimated <- modelVKK[grep("^premature",names(modelVKK))]
matureEstimated <- modelVKK[grep("^mature",names(modelVKK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVKK[grep("alpha",names(ratesVKK))]
betaEstimated <- ratesVKK[grep("beta",names(ratesVKK))]
gammaEstimated <- ratesVKK[grep("gamma",names(ratesVKK))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVKK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[1:4]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)})
k2Parameters <- tryCatch(sigmoidsParameters[[2]],error=function(e)KKK[[row]][2])
k3Parameters <- tryCatch(sigmoidsParameters[[6]],error=function(e)KKK[[row]][3])
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)
k2Parameters <- KKK[[row]][2]
k3Parameters <- KKK[[row]][3]
}
modelVKK <- expressionData_integrativeModels(tpts, class = "VKK", parameters = parameters)
ratesVKK <- rates_integrativeModels(0, class = "VKK", parameters = parameters)
prematureEstimated <- modelVKK[grep("^mature",names(modelVKK))]
matureEstimated <- modelVKK[grep("^premature",names(modelVKK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVKK[grep("alpha",names(ratesVKK))]
betaEstimated <- ratesVKK[grep("beta",names(ratesVKK))]
gammaEstimated <- ratesVKK[grep("gamma",names(ratesVKK))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVKK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 8)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 6))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VKK) <- eiGenes
message("Model 's' finished.")
KKV <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- KKK[[row]][1]
k2Parameters <- KKK[[row]][2]
k3Parameters <- c(rep(KKK[[row]][3],2), max(tpts)/3,1)
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelKKV <- expressionData_integrativeModels(tpts, class = "KKV", parameters = parameters)
ratesKKV <- rates_integrativeModels(0, class = "KKV", parameters = parameters)
prematureEstimated <- modelKKV[grep("^premature",names(modelKKV))]
matureEstimated <- modelKKV[grep("^mature",names(modelKKV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKKV[grep("alpha",names(ratesKKV))]
betaEstimated <- ratesKKV[grep("beta",names(ratesKKV))]
gammaEstimated <- ratesKKV[grep("gamma",names(ratesKKV))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKKV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(sigmoidsParameters[[1]],error=function(e)KKK[[row]][1])
k2Parameters <- tryCatch(sigmoidsParameters[[2]],error=function(e)KKK[[row]][2])
k3Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[3:6]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)})
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- KKK[[row]][1]
k2Parameters <- KKK[[row]][2]
k3Parameters <- c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)
}
modelKKV <- expressionData_integrativeModels(tpts, class = "KKV", parameters = parameters)
ratesKKV <- rates_integrativeModels(0, class = "KKV", parameters = parameters)
prematureEstimated <- modelKKV[grep("^mature",names(modelKKV))]
matureEstimated <- modelKKV[grep("^premature",names(modelKKV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKKV[grep("alpha",names(ratesKKV))]
betaEstimated <- ratesKKV[grep("beta",names(ratesKKV))]
gammaEstimated <- ratesKKV[grep("gamma",names(ratesKKV))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKKV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 8)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 6))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(KKV) <- eiGenes
message("Model 'd' finished.")
KVK <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- KKK[[row]][1]
k2Parameters <- c(rep(KKK[[row]][2],2), max(tpts)/3,1)
k3Parameters <- KKK[[row]][3]
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelKVK <- expressionData_integrativeModels(tpts, class = "KVK", parameters = parameters)
ratesKVK <- rates_integrativeModels(0, class = "KVK", parameters = parameters)
prematureEstimated <- modelKVK[grep("^premature",names(modelKVK))]
matureEstimated <- modelKVK[grep("^mature",names(modelKVK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKVK[grep("alpha",names(ratesKVK))]
betaEstimated <- ratesKVK[grep("beta",names(ratesKVK))]
gammaEstimated <- ratesKVK[grep("gamma",names(ratesKVK))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKVK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(sigmoidsParameters[[1]],error=function(e){KKK[[row]][1]})
k2Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[2:5]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)})
k3Parameters <- tryCatch(sigmoidsParameters[[6]],error=function(e){KKK[[row]][3]})
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- KKK[[row]][1]
k2Parameters <- c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)
k3Parameters <- KKK[[row]][3]
}
modelKVK <- expressionData_integrativeModels(tpts, class = "KVK", parameters = parameters)
ratesKVK <- rates_integrativeModels(0, class = "KVK", parameters = parameters)
prematureEstimated <- modelKVK[grep("^mature",names(modelKVK))]
matureEstimated <- modelKVK[grep("^premature",names(modelKVK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKVK[grep("alpha",names(ratesKVK))]
betaEstimated <- ratesKVK[grep("beta",names(ratesKVK))]
gammaEstimated <- ratesKVK[grep("gamma",names(ratesKVK))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKVK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 8)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 6))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(KVK) <- eiGenes
message("Model 'p' finished.")
VKV <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- c(rep(KKK[[row]][1],2), max(tpts)/3,1)
k2Parameters <- KKK[[row]][2]
k3Parameters <- c(rep(KKK[[row]][3],2), max(tpts)/3,1)
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelVKV <- expressionData_integrativeModels(tpts, class = "VKV", parameters = parameters)
ratesVKV <- rates_integrativeModels(0, class = "VKV", parameters = parameters)
prematureEstimated <- modelVKV[grep("^premature",names(modelVKV))]
matureEstimated <- modelVKV[grep("^mature",names(modelVKV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVKV[grep("alpha",names(ratesVKV))]
betaEstimated <- ratesVKV[grep("beta",names(ratesVKV))]
gammaEstimated <- ratesVKV[grep("gamma",names(ratesVKV))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVKV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[1:4]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)})
k2Parameters <- tryCatch(sigmoidsParameters[[5]],error=function(e)KKK[[row]][2])
k3Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[6:9]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)})
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)
k2Parameters <- KKK[[row]][2]
k3Parameters <- c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)
}
modelVKV <- expressionData_integrativeModels(tpts, class = "VKV", parameters = parameters)
ratesVKV <- rates_integrativeModels(0, class = "VKV", parameters = parameters)
prematureEstimated <- modelVKV[grep("^mature",names(modelVKV))]
matureEstimated <- modelVKV[grep("^premature",names(modelVKV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVKV[grep("alpha",names(ratesVKV))]
betaEstimated <- ratesVKV[grep("beta",names(ratesVKV))]
gammaEstimated <- ratesVKV[grep("gamma",names(ratesVKV))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVKV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 13)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 9))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VKV) <- eiGenes
message("Model 'sd' finished.")
VVK <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- c(rep(KKK[[row]][1],2), max(tpts)/3,1)
k2Parameters <- c(rep(KKK[[row]][2],2), max(tpts)/3,1)
k3Parameters <- KKK[[row]][3]
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelVVK <- expressionData_integrativeModels(tpts, class = "VVK", parameters = parameters)
ratesVVK <- rates_integrativeModels(0, class = "VVK", parameters = parameters)
prematureEstimated <- modelVVK[grep("^premature",names(modelVVK))]
matureEstimated <- modelVVK[grep("^mature",names(modelVVK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVVK[grep("alpha",names(ratesVVK))]
betaEstimated <- ratesVVK[grep("beta",names(ratesVVK))]
gammaEstimated <- ratesVVK[grep("gamma",names(ratesVVK))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[1:4]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)})
k2Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[5:8]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)})
k3Parameters <- tryCatch(sigmoidsParameters[[9]],error=function(e)KKK[[row]][3])
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)
k2Parameters <- c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)
k3Parameters <- KKK[[row]][3]
}
modelVVK <- expressionData_integrativeModels(tpts, class = "VVK", parameters = parameters)
ratesVVK <- rates_integrativeModels(0, class = "VVK", parameters = parameters)
prematureEstimated <- modelVVK[grep("^mature",names(modelVVK))]
matureEstimated <- modelVVK[grep("^premature",names(modelVVK))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVVK[grep("alpha",names(ratesVVK))]
betaEstimated <- ratesVVK[grep("beta",names(ratesVVK))]
gammaEstimated <- ratesVVK[grep("gamma",names(ratesVVK))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVK_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 13)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 9))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VVK) <- eiGenes
message("Model 'sp' finished.")
KVV <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- KKK[[row]][1]
k2Parameters <- c(rep(KKK[[row]][2],2), max(tpts)/3,1)
k3Parameters <- c(rep(KKK[[row]][3],2), max(tpts)/3,1)
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelKVV <- expressionData_integrativeModels(tpts, class = "KVV", parameters = parameters)
ratesKVV <- rates_integrativeModels(0, class = "KVV", parameters = parameters)
prematureEstimated <- modelKVV[grep("^premature",names(modelKVV))]
matureEstimated <- modelKVV[grep("^mature",names(modelKVV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKVV[grep("alpha",names(ratesKVV))]
betaEstimated <- ratesKVV[grep("beta",names(ratesKVV))]
gammaEstimated <- ratesKVV[grep("gamma",names(ratesKVV))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(sigmoidsParameters[[1]],error=function(e)KKK[[row]][1])
k2Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[2:5]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)})
k3Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[6:9]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)})
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- KKK[[row]][1]
k2Parameters <- c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)
k3Parameters <- c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)
}
modelKVV <- expressionData_integrativeModels(tpts, class = "KVV", parameters = parameters)
ratesKVV <- rates_integrativeModels(0, class = "KVV", parameters = parameters)
prematureEstimated <- modelKVV[grep("^mature",names(modelKVV))]
matureEstimated <- modelKVV[grep("^premature",names(modelKVV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesKVV[grep("alpha",names(ratesKVV))]
betaEstimated <- ratesKVV[grep("beta",names(ratesKVV))]
gammaEstimated <- ratesKVV[grep("gamma",names(ratesKVV))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorKVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 13)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 9))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(KVV) <- eiGenes
message("Model 'pd' finished.")
VVV <- bplapply(eiGenes, function(row){
ratesKKK <- rates_integrativeModels(0, class = "KKK", parameters = KKK[[row]][1:3])
alphaKKK <- ratesKKK[grep("alpha",names(ratesKKK))]
betaKKK <- ratesKKK[grep("beta",names(ratesKKK))]
gammaKKK <- ratesKKK[grep("gamma",names(ratesKKK))]
if(useSigmoidFun)
{
k1Parameters <- c(rep(KKK[[row]][1],2), max(tpts)/3,1)
k2Parameters <- c(rep(KKK[[row]][2],2), max(tpts)/3,1)
k3Parameters <- c(rep(KKK[[row]][3],2), max(tpts)/3,1)
parameters <- c(k1Parameters, k2Parameters, k3Parameters)
modelVVV <- expressionData_integrativeModels(tpts, class = "VVV", parameters = parameters)
ratesVVV <- rates_integrativeModels(0, class = "VVV", parameters = parameters)
prematureEstimated <- modelVVV[grep("^premature",names(modelVVV))]
matureEstimated <- modelVVV[grep("^mature",names(modelVVV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVVV[grep("alpha",names(ratesVVV))]
betaEstimated <- ratesVVV[grep("beta",names(ratesVVV))]
gammaEstimated <- ratesVVV[grep("gamma",names(ratesVVV))]
capture.output(sigmoidsParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
k1Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[1:4]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)})
k2Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[5:8]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)})
k3Parameters <- tryCatch(fromSigmoidToImpulse(sigmoidsParameters[[9:12]],tpts=tpts,nIter=nIter),error=function(e){c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)})
}else if(!useSigmoidFun | (any(!is.finite(c(k1Parameters,k2Parameters,k3Parameters))))){
k1Parameters <- c(rep(KKK[[row]][1],3), max(tpts)/3, max(tpts)/3*2,1)
k2Parameters <- c(rep(KKK[[row]][2],3), max(tpts)/3, max(tpts)/3*2,1)
k3Parameters <- c(rep(KKK[[row]][3],3), max(tpts)/3, max(tpts)/3*2,1)
}
modelVVV <- expressionData_integrativeModels(tpts, class = "VVV", parameters = parameters)
ratesVVV <- rates_integrativeModels(0, class = "VVV", parameters = parameters)
prematureEstimated <- modelVVV[grep("^mature",names(modelVVV))]
matureEstimated <- modelVVV[grep("^premature",names(modelVVV))]
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
alphaEstimated <- ratesVVV[grep("alpha",names(ratesVVV))]
betaEstimated <- ratesVVV[grep("beta",names(ratesVVV))]
gammaEstimated <- ratesVVV[grep("gamma",names(ratesVVV))]
capture.output(impulsesParameters <- unlist(
tryCatch(
optim(unname(c(k1Parameters, k2Parameters, k3Parameters))
,errorVVV_Int
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((alphaKKK-alphaEstimated)^2
, (betaKKK-betaEstimated)^2
, (gammaKKK-gammaEstimated)^2))
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean = FALSE
,control = list(maxit = nIter*10)),
error=function(e) c(par1 = NaN
, par2 = NaN
, par3 = NaN
, par4 = NaN
, par5 = NaN
, par6 = NaN
, par7 = NaN
, par8 = NaN
, par9 = NaN
, par10 = NaN
, par11 = NaN
, par12 = NaN
, par13 = NaN
, par14 = NaN
, par15 = NaN
, par16 = NaN
, par17 = NaN
, par18 = NaN
, value = NaN
, counts.function = NaN
, counts.gradient = NaN
, convergence = e)
)
))
if(!useSigmoidFun)return(impulsesParameters)
if(!is.finite(impulsesParameters[["value"]]))return(sigmoidsParameters)
if(!is.finite(sigmoidsParameters[["value"]]))return(impulsesParameters)
if(pchisq(impulsesParameters[["value"]],max(0,2*length(tpts) - 18)) < pchisq(sigmoidsParameters[["value"]],max(0,2*length(tpts) - 12))){return(impulsesParameters)}else{return(sigmoidsParameters)}
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
message("Model 'spd' finished.")
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
modelKKK <- expressionData_integrativeModels(tpts, class = "KKK", parameters = unlist(KKK[[g]][grep("par",names(KKK[[g]]))]))
matureModel <- modelKKK[grep("^mature",names(modelKKK))]
prematureModel <- modelKKK[grep("^premature",names(modelKKK))]
modelKKK <- c(matureModel,prematureModel)
KKKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKKK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelVKK <- expressionData_integrativeModels(tpts, class = "VKK", parameters = unlist(VKK[[g]][grep("par",names(VKK[[g]]))]))
matureModel <- modelVKK[grep("^mature",names(modelVKK))]
prematureModel <- modelVKK[grep("^premature",names(modelVKK))]
modelVKK <- c(matureModel,prematureModel)
VKKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVKK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelKVK <- expressionData_integrativeModels(tpts, class = "KVK", parameters = unlist(KVK[[g]][grep("par",names(KVK[[g]]))]))
matureModel <- modelKVK[grep("^mature",names(modelKVK))]
prematureModel <- modelKVK[grep("^premature",names(modelKVK))]
modelKVK <- c(matureModel,prematureModel)
KVKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKVK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelKKV <- expressionData_integrativeModels(tpts, class = "KKV", parameters = unlist(KKV[[g]][grep("par",names(KKV[[g]]))]))
matureModel <- modelKKV[grep("^mature",names(modelKKV))]
prematureModel <- modelKKV[grep("^premature",names(modelKKV))]
modelKKV <- c(matureModel,prematureModel)
KKVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKKV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelVVK <- expressionData_integrativeModels(tpts, class = "VVK", parameters = unlist(VVK[[g]][grep("par",names(VVK[[g]]))]))
matureModel <- modelVVK[grep("^mature",names(modelVVK))]
prematureModel <- modelVVK[grep("^premature",names(modelVVK))]
modelVVK <- c(matureModel,prematureModel)
VVKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVVK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelVKV <- expressionData_integrativeModels(tpts, class = "VKV", parameters = unlist(VKV[[g]][grep("par",names(VKV[[g]]))]))
matureModel <- modelVKV[grep("^mature",names(modelVKV))]
prematureModel <- modelVKV[grep("^premature",names(modelVKV))]
modelVKV <- c(matureModel,prematureModel)
VKVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVKV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelKVV <- expressionData_integrativeModels(tpts, class = "KVV", parameters = unlist(KVV[[g]][grep("par",names(KVV[[g]]))]))
matureModel <- modelKVV[grep("^mature",names(modelKVV))]
prematureModel <- modelKVV[grep("^premature",names(modelKVV))]
modelKVV <- c(matureModel,prematureModel)
KVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKVV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
modelVVV <- expressionData_integrativeModels(tpts, class = "VVV", parameters = unlist(VVV[[g]][grep("par",names(VVV[[g]]))]))
matureModel <- modelVVV[grep("^mature",names(modelVVV))]
prematureModel <- modelVVV[grep("^premature",names(modelVVV))]
modelVVV <- c(matureModel,prematureModel)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
c("KKK" = KKKTemp,"VKK" = VKKTemp,"KVK" = KVKTemp,"KKV" = KKVTemp,"VVK" = VVKTemp,"VKV" = VKVTemp,"KVV" = KVVTemp,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
dof <- cbind(KKK = sapply(KKK,function(m)length(grep("par",names(m))))
,VKK = sapply(VKK,function(m)length(grep("par",names(m))))
,KVK = sapply(KVK,function(m)length(grep("par",names(m))))
,KKV = sapply(KKV,function(m)length(grep("par",names(m))))
,VVK = sapply(VVK,function(m)length(grep("par",names(m))))
,VKV = sapply(VKV,function(m)length(grep("par",names(m))))
,KVV = sapply(KVV,function(m)length(grep("par",names(m))))
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- tryCatch(errorKKK_Int(parameters = KKK[[g]][grep("par",names(KKK[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL),error = function(e)NaN)
VKKTemp <- tryCatch(errorVKK_Int(parameters = VKK[[g]][grep("par",names(VKK[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
KVKTemp <- tryCatch(errorKVK_Int(parameters = KVK[[g]][grep("par",names(KVK[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
KKVTemp <- tryCatch(errorKKV_Int(parameters = KKV[[g]][grep("par",names(KKV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
VVKTemp <- tryCatch(errorVVK_Int(parameters = VVK[[g]][grep("par",names(VVK[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
VKVTemp <- tryCatch(errorVKV_Int(parameters = VKV[[g]][grep("par",names(VKV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
KVVTemp <- tryCatch(errorKVV_Int(parameters = KVV[[g]][grep("par",names(KVV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
VVVTemp <- tryCatch(errorVVV_Int(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
,tpts = tpts
,premature = prematureSmooth[g,]
,mature = matureSmooth[g,]
,alpha = NULL
,prematureVariance = prematureVariance[g,]
,matureVariance = matureVariance[g,]
,alphaVariance = NULL
,clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp, VKK = VKKTemp, KVK = KVKTemp, KKV = KKVTemp, VVK = VVKTemp, VKV = VKVTemp, KVV = KVVTemp, VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,2*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,2*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,2*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,2*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,2*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,2*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,2*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,2*length(tpts)-dof[g,'VVV'])))))
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KKK[[g]][1])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KKK[[g]][3])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKK[[g]][2])))
,test = log(pvaluesdata[g,"KKK"])
,logLik = logLikelihood[g,"KKK"]
,AIC = AIC[g,"KKK"]
,AICc = AICc[g,"KKK"]
,counts = c("function"=unname(KKK[[g]]["counts.function"]), gradient=unname(KKK[[g]]["counts.gradient"]))
,convergence = unname(KKK[[g]]["convergence"])
,message = NULL)
,"a" = if(length(grep("par",names(VKK[[g]])))==8)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VKK[[g]][1:6])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VKK[[g]][8])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKK[[g]][7])))
,test = log(pvaluesdata[g,"VKK"])
,logLik = logLikelihood[g,"VKK"]
,AIC = AIC[g,"VKK"]
,AICc = AICc[g,"VKK"]
,counts = c("function"=unname(VKK[[g]]["counts.function"]), gradient=unname(VKK[[g]]["counts.gradient"]))
,convergence = unname(VKK[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VKK[[g]][1:4])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VKK[[g]][6])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKK[[g]][5])))
,test = log(pvaluesdata[g,"VKK"])
,logLik = logLikelihood[g,"VKK"]
,AIC = AIC[g,"VKK"]
,AICc = AICc[g,"VKK"]
,counts = c("function"=unname(VKK[[g]]["counts.function"]), gradient=unname(VKK[[g]]["counts.gradient"]))
,convergence = unname(VKK[[g]]["convergence"])
,message = NULL)
}
,"b" = if(length(grep("par",names(KKV[[g]])))==8)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KKV[[g]][1])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(KKV[[g]][3:8])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKV[[g]][2])))
,test = log(pvaluesdata[g,"KKV"])
,logLik = logLikelihood[g,"KKV"]
,AIC = AIC[g,"KKV"]
,AICc = AICc[g,"KKV"]
,counts = c("function"=unname(KKV[[g]]["counts.function"]), gradient=unname(KKV[[g]]["counts.gradient"]))
,convergence = unname(KKV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KKV[[g]][1])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(KKV[[g]][3:6])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKV[[g]][2])))
,test = log(pvaluesdata[g,"KKV"])
,logLik = logLikelihood[g,"KKV"]
,AIC = AIC[g,"KKV"]
,AICc = AICc[g,"KKV"]
,counts = c("function"=unname(KKV[[g]]["counts.function"]), gradient=unname(KKV[[g]]["counts.gradient"]))
,convergence = unname(KKV[[g]]["convergence"])
,message = NULL)
}
,"c" = if(length(grep("par",names(KVK[[g]])))==8)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVK[[g]][1])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KVK[[g]][8])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(KVK[[g]][2:7])))
,test = log(pvaluesdata[g,"KVK"])
,logLik = logLikelihood[g,"KVK"]
,AIC = AIC[g,"KVK"]
,AICc = AICc[g,"KVK"]
,counts = c("function"=unname(KVK[[g]]["counts.function"]), gradient=unname(KVK[[g]]["counts.gradient"]))
,convergence = unname(KVK[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVK[[g]][1])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KVK[[g]][6])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(KVK[[g]][2:5])))
,test = log(pvaluesdata[g,"KVK"])
,logLik = logLikelihood[g,"KVK"]
,AIC = AIC[g,"KVK"]
,AICc = AICc[g,"KVK"]
,counts = c("function"=unname(KVK[[g]]["counts.function"]), gradient=unname(KVK[[g]]["counts.gradient"]))
,convergence = unname(KVK[[g]]["convergence"])
,message = NULL)
}
,"ab" = if(length(grep("par",names(VKV[[g]])))==13)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VKV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VKV[[g]][8:13])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKV[[g]][7])))
,test = log(pvaluesdata[g,"VKV"])
,logLik = logLikelihood[g,"VKV"]
,AIC = AIC[g,"VKV"]
,AICc = AICc[g,"VKV"]
,counts = c("function"=unname(VKV[[g]]["counts.function"]), gradient=unname(VKV[[g]]["counts.gradient"]))
,convergence = unname(VKV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VKV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VKV[[g]][6:9])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKV[[g]][5])))
,test = log(pvaluesdata[g,"VKV"])
,logLik = logLikelihood[g,"VKV"]
,AIC = AIC[g,"VKV"]
,AICc = AICc[g,"VKV"]
,counts = c("function"=unname(VKV[[g]]["counts.function"]), gradient=unname(VKV[[g]]["counts.gradient"]))
,convergence = unname(VKV[[g]]["convergence"])
,message = NULL)
}
,"ac" = if(length(grep("par",names(VVK[[g]])))==13)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VVK[[g]][1:6])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VVK[[g]][13])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVK[[g]][7:12])))
,test = log(pvaluesdata[g,"VVK"])
,logLik = logLikelihood[g,"VVK"]
,AIC = AIC[g,"VVK"]
,AICc = AICc[g,"VVK"]
,counts = c("function"=unname(VVK[[g]]["counts.function"]), gradient=unname(VVK[[g]]["counts.gradient"]))
,convergence = unname(VVK[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VVK[[g]][1:4])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VVK[[g]][9])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVK[[g]][5:8])))
,test = log(pvaluesdata[g,"VVK"])
,logLik = logLikelihood[g,"VVK"]
,AIC = AIC[g,"VVK"]
,AICc = AICc[g,"VVK"]
,counts = c("function"=unname(VVK[[g]]["counts.function"]), gradient=unname(VVK[[g]]["counts.gradient"]))
,convergence = unname(VVK[[g]]["convergence"])
,message = NULL)
}
,"bc" = if(length(grep("par",names(KVV[[g]])))==13)
{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVV[[g]][1])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(KVV[[g]][8:12])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(KVV[[g]][2:7])))
,test = log(pvaluesdata[g,"KVV"])
,logLik = logLikelihood[g,"KVV"]
,AIC = AIC[g,"KVV"]
,AICc = AICc[g,"KVV"]
,counts = c("function"=unname(KVV[[g]]["counts.function"]), gradient=unname(KVV[[g]]["counts.gradient"]))
,convergence = unname(KVV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVV[[g]][1])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(KVV[[g]][6:9])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(KVV[[g]][2:5])))
,test = log(pvaluesdata[g,"KVV"])
,logLik = logLikelihood[g,"KVV"]
,AIC = AIC[g,"KVV"]
,AICc = AICc[g,"KVV"]
,counts = c("function"=unname(KVV[[g]]["counts.function"]), gradient=unname(KVV[[g]]["counts.gradient"]))
,convergence = unname(KVV[[g]]["convergence"])
,message = NULL)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(alpha = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(alpha = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(alpha = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(alpha = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
return(ratesSpecs)
}
#####################################
### Errors integrative functions ####
#####################################
genericError_Int <- function(k1F,k2F,k3F
,Dk1F,Dk2F,Dk3F
,tpts
,premature, mature, alpha
,prematureVariance, matureVariance, alphaVariance
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = 1
,derivativePenalityRelevance = 10^-50
,clean)
{
D0_k1 <- Dk1F(0)
D0_k2 <- Dk2F(0)
D0_k3 <- Dk3F(0)
modData <- systemSolution(k1F,k2F,k3F,tpts)
prematureEstimated <- modData[grep("^premature",names(modData))]
matureEstimated <- modData[grep("^mature",names(modData))]
alphaEstimated <- k1F(tpts)
gammaEstimated <- k2F(tpts)
betaEstimated <- k3F(tpts)
modData[modData<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
gammaEstimated[gammaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
if(any(!is.finite(modData)) |
any(!is.finite(alphaEstimated)) |
any(!is.finite(gammaEstimated)) |
any(!is.finite(betaEstimated)) |
!is.finite(D0_k1) |
!is.finite(D0_k2) |
!is.finite(D0_k3)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean)
{
initialPenality <- 0
}else{
initialPenality <- initialPenalityRelevance*initialChisquare*((k1KKK_Int(0,KKK)-alphaEstimated[1])^2
+ (k2KKK_Int(0,KKK)-gammaEstimated[1])^2
+ (k3KKK_Int(0,KKK)-betaEstimated[1])^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_k1)+abs(D0_k2)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorKKK_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance)
{
if(parameters[1]<0)return(NaN)
if(parameters[2]<0)return(NaN)
if(parameters[3]<0)return(NaN)
k1Parameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
prematureEstimated <- rep(k1Parameters/k2Parameters,length(tpts))
matureEstimated <- rep(k1Parameters/k3Parameters,length(tpts))
alphaEstimated <- rep(k1Parameters,length(tpts))
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(alpha)&is.null(alphaVariance)){alphaChiSquare <- 0}else{alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)}
return(sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare)))
}
errorVKK_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==8)
{
k1F <- function(x) {impulseModel(x,parameters[1:6])}
Dk1F <- function(x){.DimpulseModel(x,parameters[1:6])}
k2F <- function(x) {parameters[7]}
Dk2F <- function(x){0}
k3F <- function(x) {parameters[8]}
Dk3F <- function(x){0}
}else{
k1F <- function(x) {sigmoidModel(x,parameters[1:4])}
Dk1F <- function(x){.DsigmoidModel(x,parameters[1:4])}
k2F <- function(x) {parameters[5]}
Dk2F <- function(x){0}
k3F <- function(x) {parameters[6]}
Dk3F <- function(x){0}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorKVK_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==8)
{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {impulseModel(x,parameters[2:7])}
Dk2F <- function(x){.DimpulseModel(x,parameters[2:7])}
k3F <- function(x) {parameters[8]}
Dk3F <- function(x){0}
}else{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {sigmoidModel(x,parameters[2:5])}
Dk2F <- function(x){.DsigmoidModel(x,parameters[2:5])}
k3F <- function(x) {parameters[6]}
Dk3F <- function(x){0}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorKKV_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==8)
{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {parameters[2]}
Dk2F <- function(x){0}
k3F <- function(x) {impulseModel(x,parameters[3:8])}
Dk3F <- function(x){.DimpulseModel(x,parameters[3:8])}
}else{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {parameters[2]}
Dk2F <- function(x){0}
k3F <- function(x) {sigmoidModel(x,parameters[3:6])}
Dk3F <- function(x){.DsigmoidModel(x,parameters[3:6])}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorVVK_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(x,parameters[1:6])}
Dk1F <- function(x){.DimpulseModel(x,parameters[1:6])}
k2F <- function(x) {impulseModel(x,parameters[7:12])}
Dk2F <- function(x){.DimpulseModel(x,parameters[7:12])}
k3F <- function(x) {parameters[13]}
Dk3F <- function(x){0}
}else{
k1F <- function(x) {sigmoidModel(x,parameters[1:4])}
Dk1F <- function(x){.DsigmoidModel(x,parameters[1:4])}
k2F <- function(x) {sigmoidModel(x,parameters[5:8])}
Dk2F <- function(x){.DsigmoidModel(x,parameters[5:8])}
k3F <- function(x) {parameters[9]}
Dk3F <- function(x){0}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorVKV_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==13)
{
k1F <- function(x) {impulseModel(x,parameters[1:6])}
Dk1F <- function(x){.DimpulseModel(x,parameters[1:6])}
k2F <- function(x) {parameters[7]}
Dk2F <- function(x){0}
k3F <- function(x) {impulseModel(x,parameters[8:13])}
Dk3F <- function(x){.DimpulseModel(x,parameters[8:13])}
}else{
k1F <- function(x) {sigmoidModel(x,parameters[1:4])}
Dk1F <- function(x){.DsigmoidModel(x,parameters[1:4])}
k2F <- function(x) {parameters[5]}
Dk2F <- function(x){0}
k3F <- function(x) {sigmoidModel(x,parameters[6:9])}
Dk3F <- function(x){.DsigmoidModel(x,parameters[6:9])}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorKVV_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==13)
{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {impulseModel(x,parameters[2:7])}
Dk2F <- function(x){.DimpulseModel(x,parameters[2:7])}
k3F <- function(x) {impulseModel(x,parameters[8:13])}
Dk3F <- function(x){.DimpulseModel(x,parameters[8:13])}
}else{
k1F <- function(x) {parameters[1]}
Dk1F <- function(x){0}
k2F <- function(x) {sigmoidModel(x,parameters[2:5])}
Dk2F <- function(x){.DsigmoidModel(x,parameters[2:5])}
k3F <- function(x) {sigmoidModel(x,parameters[6:9])}
Dk3F <- function(x){.DsigmoidModel(x,parameters[6:9])}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
errorVVV_Int <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==18)
{
k1F <- function(x) {impulseModel(x,parameters[1:6])}
Dk1F <- function(x){.DimpulseModel(x,parameters[1:6])}
k2F <- function(x) {impulseModel(x,parameters[7:12])}
Dk2F <- function(x){.DimpulseModel(x,parameters[7:12])}
k3F <- function(x) {impulseModel(x,parameters[13:18])}
Dk3F <- function(x){.DimpulseModel(x,parameters[13:18])}
}else{
k1F <- function(x) {sigmoidModel(x,parameters[1:4])}
Dk1F <- function(x){.DsigmoidModel(x,parameters[1:4])}
k2F <- function(x) {sigmoidModel(x,parameters[5:8])}
Dk2F <- function(x){.DsigmoidModel(x,parameters[5:8])}
k3F <- function(x) {sigmoidModel(x,parameters[9:12])}
Dk3F <- function(x){.DsigmoidModel(x,parameters[9:12])}
}
return(genericError_Int(k1F=k1F,k2F=k2F,k3F=k3F,Dk1F=Dk1F,Dk2F=Dk2F,Dk3F=Dk3F
,tpts=tpts
,premature=premature, mature=mature, alpha=alpha
,prematureVariance=prematureVariance, matureVariance=matureVariance, alphaVariance=alphaVariance
,KKK=KKK
,initialChisquare=initialChisquare
,initialDistances=initialDistances
,initialPenalityRelevance=initialPenalityRelevance
,derivativePenalityRelevance=derivativePenalityRelevance
,clean=clean))
}
fromSigmoidToImpulse <- function(sigmoidsParameters,tpts,nIter)
{
sigmoidProfile <- sigmoidModel(x=tpts,par=sigmoidsParameters)
internalError <- function(impulsesParameters,sigmoidsParameters,tpts)
{
impulseProfile <- impulseModel(x=tpts,par=impulsesParameters)
sigmoidProfile <- sigmoidModel(x=tpts,par=sigmoidsParameters)
if(any(impulseProfile<0))return(NaN)
chisqFunction(experiment=impulseProfile,model=sigmoidProfile,variance=impulseProfile)
}
optTmp <- optim(par=c(head(sigmoidProfile,1),median(sigmoidProfile),tail(sigmoidProfile,1),max(tpts)/3,2*max(tpts)/3,1)
,internalError
,sigmoidsParameters=sigmoidsParameters
,tpts=tpts
,control = list(maxit = nIter))
return(optTmp$par)
}
####################################################################
################ NEW INSPEcT DERIVATIVE APPROACHES #################
####################################################################
.inspect.engine_Derivative_Nascent <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
alphaVariance <- rates$alpha_var
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(premature)
message("Mature RNA fit.")
modelMatureRNAfun <- bplapply(eiGenes,function(i)
{
tryCatch(.chooseModel(tpts=tpts
, experiment=mature[i,]
, variance=matureVariance[i,]
, na.rm=na.rm
, sigmoid=useSigmoidFun
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
},BPPARAM=BPPARAM)
names(modelMatureRNAfun) <- eiGenes
accelerationCoefficient <- sapply(eiGenes, function(row)
{
matureParameters <- unname(modelMatureRNAfun[[row]]$params)
if(is.null(matureParameters)) return(NaN)
if(length(matureParameters)==6)
{
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
k2Parameters <- c(rep(mean(gamma[row,]),3), max(tpts)/3, max(tpts)/3*2, 1)
k3Parameters <- c(rep(mean(beta[row,]),3), max(tpts)/3, max(tpts)/3*2, 1)
parameters <- c(matureParameters,k2Parameters,k3Parameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- .DimpulseModel(0,parameters[7:12])
D0_k3 <- .DimpulseModel(0,parameters[13:18])
} else {
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
k2Parameters <- c(rep(mean(gamma[row,]),2), max(tpts)/3, 1)
k3Parameters <- c(rep(mean(beta[row,]),2), max(tpts)/3, 1)
parameters <- c(matureParameters,k2Parameters,k3Parameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- .DsigmoidModel(0,parameters[5:8])
D0_k3 <- .DsigmoidModel(0,parameters[9:12])
}
D0_P <- .DprematureVVV_Der(0, parameters)
prematureEstimated <- prematureVVV_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VVV_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(alphaEstimated)) &
all(is.finite(prematureEstimated)) &
all(is.finite(matureEstimated)) &
all(is.finite(c(D0_M, D0_P, D0_k2, D0_k3)))
) return(1)
suppressWarnings(optimize( function(x)
{
if(length(matureParameters)==6)
{
k2Parameters[1:3] <- k2Parameters[1:3]*x
k3Parameters[1:3] <- k3Parameters[1:3]*x
parameters <- c(matureParameters,k2Parameters,k3Parameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- .DimpulseModel(0,parameters[7:12])
D0_k3 <- .DimpulseModel(0,parameters[13:18])
}else{
k2Parameters[1:2] <- k2Parameters[1:2]*x
k3Parameters[1:2] <- k3Parameters[1:2]*x
parameters <- c(matureParameters,k2Parameters,k3Parameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- .DsigmoidModel(0,parameters[5:8])
D0_k3 <- .DsigmoidModel(0,parameters[9:12])
}
D0_P <- .DprematureVVV_Der(0, parameters)
prematureEstimated <- prematureVVV_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VVV_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(alphaEstimated)) &
all(is.finite(prematureEstimated)) &
all(is.finite(matureEstimated)) &
all(is.finite(c(D0_M, D0_P, D0_k2, D0_k3)))
) return(x) else NaN
},c(1, 1e5) ))$minimum
})
# saveRDS(accelerationCoefficient,"accelerationCoefficient.rds")
# eiGenes <- rownames(mature)
message("spd modeling.")
VVV <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
if(length(matureParameters)==6)
{
k2Parameters <- c(rep(mean(gamma[row,]),3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
k3Parameters <- c(rep(mean(beta[row,]),3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
}else{
k2Parameters <- c(rep(mean(gamma[row,]),2)*accelerationCoefficient[row], max(tpts)/3, 1)
k3Parameters <- c(rep(mean(beta[row,]),2)*accelerationCoefficient[row], max(tpts)/3, 1)
}
unlist(
tryCatch(
optim(unname(c(matureParameters, k2Parameters, k3Parameters))
,errorVVV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
# saveRDS(VVV,"VVV.rds")
### Confidence intervals
message("Confidence intervals.")
confidenceIntervals <- bplapply(eiGenes,function(g)
{
classTmp <- "VVV"
parameters <- VVV[[g]][grep("par",names(VVV[[g]]))]
optTmp <- rates_derivativeModels(tpts=tpts, class=classTmp, parameters=parameters)
foe <- capture.output({ # Just to capture the output of multiroot function
suppressWarnings({
intervals <- sapply(names(parameters),function(parname)
{
par <- parameters[parname]
mOut = list(
left_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e-2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
left_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1/2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
center = tryCatch(multiroot(f = logLikelihoodCIerror, start = par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
right_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1.5*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
right_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList))
)
precis = sapply(mOut, '[[', 'f.root')
if( length(which(precis<1e-2))>0 ) {
conf_int = sapply(mOut[which(precis<1e-2)], '[[', 'root')
low_int = min(conf_int)
high_int = max(conf_int)
left = ifelse( low_int < par, low_int, NA)
right = ifelse( high_int > par, high_int, NA)
left = unname(left)
right = unname(right)
} else {
left = NA
right = NA
}
return(c(left,right))
})
intervals[1,!is.finite(intervals[2,])] <- NaN
intervals[2,!is.finite(intervals[1,])] <- NaN
})
})
perturbedRates <- matrix(rep(NaN,3*length(tpts)),ncol=1)
for(parname in names(parameters))
{
for(extremePar in intervals[,parname])
{
perturbedParameters <- parameters
perturbedParameters[parname] <- extremePar
perturbedRates <- cbind(perturbedRates,rates_derivativeModels(tpts=tpts, class=classTmp, parameters=perturbedParameters))
}
};perturbedRates <- perturbedRates[,-1]
perturbedRates[perturbedRates<0] <- 0
k1left <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k1TC <- optTmp[grep("alpha",names(optTmp))]
k1right <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k2left <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k2TC <- optTmp[grep("gamma",names(optTmp))]
k2right <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k3left <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k3TC <- optTmp[grep("beta",names(optTmp))]
k3right <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,max,na.rm=TRUE)
return(list(
k1 = cbind(left=k1left, opt=k1TC, right=k1right),
k2 = cbind(left=k2left, opt=k2TC, right=k2right),
k3 = cbind(left=k3left, opt=k3TC, right=k3right)
))
},BPPARAM=BPPARAM)
names(confidenceIntervals) <- eiGenes
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if((!is.finite(row[1])|row[1]==row[2])&(is.finite(row[3])&row[3]!=row[2])) row[1] <- row[2] - (row[3]-row[2])
if((!is.finite(row[3])|row[3]==row[2])&(is.finite(row[1])&row[1]!=row[2])) row[3] <- row[2] + (row[2]-row[1])
row
}))
}
}
k1_low <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k1_high <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k2_low <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k2_high <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k3_low <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
k3_high <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
### Possible for very few genes
#
if(k1_low==0)k1_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k1_high==0)k1_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k2_low==0)k2_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k2_high==0)k2_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k3_low==0)k3_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
if(k3_high==0)k3_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
median_low <- c(k1=k1_low,k2=k2_low,k3=k3_low)
median_high <- c(k1=k1_high,k2=k2_high,k3=k3_high)
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if(is.finite(row[2]))
{
if(row[1]==row[2] & row[1]==row[3]) {row[1] <- row[2]*(1-median_low[[r]]); row[3] <- row[2]*(1+median_high[[r]])}
}
row
}))
}
}
# Removal of not modeled genes
eiGenes <- eiGenes[sapply(confidenceIntervals,function(g)all(is.finite(g[[1]]))&all(is.finite(g[[2]]))&all(is.finite(g[[3]])))]
confidenceIntervals <- confidenceIntervals[eiGenes]
VVV <- VVV[eiGenes]
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
# I compute che constant rates
fitResults_synthesis <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k1"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
tryCatch(optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)$par, error=function(e) NaN)
}))
fitResults_processing <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k2"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
tryCatch(optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)$par, error=function(e) NaN)
}))
fitResults_degradation <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k3"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
tryCatch(optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)$par, error=function(e) NaN)
}))
names(fitResults_synthesis) <-
names(fitResults_processing) <-
names(fitResults_degradation) <- eiGenes
confidenceIntervals <- lapply(eiGenes,function(g)
{
confidenceIntervals[[g]][['k1']] <- cbind(confidenceIntervals[[g]][['k1']],'constant'=rep(fitResults_synthesis[[g]],length(tpts)))
confidenceIntervals[[g]][['k2']] <- cbind(confidenceIntervals[[g]][['k2']],'constant'=rep(fitResults_processing[[g]],length(tpts)))
confidenceIntervals[[g]][['k3']] <- cbind(confidenceIntervals[[g]][['k3']],'constant'=rep(fitResults_degradation[[g]],length(tpts)))
confidenceIntervals[[g]]
})
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
### Standard outputs
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
prematureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
alphaVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)k1VVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
modelVVV <- c(matureVVVTemp,prematureVVVTemp,alphaVVVTemp)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,],alpha[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,],alphaVariance[g,])),error=function(e)NaN)
c("KKK" = NaN,"VKK" = NaN,"KVK" = NaN,"KKV" = NaN,"VVK" = NaN,"VKV" = NaN,"KVV" = NaN,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
### Common code for confidence bars computation
# dof
dof <- cbind(KKK = NaN
,VKK = NaN
,KVK = NaN
,KKV = NaN
,VVK = NaN
,VKV = NaN
,KVV = NaN
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- NaN
VKKTemp <- NaN
KVKTemp <- NaN
KKVTemp <- NaN
VVKTemp <- NaN
VKVTemp <- NaN
KVVTemp <- NaN
VVVTemp <- tryCatch(errorVVV_Der(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = alpha[g,]
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = alphaVariance[g,]
, clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp,VKK = VKKTemp,KVK = KVKTemp,KKV = KKVTemp,VVK = VVKTemp,VKV = VKVTemp,KVV = KVVTemp,VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,3*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,3*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,3*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,3*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,3*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,3*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,3*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,3*length(tpts)-dof[g,'VVV'])))))
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(mature = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
,"a" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"b" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"c" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ab" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ac" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"bc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
out <- list(ratesSpecs=ratesSpecs[eiGenes], confidenceIntervals=confidenceIntervals)
return(out)
}
.inspect.engine_Derivative_Nascent_sdp <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
alphaVariance <- rates$alpha_var
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(premature)
message("Mature RNA fit.")
modelMatureRNAfun <- bplapply(eiGenes,function(i)
{
tryCatch(.chooseModel(tpts=tpts
, experiment=mature[i,]
, variance=matureVariance[i,]
, na.rm=na.rm
, sigmoid=useSigmoidFun
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
},BPPARAM=BPPARAM)
names(modelMatureRNAfun) <- eiGenes
message("spd modeling.")
VVV <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
if(length(matureParameters)==6)
{
k2Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=gamma[row,]
, variance=gamma[row,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(mean(gamma[row,]),3), max(tpts)/3, max(tpts)/3*2, 1))
k3Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=beta[row,]
, variance=beta[row,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(mean(beta[row,]),3), max(tpts)/3, max(tpts)/3*2, 1))
}else{
k2Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=gamma[row,]
, variance=gamma[row,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(mean(gamma[row,]),2), max(tpts)/3, 1))
k3Parameters <- tryCatch(.chooseModel(tpts=tpts
, experiment=beta[row,]
, variance=beta[row,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = FALSE)$params,
error=function(e)
c(rep(mean(beta[row,]),2), max(tpts)/3, 1))
}
unlist(
tryCatch(
optim(unname(c(matureParameters, k2Parameters, k3Parameters))
,errorVVV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = alpha[row,]
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = alphaVariance[row,]
,KKK = NULL
,initialChisquare = NULL
,initialDistances = NULL
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
# saveRDS(VVV,"VVV.rds")
### Confidence intervals
message("Confidence intervals.")
confidenceIntervals <- bplapply(eiGenes,function(g)
{
classTmp <- "VVV"
parameters <- VVV[[g]][grep("par",names(VVV[[g]]))]
optTmp <- rates_derivativeModels(tpts=tpts, class=classTmp, parameters=parameters)
foe <- capture.output({ # Just to capture the output of multiroot function
suppressWarnings({
intervals <- sapply(names(parameters),function(parname)
{
par <- parameters[parname]
mOut = list(
left_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e-2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
left_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1/2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
center = tryCatch(multiroot(f = logLikelihoodCIerror, start = par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
right_1 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1.5*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList)),
right_2 = tryCatch(multiroot(f = logLikelihoodCIerror, start = 1e2*par, name = parname, parameters = parameters, class = classTmp, tpts = tpts, experimentalP = premature[g,], experimentalM = mature[g,], experimentalA = alpha[g,], varianceP = prematureVariance[g,], varianceM = matureVariance[g,], varianceA = alphaVariance[g,], confidenceThreshold = llConfidenceThreshold, derivative = TRUE),error=function(e)return(emptyList))
)
precis = sapply(mOut, '[[', 'f.root')
if( length(which(precis<1e-2))>0 ) {
conf_int = sapply(mOut[which(precis<1e-2)], '[[', 'root')
low_int = min(conf_int)
high_int = max(conf_int)
left = ifelse( low_int < par, low_int, NA)
right = ifelse( high_int > par, high_int, NA)
left = unname(left)
right = unname(right)
} else {
left = NA
right = NA
}
return(c(left,right))
})
intervals[1,!is.finite(intervals[2,])] <- NaN
intervals[2,!is.finite(intervals[1,])] <- NaN
})
})
perturbedRates <- matrix(rep(NaN,3*length(tpts)),ncol=1)
for(parname in names(parameters))
{
for(extremePar in intervals[,parname])
{
perturbedParameters <- parameters
perturbedParameters[parname] <- extremePar
perturbedRates <- cbind(perturbedRates,rates_derivativeModels(tpts=tpts, class=classTmp, parameters=perturbedParameters))
}
};perturbedRates <- perturbedRates[,-1]
perturbedRates[perturbedRates<0] <- 0
k1left <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k1TC <- optTmp[grep("alpha",names(optTmp))]
k1right <- apply(perturbedRates[grep("alpha",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k2left <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k2TC <- optTmp[grep("gamma",names(optTmp))]
k2right <- apply(perturbedRates[grep("gamma",rownames(perturbedRates)),],1,max,na.rm=TRUE)
k3left <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,min,na.rm=TRUE)
k3TC <- optTmp[grep("beta",names(optTmp))]
k3right <- apply(perturbedRates[grep("beta",rownames(perturbedRates)),],1,max,na.rm=TRUE)
return(list(
k1 = cbind(left=k1left, opt=k1TC, right=k1right),
k2 = cbind(left=k2left, opt=k2TC, right=k2right),
k3 = cbind(left=k3left, opt=k3TC, right=k3right)
))
},BPPARAM=BPPARAM)
names(confidenceIntervals) <- eiGenes
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if((!is.finite(row[1])|row[1]==row[2])&(is.finite(row[3])&row[3]!=row[2])) row[1] <- row[2] - (row[3]-row[2])
if((!is.finite(row[3])|row[3]==row[2])&(is.finite(row[1])&row[1]!=row[2])) row[3] <- row[2] + (row[2]-row[1])
row
}))
}
}
k1_low <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k1_high <- median(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
k2_low <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k2_high <- median(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
k3_low <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
k3_high <- median(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
### Possible for very few genes
#
if(k1_low==0)k1_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,2] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k1_high==0)k1_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[1]][,3] - g[[1]][,1])/g[[1]][,1]}),na.rm=TRUE)
if(k2_low==0)k2_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,2] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k2_high==0)k2_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[2]][,3] - g[[2]][,1])/g[[2]][,1]}),na.rm=TRUE)
if(k3_low==0)k3_low <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,2] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
if(k3_high==0)k3_high <- mean(sapply(confidenceIntervals,function(g){abs(g[[3]][,3] - g[[3]][,1])/g[[3]][,1]}),na.rm=TRUE)
median_low <- c(k1=k1_low,k2=k2_low,k3=k3_low)
median_high <- c(k1=k1_high,k2=k2_high,k3=k3_high)
for(g in seq_along(confidenceIntervals))
{
for(r in 1:3)
{
confidenceIntervals[[g]][[r]] <- t(apply(confidenceIntervals[[g]][[r]],1,function(row)
{
if(is.finite(row[2]))
{
if(row[1]==row[2] & row[1]==row[3]) {row[1] <- row[2]*(1-median_low[[r]]); row[3] <- row[2]*(1+median_high[[r]])}
}
row
}))
}
}
# Removal of not modeled genes
eiGenes <- eiGenes[sapply(confidenceIntervals,function(g)all(is.finite(g[[1]]))&all(is.finite(g[[2]]))&all(is.finite(g[[3]])))]
confidenceIntervals <- confidenceIntervals[eiGenes]
VVV <- VVV[eiGenes]
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
# I compute che constant rates
fitResults_synthesis <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k1"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_processing <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k2"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
fitResults_degradation <- unlist(lapply(eiGenes,function(g)
{
rate_conf_int <- confidenceIntervals[[g]][["k3"]]
k_start <- mean(rate_conf_int[,2],na.rm=TRUE)
if(!is.finite(k_start)) NaN #return(list(par=NaN, value=NaN))
k_scores_out <- optim(k_start, k_score_fun, method='BFGS', rate_conf_int=rate_conf_int)
return(k_scores_out$par)
}))
names(fitResults_synthesis) <-
names(fitResults_processing) <-
names(fitResults_degradation) <- eiGenes
confidenceIntervals <- lapply(eiGenes,function(g)
{
confidenceIntervals[[g]][['k1']] <- cbind(confidenceIntervals[[g]][['k1']],'constant'=rep(fitResults_synthesis[[g]],length(tpts)))
confidenceIntervals[[g]][['k2']] <- cbind(confidenceIntervals[[g]][['k2']],'constant'=rep(fitResults_processing[[g]],length(tpts)))
confidenceIntervals[[g]][['k3']] <- cbind(confidenceIntervals[[g]][['k3']],'constant'=rep(fitResults_degradation[[g]],length(tpts)))
confidenceIntervals[[g]]
})
# saveRDS(confidenceIntervals,"confidenceIntervals.rds")
### Standard outputs
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
prematureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
alphaVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)k1VVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
modelVVV <- c(matureVVVTemp,prematureVVVTemp,alphaVVVTemp)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,],alpha[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,],alphaVariance[g,])),error=function(e)NaN)
c("KKK" = NaN,"VKK" = NaN,"KVK" = NaN,"KKV" = NaN,"VVK" = NaN,"VKV" = NaN,"KVV" = NaN,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
### Common code for confidence bars computation
# dof
dof <- cbind(KKK = NaN
,VKK = NaN
,KVK = NaN
,KKV = NaN
,VVK = NaN
,VKV = NaN
,KVV = NaN
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- NaN
VKKTemp <- NaN
KVKTemp <- NaN
KKVTemp <- NaN
VVKTemp <- NaN
VKVTemp <- NaN
KVVTemp <- NaN
VVVTemp <- tryCatch(errorVVV_Der(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = alpha[g,]
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = alphaVariance[g,]
, clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp,VKK = VKKTemp,KVK = KVKTemp,KKV = KKVTemp,VVK = VVKTemp,VKV = VKVTemp,KVV = KVVTemp,VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,3*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,3*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,3*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,3*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,3*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,3*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,3*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,3*length(tpts)-dof[g,'VVV'])))))
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(mature = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
,"a" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"b" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"c" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ab" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"ac" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"bc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = NaN)
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = NaN)
,test = NaN
,logLik = NaN
,AIC = NaN
,AICc = NaN
,counts = NaN
,convergence = NaN
,message = NaN)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
out <- list(ratesSpecs=ratesSpecs[eiGenes], confidenceIntervals=confidenceIntervals)
return(out)
}
.inspect.engine_Derivative_NoNascent <- function(tpts
, concentrations
, rates
, BPPARAM
, na.rm
, verbose
# , testOnSmooth
, seed
, nInit
, nIter
, computeDerivatives = TRUE
, useSigmoidFun = TRUE
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, llConfidenceThreshold)
{
total <- concentrations$total
totalVariance <- concentrations$total_var
premature <- concentrations$preMRNA
prematureVariance <- concentrations$preMRNA_var
mature <- concentrations$mature
matureVariance <- concentrations$mature_var
alpha <- rates$alpha
beta <- rates$beta
gamma <- rates$gamma
prematureSmooth <- premature
matureSmooth <- mature
eiGenes <- rownames(total)
message("Evaluating the functional form for:")
message(" mature RNA")
modelMatureRNAfun <- bplapply(eiGenes,function(i)
{
tryCatch(.chooseModel(tpts=tpts
, experiment=mature[i,]
, variance=matureVariance[i,]
, na.rm=na.rm
, sigmoid=useSigmoidFun
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
},BPPARAM=BPPARAM)
names(modelMatureRNAfun) <- eiGenes
#$# saveRDS(modelMatureRNAfun,"modelMatureRNAfun.rds")
message(" total RNA")
modelTotalRNAfun <- bplapply(eiGenes,function(i)
{
tryCatch(.chooseModel(tpts=tpts
, experiment=total[i,]
, variance=totalVariance[i,]
, na.rm=na.rm
, sigmoid=useSigmoidFun
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
},BPPARAM=BPPARAM)
names(modelTotalRNAfun) <- eiGenes
impulseGenes <- as.numeric(sapply(modelMatureRNAfun,"[[","type")=="impulse") +
as.numeric(sapply(modelTotalRNAfun,"[[","type")=="impulse")
impulseGenes <- eiGenes[impulseGenes!=2&impulseGenes!=0]
message(" mixed genes coercion: impulse")
for(i in impulseGenes)
{
modelMatureRNAfun[[i]] <- tryCatch(.chooseModel(tpts=tpts
, experiment=mature[i,]
, variance=matureVariance[i,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
modelTotalRNAfun[[i]] <- tryCatch(.chooseModel(tpts=tpts
, experiment=total[i,]
, variance=totalVariance[i,]
, na.rm=na.rm
, sigmoid=FALSE
, impulse=TRUE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
}
message(" mixed genes coercion: sigmoid")
sigmoidGenes <- eiGenes[!sapply(sapply(modelMatureRNAfun,"[[","message"),is.null)|!sapply(sapply(modelTotalRNAfun,"[[","message"),is.null)]
for(i in sigmoidGenes)
{
modelMatureRNAfun[[i]] <- tryCatch(.chooseModel(tpts=tpts
, experiment=mature[i,]
, variance=matureVariance[i,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
modelTotalRNAfun[[i]] <- tryCatch(.chooseModel(tpts=tpts
, experiment=total[i,]
, variance=totalVariance[i,]
, na.rm=na.rm
, sigmoid=TRUE
, impulse=FALSE
, polynomial=FALSE
, nInit=nInit
, nIter=nIter
, sigmoidModel=sigmoidModel
, impulseModel=impulseModel
, sigmoidModelP=sigmoidModelP
, impulseModelP=impulseModelP
, .polynomialModelP=.polynomialModelP
, seed = seed
, computeDerivatives = computeDerivatives
), error=function(e) return(.emptyGene(e)))
}
#$# saveRDS(modelMatureRNAfun,"modelMatureRNAfun.rds")
#$# saveRDS(modelTotalRNAfun,"modelTotalRNAfun.rds")
### KKK
KKK <- bplapply(eiGenes,function(row)
{
matureParameters <- tryCatch(mean(modelMatureRNAfun[[row]]$fun$value(tpts, modelMatureRNAfun[[row]]$params)),error=function(e)list(NaN))
k2Parameters <- mean(gamma,na.rm=TRUE)
k3Parameters <- mean(beta,na.rm=TRUE)
unlist(
tryCatch(
optim(c(matureParameters, k2Parameters, k3Parameters)
,errorKKK_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=c(NaN,NaN,NaN)
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(KKK) <- eiGenes
message("Model no-reg finished.")
#$# saveRDS(KKK,"KKK.rds")
### Acceleration coefficients
accelerationCoefficient <- sapply(eiGenes, function(row)
{
matureParameters <- unname(modelMatureRNAfun[[row]]$params)
if(is.null(matureParameters)) return(NaN)
k2Parameters <- KKK[[row]]["par2"]
k3Parameters <- KKK[[row]]["par3"]
parameters <- c(matureParameters,k2Parameters,k3Parameters)
prematureEstimated <- prematureVKK_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VKK_Der(x = tpts, parameters = parameters)
prematureEstimated[prematureEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
if(all(is.finite(alphaEstimated)) & all(is.finite(prematureEstimated))) return(1)
suppressWarnings(optimize( function(x)
{
k2Parameters <- k2Parameters*x
k2Tmp <- k2Parameters*length(tpts)
k3Parameters <- k3Parameters*x
k3Tmp <- k3Parameters*length(tpts)
parameters <- c(matureParameters,k2Parameters,k3Parameters)
prematureEstimated <- prematureVKK_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VKK_Der(x = tpts, parameters = parameters)
prematureEstimated[prematureEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
if(any(!is.finite(prematureEstimated))|any(!is.finite(alphaEstimated))) NaN else x
},c(1, 1e5) ))$minimum
})
#$# saveRDS(accelerationCoefficient,"accelerationCoefficient.rds")
accelerationCoefficient_constantSynthesis_variableDegradation <- sapply(eiGenes, function(row)
{
totalParameters <- modelTotalRNAfun[[row]]$params
if(is.null(totalParameters)) return(NaN)
k1Parameters <- k1KKK_Der(0,KKK[[row]][1:3])
k3Parameters <- KKK[[row]]["par3"]
parameters <- c(totalParameters,k1Parameters,k3Parameters)
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[7], length(tpts))
betaEstimated <- rep(parameters[8], length(tpts))
} else {
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[5], length(tpts))
betaEstimated <- rep(parameters[6], length(tpts))
}
prematureEstimated <- sapply(tpts,function(t)prematureKVK_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
gammaEstimated <- sapply(tpts,function(t)k2KVK_Der(t, parameters))
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(c(totalEstimated,alphaEstimated,betaEstimated,prematureEstimated,matureEstimated,gammaEstimated)))) return(1)
suppressWarnings(optimize(function(x)
{
parameters <- c(totalParameters,k1Parameters,k3Parameters*x)
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[7], length(tpts))
betaEstimated <- rep(parameters[8], length(tpts))
} else {
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[5], length(tpts))
betaEstimated <- rep(parameters[6], length(tpts))
}
prematureEstimated <- sapply(tpts,function(t)prematureKVK_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
gammaEstimated <- sapply(tpts,function(t)k2KVK_Der(t, parameters))
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(c(totalEstimated
,alphaEstimated
,betaEstimated
,prematureEstimated
,matureEstimated)))) x else NaN
},c(1,1e5)))$minimum
})
#$# saveRDS(accelerationCoefficient_constantSynthesis_variableDegradation,"accelerationCoefficient_constantSynthesis_variableDegradation.rds")
accelerationCoefficient_constantSynthesis_variableProcessing <- sapply(eiGenes, function(row)
{
totalParameters <- modelTotalRNAfun[[row]]$params
if(is.null(totalParameters)) return(NaN)
k1Parameters <- k1KKK_Der(0,KKK[[row]][1:3])
k2Parameters <- KKK[[row]]["par2"]
parameters <- c(totalParameters,k1Parameters,k2Parameters)
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[7], length(tpts))
gammaEstimated <- rep(parameters[8], length(tpts))
} else {
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[5], length(tpts))
gammaEstimated <- rep(parameters[6], length(tpts))
}
prematureEstimated <- sapply(tpts,function(t)prematureKKV_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
betaEstimated <- sapply(tpts,function(t)k3KKV_Der(t, parameters))
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(c(totalEstimated,alphaEstimated,betaEstimated,prematureEstimated,matureEstimated,gammaEstimated)))) return(1)
suppressWarnings(optimize( function(x)
{
parameters <- c(totalParameters,k1Parameters,k2Parameters*x)
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[7], length(tpts))
gammaEstimated <- rep(parameters[8], length(tpts))
} else {
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
alphaEstimated <- rep(parameters[5], length(tpts))
gammaEstimated <- rep(parameters[6], length(tpts))
}
prematureEstimated <- sapply(tpts,function(t)prematureKKV_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
betaEstimated <- sapply(tpts,function(t)k3KKV_Der(t, parameters))
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(all(is.finite(c(totalEstimated
,alphaEstimated
,betaEstimated
,prematureEstimated
,matureEstimated)))) x else NaN
},c(1,1e5)))$minimum
})
#$# saveRDS(accelerationCoefficient_constantSynthesis_variableProcessing,"accelerationCoefficient_constantSynthesis_variableProcessing.rds")
# VKK
VKK <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
k2Parameters <- accelerationCoefficient[row]*KKK[[row]]["par2"]
k3Parameters <- accelerationCoefficient[row]*KKK[[row]]["par3"]
parameters <- unname(c(matureParameters,k2Parameters,k3Parameters))
prematureEstimated <- prematureVKK_Der(x = tpts, parameters = parameters)
matureEstimated <- matureVKK_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VKK_Der(x = tpts, parameters = parameters)
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorVKK_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1VKK_Der(0,parameters))^2
,(k2KKK_Der(0,KKK[[row]])-k2VKK_Der(0,parameters))^2
,(k3KKK_Der(0,KKK[[row]])-k3VKK_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
,"value" = NaN
,"counts" = c("function" = NaN, "gradient" = NaN)
,"convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VKK) <- eiGenes
message("Model 's' finished.")
#$# saveRDS(VKK,"VKK.rds")
# KKV
KKV <- bplapply(eiGenes,function(row){
totalParameters <- modelTotalRNAfun[[row]]$params
k1Parameters <- k1KKK_Der(0,KKK[[row]][1:3])
k2Parameters <- accelerationCoefficient_constantSynthesis_variableProcessing[row]*KKK[[row]]["par2"]
parameters <- unname(c(totalParameters, k1Parameters, k2Parameters))
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts, function(t)impulseModel(t, totalParameters))
}else{
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts, function(t)sigmoidModel(t, totalParameters))
}
prematureEstimated <- sapply(tpts, function(x)prematureKKV_Der(x, parameters))
matureEstimated <- totalEstimated - prematureEstimated
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorKKV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1KKV_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2KKV_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3KKV_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(totalParameters, k1Parameters, k2Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(KKV) <- eiGenes
message("Model 'd' finished.")
#$# saveRDS(KKV,"KKV.rds")
# KVK
KVK <- bplapply(eiGenes,function(row){
totalParameters <- modelTotalRNAfun[[row]]$params
k1Parameters <- k1KKK_Der(0,KKK[[row]][1:3])
k3Parameters <- accelerationCoefficient_constantSynthesis_variableDegradation[row]*KKK[[row]]["par3"]
parameters <- unname(c(totalParameters, k1Parameters, k3Parameters))
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
} else {
totalParameters <- parameters[1:4]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
}
prematureEstimated <- sapply(tpts,function(t)prematureKVK_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
prematureChiSquare <- sum((premature[row,] - prematureEstimated)^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorKVK_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1KVK_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2KVK_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3KVK_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(totalParameters, k1Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(KVK) <- eiGenes
message("Model 'p' finished.")
#$# saveRDS(KVK,"KVK.rds")
# VKV
VKV <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
k2Parameters <- accelerationCoefficient[row]*KKK[[row]]["par2"]
if(length(matureParameters)==6)
{
k3Parameters <- c(rep(KKK[[row]]["par3"],3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
}else{
k3Parameters <- c(rep(KKK[[row]]["par3"],2)*accelerationCoefficient[row], max(tpts)/3, 1)
}
parameters <- unname(c(matureParameters, k2Parameters, k3Parameters))
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
}
prematureEstimated <- prematureVKV_Der(x = tpts, parameters = parameters)
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorVKV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1VKV_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2VKV_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3VKV_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VKV) <- eiGenes
message("Model 'sd' finished.")
#$# saveRDS(VKV,"VKV.rds")
# VVK
VVK <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
if(length(matureParameters)==6)
{
k2Parameters <- c(rep(KKK[[row]]["par2"],3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
}else{
k2Parameters <- c(rep(KKK[[row]]["par2"],2)*accelerationCoefficient[row], max(tpts)/3, 1)
}
k3Parameters <- accelerationCoefficient[row]*KKK[[row]]["par3"]
parameters <- unname(c(matureParameters, k2Parameters, k3Parameters))
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
}
prematureEstimated <- prematureVVK_Der(x = tpts, parameters = parameters)
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorVVK_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1VVK_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2VVK_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3VVK_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VVK) <- eiGenes
message("Model 'sp' finished.")
#$# saveRDS(VVK,"VVK.rds")
# KVV
KVV <- bplapply(eiGenes,function(row){
totalParameters <- modelTotalRNAfun[[row]]$params
k1Parameters <- k1KKK_Der(0,KKK[[row]][1:3])
if(length(totalParameters)==6)
{
k3Parameters <- c(rep(KKK[[row]]["par3"],3)*accelerationCoefficient_constantSynthesis_variableDegradation[row], max(tpts)/3, max(tpts)/3*2, 1)
}else{
k3Parameters <- c(rep(KKK[[row]]["par3"],2)*accelerationCoefficient_constantSynthesis_variableDegradation[row], max(tpts)/3, 1)
}
parameters <- unname(c(totalParameters, k1Parameters, k3Parameters))
prematureEstimated <- sapply(tpts,function(t)prematureKVV_Der(x = t, parameters = parameters))
matureEstimated <- matureKVV_Der(tpts,parameters)
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorKVV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1KVV_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2KVV_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3KVV_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(totalParameters, k1Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(KVV) <- eiGenes
message("Model 'pd' finished.")
#$# saveRDS(KVV,"KVV.rds")
# VVV
VVV <- bplapply(eiGenes,function(row){
matureParameters <- tryCatch(unname(modelMatureRNAfun[[row]]$params),error=function(e) rep(NaN, length(tpts)))
if(length(matureParameters)==6)
{
k2Parameters <- c(rep(KKK[[row]]["par2"],3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
k3Parameters <- c(rep(KKK[[row]]["par3"],3)*accelerationCoefficient[row], max(tpts)/3, max(tpts)/3*2, 1)
}else{
k2Parameters <- c(rep(KKK[[row]]["par2"],2)*accelerationCoefficient[row], max(tpts)/3, 1)
k3Parameters <- c(rep(KKK[[row]]["par3"],2)*accelerationCoefficient[row], max(tpts)/3, 1)
}
parameters <- unname(c(matureParameters, k2Parameters, k3Parameters))
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
}
prematureEstimated <- prematureVVV_Der(x = tpts, parameters = parameters)
prematureChiSquare <- sum((premature[row,] - prematureEstimated )^2/prematureVariance[row,])
matureChiSquare <- sum((mature[row,] - matureEstimated)^2/matureVariance[row,])
unlist(
tryCatch(
optim(parameters
,errorVVV_Der
,tpts = tpts
,premature = premature[row,]
,mature = mature[row,]
,alpha = NULL
,prematureVariance = prematureVariance[row,]
,matureVariance = matureVariance[row,]
,alphaVariance = NULL
,KKK = KKK[[row]]
,initialChisquare = sum(c(prematureChiSquare,matureChiSquare))
,initialDistances = sum(c((k1KKK_Der(0,KKK[[row]])-k1VVV_Der(0,parameters))^2
, (k2KKK_Der(0,KKK[[row]])-k2VVV_Der(0,parameters))^2
, (k3KKK_Der(0,KKK[[row]])-k3VVV_Der(0,parameters))^2))
,initialPenalityRelevance = initialPenalityRelevance
,derivativePenalityRelevance = derivativePenalityRelevance
,clean = FALSE
,control = list(maxit = nIter * 1000)),
error=function(e) list("par"=rep(NaN,length(c(matureParameters, k2Parameters, k3Parameters)))
, "value" = NaN
, "counts" = c("function" = NaN, "gradient" = NaN)
, "convergence" = NaN)
)
)
}, BPPARAM=BPPARAM)
names(VVV) <- eiGenes
message("Model 'spd' finished.")
#$# saveRDS(VVV,"VVV.rds")
# Log likelihood
logLikelihood <- t(sapply(eiGenes,function(g)
{
prematureKKKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureKKK_Der(x = tpts[t], parameters = KKK[[g]][grep("par",names(KKK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureKVKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureKVK_Der(x = tpts[t], parameters = KVK[[g]][grep("par",names(KVK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureKKVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureKKV_Der(x = tpts[t], parameters = KKV[[g]][grep("par",names(KKV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureVKKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVKK_Der(x = tpts[t], parameters = VKK[[g]][grep("par",names(VKK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureVVKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVVK_Der(x = tpts[t], parameters = VVK[[g]][grep("par",names(VVK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureVKVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVKV_Der(x = tpts[t], parameters = VKV[[g]][grep("par",names(VKV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureKVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureKVV_Der(x = tpts[t], parameters = KVV[[g]][grep("par",names(KVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
prematureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)prematureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureKKKTemp <- tryCatch(rep(KKK[[g]][[1]],length(tpts)),error=function(e)rep(NaN,length(tpts)))
matureVKKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVKK_Der(x = tpts[t], parameters = VKK[[g]][grep("par",names(VKK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureKVKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureKVK_Der(x = tpts[t], parameters = KVK[[g]][grep("par",names(KVK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureKKVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureKKV_Der(x = tpts[t], parameters = KKV[[g]][grep("par",names(KKV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureVVKTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVVK_Der(x = tpts[t], parameters = VVK[[g]][grep("par",names(VVK[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureVKVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVKV_Der(x = tpts[t], parameters = VKV[[g]][grep("par",names(VKV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureKVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureKVV_Der(x = tpts[t], parameters = KVV[[g]][grep("par",names(KVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
matureVVVTemp <- tryCatch(c(sapply(seq_along(tpts),function(t)matureVVV_Der(x = tpts[t], parameters = VVV[[g]][grep("par",names(VVV[[g]]))]))),error=function(e)rep(NaN,length(tpts)))
modelKKK <- c(matureKKKTemp,prematureKKKTemp)
modelKVK <- c(matureKVKTemp,prematureKVKTemp)
modelKKV <- c(matureKKVTemp,prematureKKVTemp)
modelVKK <- c(matureVKKTemp,prematureVKKTemp)
modelVVK <- c(matureVVKTemp,prematureVVKTemp)
modelVKV <- c(matureVKVTemp,prematureVKVTemp)
modelKVV <- c(matureKVVTemp,prematureKVVTemp)
modelVVV <- c(matureVVVTemp,prematureVVVTemp)
KKKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKKK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
KVKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKVK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
KKVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKKV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
VKKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVKK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
VVKTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVVK
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
VKVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVKV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
KVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelKVV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
VVVTemp <- tryCatch(logLikelihoodFunction(experiment = c(matureSmooth[g,],prematureSmooth[g,])
, model = modelVVV
, variance = c(matureVariance[g,],prematureVariance[g,])),error=function(e)NaN)
c("KKK" = KKKTemp,"VKK" = VKKTemp,"KVK" = KVKTemp,"KKV" = KKVTemp,"VVK" = VVKTemp,"VKV" = VKVTemp,"KVV" = KVVTemp,"VVV" = VVVTemp)
}))
rownames(logLikelihood) <- eiGenes
#$# saveRDS(logLikelihood,"logLikelihood.rds")
### Common code for confidence bars computation
# dof
dof <- cbind(KKK = sapply(KKK,function(m)length(grep("par",names(m))))
,VKK = sapply(VKK,function(m)length(grep("par",names(m))))
,KVK = sapply(KVK,function(m)length(grep("par",names(m))))
,KKV = sapply(KKV,function(m)length(grep("par",names(m))))
,VVK = sapply(VVK,function(m)length(grep("par",names(m))))
,VKV = sapply(VKV,function(m)length(grep("par",names(m))))
,KVV = sapply(KVV,function(m)length(grep("par",names(m))))
,VVV = sapply(VVV,function(m)length(grep("par",names(m)))))
AIC <- 2*(dof - logLikelihood)
AICc <- 2*(dof - logLikelihood) + (2*dof*(dof+1))/max(0,2*length(tpts)-dof-1)
#$# saveRDS(AIC,"AIC.rds")
#$# saveRDS(AICc,"AICc.rds")
chi2data <- t(mcsapply(eiGenes,function(g)
{
KKKTemp <- tryCatch(errorKKK_Der(parameters = KKK[[g]][grep("par",names(KKK[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL),error = function(e)NaN)
VKKTemp <- tryCatch(errorVKK_Der(parameters = VKK[[g]][grep("par",names(VKK[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
KVKTemp <- tryCatch(errorKVK_Der(parameters = KVK[[g]][grep("par",names(KVK[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
KKVTemp <- tryCatch(errorKKV_Der(parameters = KKV[[g]][grep("par",names(KKV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
VVKTemp <- tryCatch(errorVVK_Der(parameters = VVK[[g]][grep("par",names(VVK[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
VKVTemp <- tryCatch(errorVKV_Der(parameters = VKV[[g]][grep("par",names(VKV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
KVVTemp <- tryCatch(errorKVV_Der(parameters = KVV[[g]][grep("par",names(KVV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
VVVTemp <- tryCatch(errorVVV_Der(parameters = VVV[[g]][grep("par",names(VVV[[g]]))]
, tpts = tpts
, premature = prematureSmooth[g,]
, mature = matureSmooth[g,]
, alpha = NULL
, prematureVariance = prematureVariance[g,]
, matureVariance = matureVariance[g,]
, alphaVariance = NULL
, clean = TRUE),error = function(e)NaN)
c(KKK = KKKTemp,VKK = VKKTemp,KVK = KVKTemp,KKV = KKVTemp,VVK = VVKTemp,VKV = VKVTemp,KVV = KVVTemp,VVV = VVVTemp)
}, BPPARAM=BPPARAM))
rownames(chi2data) <- eiGenes
#$# saveRDS(chi2data,"chi2data.rds")
# P values
pvaluesdata <- cbind(KKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKK'], max(c(0,2*length(tpts)-dof[g,'KKK']))))
,VKK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKK'], max(c(0,2*length(tpts)-dof[g,'VKK']))))
,KVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVK'], max(c(0,2*length(tpts)-dof[g,'KVK']))))
,KKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KKV'], max(c(0,2*length(tpts)-dof[g,'KKV']))))
,VVK=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVK'], max(c(0,2*length(tpts)-dof[g,'VVK']))))
,VKV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VKV'], max(c(0,2*length(tpts)-dof[g,'VKV']))))
,KVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'KVV'], max(c(0,2*length(tpts)-dof[g,'KVV']))))
,VVV=sapply(eiGenes,function(g)pchisq(chi2data[g,'VVV'], max(c(0,2*length(tpts)-dof[g,'VVV'])))))
#$# saveRDS(pvaluesdata,"pvaluesdata.rds")
ratesSpecs <- lapply(eiGenes,function(g)
{
list("0" = list(mature = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(mature = unname(KKK[[g]]["par1"])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KKK[[g]]["par3"])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKK[[g]]["par2"])))
,test = log(pvaluesdata[g,"KKK"])
,logLik = logLikelihood[g,"KKK"]
,AIC = AIC[g,"KKK"]
,AICc = AICc[g,"KKK"]
,counts = c("function"=unname(KKK[[g]]["counts.function"]), gradient=unname(KKK[[g]]["counts.gradient"]))
,convergence = unname(KKK[[g]]["convergence"])
,message = NULL)
,"a" = if(length(grep("par",names(VKK[[g]])))==8)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VKK[[g]][1:6])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VKK[[g]][8])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKK[[g]][7])))
,test = log(pvaluesdata[g,"VKK"])
,logLik = logLikelihood[g,"VKK"]
,AIC = AIC[g,"VKK"]
,AICc = AICc[g,"VKK"]
,counts = c("function"=unname(VKK[[g]]["counts.function"]), gradient=unname(VKK[[g]]["counts.gradient"]))
,convergence = unname(VKK[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VKK[[g]][1:4])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VKK[[g]][6])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKK[[g]][5])))
,test = log(pvaluesdata[g,"VKK"])
,logLik = logLikelihood[g,"VKK"]
,AIC = AIC[g,"VKK"]
,AICc = AICc[g,"VKK"]
,counts = c("function"=unname(VKK[[g]]["counts.function"]), gradient=unname(VKK[[g]]["counts.gradient"]))
,convergence = unname(VKK[[g]]["convergence"])
,message = NULL)
}
,"b" = if(length(grep("par",names(KKV[[g]])))==8)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(total = unname(KKV[[g]][1:6])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KKV[[g]][7])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKV[[g]][8])))
,test = log(pvaluesdata[g,"KKV"])
,logLik = logLikelihood[g,"KKV"]
,AIC = AIC[g,"KKV"]
,AICc = AICc[g,"KKV"]
,counts = c("function"=unname(KKV[[g]]["counts.function"]), gradient=unname(KKV[[g]]["counts.gradient"]))
,convergence = unname(KKV[[g]]["convergence"])
,message = NULL)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(total = unname(KKV[[g]][1:4])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KKV[[g]][5])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(KKV[[g]][6])))
,test = log(pvaluesdata[g,"KKV"])
,logLik = logLikelihood[g,"KKV"]
,AIC = AIC[g,"KKV"]
,AICc = AICc[g,"KKV"]
,counts = c("function"=unname(KKV[[g]]["counts.function"]), gradient=unname(KKV[[g]]["counts.gradient"]))
,convergence = unname(KKV[[g]]["convergence"])
,message = NULL)
}
,"c" = if(length(grep("par",names(KVK[[g]])))==8)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(total = unname(KVK[[g]][1:6])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVK[[g]][7])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KVK[[g]][8])))
,test = log(pvaluesdata[g,"KVK"])
,logLik = logLikelihood[g,"KVK"]
,AIC = AIC[g,"KVK"]
,AICc = AICc[g,"KVK"]
,counts = c("function"=unname(KVK[[g]]["counts.function"]), gradient=unname(KVK[[g]]["counts.gradient"]))
,convergence = unname(KVK[[g]]["convergence"])
,message = NULL)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(total = unname(KVK[[g]][1:4])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVK[[g]][5])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(KVK[[g]][6])))
,test = log(pvaluesdata[g,"KVK"])
,logLik = logLikelihood[g,"KVK"]
,AIC = AIC[g,"KVK"]
,AICc = AICc[g,"KVK"]
,counts = c("function"=unname(KVK[[g]]["counts.function"]), gradient=unname(KVK[[g]]["counts.gradient"]))
,convergence = unname(KVK[[g]]["convergence"])
,message = NULL)
}
,"ab" = if(length(grep("par",names(VKV[[g]])))==13)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VKV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VKV[[g]][8:13])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKV[[g]][7])))
,test = log(pvaluesdata[g,"VKV"])
,logLik = logLikelihood[g,"VKV"]
,AIC = AIC[g,"VKV"]
,AICc = AICc[g,"VKV"]
,counts = c("function"=unname(VKV[[g]]["counts.function"]), gradient=unname(VKV[[g]]["counts.gradient"]))
,convergence = unname(VKV[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VKV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VKV[[g]][6:9])))
,gamma = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(gamma = unname(VKV[[g]][5])))
,test = log(pvaluesdata[g,"VKV"])
,logLik = logLikelihood[g,"VKV"]
,AIC = AIC[g,"VKV"]
,AICc = AICc[g,"VKV"]
,counts = c("function"=unname(VKV[[g]]["counts.function"]), gradient=unname(VKV[[g]]["counts.gradient"]))
,convergence = unname(VKV[[g]]["convergence"])
,message = NULL)
}
,"ac" = if(length(grep("par",names(VVK[[g]])))==13)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VVK[[g]][1:6])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VVK[[g]][13])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVK[[g]][7:12])))
,test = log(pvaluesdata[g,"VVK"])
,logLik = logLikelihood[g,"VVK"]
,AIC = AIC[g,"VVK"]
,AICc = AICc[g,"VVK"]
,counts = c("function"=unname(VVK[[g]]["counts.function"]), gradient=unname(VVK[[g]]["counts.gradient"]))
,convergence = unname(VVK[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VVK[[g]][1:4])))
,beta = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(beta = unname(VVK[[g]][9])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVK[[g]][5:8])))
,test = log(pvaluesdata[g,"VVK"])
,logLik = logLikelihood[g,"VVK"]
,AIC = AIC[g,"VVK"]
,AICc = AICc[g,"VVK"]
,counts = c("function"=unname(VVK[[g]]["counts.function"]), gradient=unname(VVK[[g]]["counts.gradient"]))
,convergence = unname(VVK[[g]]["convergence"])
,message = NULL)
}
,"bc" = if(length(grep("par",names(KVV[[g]])))==13)
{
list(total = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(total = unname(KVV[[g]][1:6])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVV[[g]][7])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(KVV[[g]][8:13])))
,test = log(pvaluesdata[g,"KVV"])
,logLik = logLikelihood[g,"KVV"]
,AIC = AIC[g,"KVV"]
,AICc = AICc[g,"KVV"]
,counts = c("function"=unname(KVV[[g]]["counts.function"]), gradient=unname(KVV[[g]]["counts.gradient"]))
,convergence = unname(KVV[[g]]["convergence"])
,message = NULL)
}else{
list(total = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(total = unname(KVV[[g]][1:4])))
,alpha = list(fun = constantModelP
,type = "constant"
,df = 1
,params = c(alpha = unname(KVV[[g]][5])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(KVV[[g]][6:9])))
,test = log(pvaluesdata[g,"KVV"])
,logLik = logLikelihood[g,"KVV"]
,AIC = AIC[g,"KVV"]
,AICc = AICc[g,"KVV"]
,counts = c("function"=unname(KVV[[g]]["counts.function"]), gradient=unname(KVV[[g]]["counts.gradient"]))
,convergence = unname(KVV[[g]]["convergence"])
,message = NULL)
}
,"abc" = if(length(grep("par",names(VVV[[g]])))==18)
{
list(mature = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(mature = unname(VVV[[g]][1:6])))
,beta = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(beta = unname(VVV[[g]][13:18])))
,gamma = list(fun = impulseModelP
,type = "impulse"
,df = 6
,params = c(gamma = unname(VVV[[g]][7:12])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}else{
list(mature = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(mature = unname(VVV[[g]][1:4])))
,beta = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(beta = unname(VVV[[g]][9:12])))
,gamma = list(fun = sigmoidModelP
,type = "sigmoid"
,df = 4
,params = c(gamma = unname(VVV[[g]][5:8])))
,test = log(pvaluesdata[g,"VVV"])
,logLik = logLikelihood[g,"VVV"]
,AIC = AIC[g,"VVV"]
,AICc = AICc[g,"VVV"]
,counts = c("function"=unname(VVV[[g]]["counts.function"]), gradient=unname(VVV[[g]]["counts.gradient"]))
,convergence = unname(VVV[[g]]["convergence"])
,message = NULL)
}
)
})
names(ratesSpecs) <- eiGenes
#$# saveRDS(ratesSpecs,"ratesSpecs.rds")
return(ratesSpecs)
}
####################################
### Errors derivative functions ####
####################################
errorKKK_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance)
{
if(parameters[1]<0)return(NaN)
if(parameters[2]<0)return(NaN)
if(parameters[3]<0)return(NaN)
matureParameters <- parameters[1]
prematureEstimated <- prematureKKK_Der(x = tpts, parameters = parameters)
matureEstimated <- rep(matureParameters,length(tpts))
alphaEstimated <- k1KKK_Der(x = tpts, parameters = parameters)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(alpha)&is.null(alphaVariance)){alphaChiSquare <- 0}else{alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)}
return(sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare)))
}
errorVKK_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==8)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- 0
D0_k3 <- 0
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- 0
D0_k3 <- 0
}
D0_P <- .DprematureVKK_Der(0, parameters)
prematureEstimated <- prematureVKK_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VKK_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
!is.finite(D0_M) |
!is.finite(D0_k2) |
!is.finite(D0_k3) |
!is.finite(D0_P)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1VKK_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2VKK_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3VKK_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_M)+abs(D0_P)+abs(D0_k2)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorKVK_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
D0_T <- .DimpulseModel(0,parameters[1:6])
} else {
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
D0_T <- .DsigmoidModel(0,parameters[1:4])
}
D0_k1 <- 0
D0_k3 <- 0
alphaEstimated <- rep(k1Parameters, length(tpts))
betaEstimated <- rep(k3Parameters, length(tpts))
gammaEstimated <- sapply(tpts,function(t)k2KVK_Der(t, parameters))
prematureEstimated <- sapply(tpts,function(t)prematureKVK_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
D0_P <- alphaEstimated[[1]] - gammaEstimated[[1]]*prematureEstimated[[1]]
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
gammaEstimated[gammaEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(betaEstimated)) |
any(!is.finite(gammaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
any(!is.finite(totalEstimated)) |
!is.finite(D0_T) |
!is.finite(D0_k1) |
!is.finite(D0_k3) |
!is.finite(D0_P)) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1KVK_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2KVK_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3KVK_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- (abs(D0_T)+abs(D0_P)+abs(D0_k1)+abs(D0_k3))
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorKKV_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k2Parameters <- parameters[8]
totalEstimated <- sapply(tpts, function(t)impulseModel(t, totalParameters))
D0_T <- .DimpulseModel(0,parameters[1:6])
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k2Parameters <- parameters[6]
totalEstimated <- sapply(tpts, function(t)sigmoidModel(t, totalParameters))
D0_T <- .DsigmoidModel(0,parameters[1:4])
}
D0_k1 <- 0
D0_k2 <- 0
alphaEstimated <- rep(k1Parameters, length(tpts))
gammaEstimated <- rep(k2Parameters, length(tpts))
betaEstimated <- sapply(tpts, function(x)k3KKV_Der(x, parameters))
prematureEstimated <- sapply(tpts, function(x)prematureKKV_Der(x, parameters))
matureEstimated <- totalEstimated - prematureEstimated
D0_P <- 0
totalEstimated[totalEstimated<0] <- NaN
alphaEstimated[alphaEstimated<0] <- NaN
gammaEstimated[gammaEstimated<0] <- NaN
betaEstimated[betaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(betaEstimated)) |
any(!is.finite(gammaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
!is.finite(D0_T) |
!is.finite(D0_k1) |
!is.finite(D0_k2) |
!is.finite(D0_P)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1KKV_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2KKV_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3KKV_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_T)+abs(D0_P)+abs(D0_k1)+abs(D0_k2)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorVVK_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- .DimpulseModel(0,parameters[7:12])
D0_k3 <- 0
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- .DsigmoidModel(0,parameters[5:8])
D0_k3 <- 0
}
D0_P <- .DprematureVVK_Der(0, parameters)
prematureEstimated <- prematureVVK_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VVK_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
!is.finite(D0_M) |
!is.finite(D0_k2) |
!is.finite(D0_k3) |
!is.finite(D0_P)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1VVK_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2VVK_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3VVK_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_M)+abs(D0_P)+abs(D0_k2)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorVKV_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- 0
D0_k3 <- .DimpulseModel(0,parameters[8:13])
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- 0
D0_k3 <- .DsigmoidModel(0,parameters[6:9])
}
D0_P <- .DprematureVKV_Der(0, parameters)
prematureEstimated <- prematureVKV_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VKV_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
!is.finite(D0_M) |
!is.finite(D0_k2) |
!is.finite(D0_k3) |
!is.finite(D0_P)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1VKV_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2VKV_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3VKV_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_M)+abs(D0_P)+abs(D0_k2)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorKVV_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 1
, clean
)
{
if(length(parameters)==13)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
totalEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = totalParameters))
alphaEstimated <- rep(k1Parameters, length(tpts))
betaEstimated <- sapply(tpts,function(t)impulseModel(x = t, par = k3Parameters))
D0_T <- .DimpulseModel(0, totalParameters)
D0_k1 <- 0
D0_k3 <- .DimpulseModel(0, k3Parameters)
} else {
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
totalEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = totalParameters))
alphaEstimated <- rep(k1Parameters, length(tpts))
betaEstimated <- sapply(tpts,function(t)sigmoidModel(x = t, par = k3Parameters))
D0_T <- .DsigmoidModel(0, totalParameters)
D0_k1 <- 0
D0_k3 <- .DsigmoidModel(0, k3Parameters)
}
gammaEstimated <- sapply(tpts,function(t)k2KVV_Der(t, parameters))
prematureEstimated <- sapply(tpts,function(t)prematureKVV_Der(x = t, parameters = parameters))
matureEstimated <- totalEstimated - prematureEstimated
D0_P <- alphaEstimated[[1]] - gammaEstimated[[1]]*prematureEstimated[[1]]
betaEstimated[betaEstimated<0] <- NaN
gammaEstimated[gammaEstimated<0] <- NaN
if(is.null(alpha)&is.null(alphaVariance))
{
alphaEstimated[alphaEstimated<0] <- NaN
}
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(betaEstimated)) |
any(!is.finite(gammaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
any(!is.finite(totalEstimated)) |
!is.finite(D0_T) |
!is.finite(D0_k1) |
!is.finite(D0_k3) |
!is.finite(D0_P)) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1KVV_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2KVV_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3KVV_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_T)+abs(D0_P)+abs(D0_k1)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
errorVVV_Der <- function(parameters, tpts
, premature, mature, alpha
, prematureVariance, matureVariance, alphaVariance
, KKK = NULL
, initialChisquare = NULL
, initialDistances = NULL
, initialPenalityRelevance = 1
, derivativePenalityRelevance = 10^-50
, clean)
{
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
matureEstimated <- impulseModel(x = tpts, par = matureParameters)
D0_M <- .DimpulseModel(0,parameters[1:6])
D0_k2 <- .DimpulseModel(0,parameters[7:12])
D0_k3 <- .DimpulseModel(0,parameters[13:18])
} else {
matureParameters <- parameters[1:4]
matureEstimated <- sigmoidModel(x = tpts, par = matureParameters)
D0_M <- .DsigmoidModel(0,parameters[1:4])
D0_k2 <- .DsigmoidModel(0,parameters[5:8])
D0_k3 <- .DsigmoidModel(0,parameters[9:12])
}
D0_P <- .DprematureVVV_Der(0, parameters)
prematureEstimated <- prematureVVV_Der(x = tpts, parameters = parameters)
alphaEstimated <- k1VVV_Der(x = tpts, parameters = parameters)
alphaEstimated[alphaEstimated<0] <- NaN
prematureEstimated[prematureEstimated<0] <- NaN
matureEstimated[matureEstimated<0] <- NaN
if(any(!is.finite(alphaEstimated)) |
any(!is.finite(prematureEstimated)) |
any(!is.finite(matureEstimated)) |
!is.finite(D0_M) |
!is.finite(D0_k2) |
!is.finite(D0_k3) |
!is.finite(D0_P)
) return(NaN)
prematureChiSquare <- sum((premature - prematureEstimated )^2/prematureVariance)
matureChiSquare <- sum((mature - matureEstimated)^2/matureVariance)
if(is.null(KKK)&is.null(initialChisquare)&is.null(initialDistances)&!is.null(alpha)&!is.null(alphaVariance))
{
alphaChiSquare <- sum((alpha - alphaEstimated)^2/alphaVariance)
initialPenality <- 0
}else{
if(clean){initialPenality <- 0}else{
initialPenality <- initialPenalityRelevance*(initialChisquare/initialDistances)*((k1KKK_Der(0,KKK)-k1VVV_Der(0,parameters))^2
+ (k2KKK_Der(0,KKK)-k2VVV_Der(0,parameters))^2
+ (k3KKK_Der(0,KKK)-k3VVV_Der(0,parameters))^2)
}
alphaChiSquare <- 0
}
chiSquare <- sum(c(prematureChiSquare,matureChiSquare,alphaChiSquare))
penalty <- abs(D0_M)+abs(D0_P)+abs(D0_k2)+abs(D0_k3)
if(penalty <= chiSquare*derivativePenalityRelevance){penalty <- 0}
if(clean){return(chiSquare)}else{return(chiSquare+penalty+initialPenality)}
}
############################################
### Kinetic rates integrative functions ####
############################################
k1KKK_Int <- function(x, parameters)
{
parameters[1]
}
k2KKK_Int <- function(x, parameters)
{
parameters[2]
}
k3KKK_Int <- function(x, parameters)
{
parameters[3]
}
###########################################
### Kinetic rates derivative functions ####
###########################################
k1KKK_Der <- function(x, parameters)
{
parameters[1]*parameters[3]
}
k2KKK_Der <- function(x, parameters)
{
parameters[2]
}
k3KKK_Der <- function(x, parameters)
{
parameters[3]
}
k1VKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8]
return(.D2impulseModel(x, matureParameters)/k2Parameters + .DimpulseModel(x, matureParameters)*(1+k3Parameters/k2Parameters) + k3Parameters*impulseModel(x, matureParameters))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6]
return(.D2sigmoidModel(x, matureParameters)/k2Parameters + .DsigmoidModel(x, matureParameters)*(1+k3Parameters/k2Parameters) + k3Parameters*sigmoidModel(x, matureParameters))
}
}
k2VKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
k2Parameters <- parameters[7]
}else{
k2Parameters <- parameters[5]
}
}
k3VKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
k3Parameters <- parameters[8]
}else{
k3Parameters <- parameters[6]
}
}
k1KVK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
alphaParameters <- parameters[7]
return(alphaParameters)
}else{
alphaParameters <- parameters[5]
return(alphaParameters)
}
}
k2KVK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8]
return((k1Parameters - (.DimpulseModel(x, totalParameters) + .D2impulseModel(x, totalParameters)/k3Parameters))/prematureKVK_Der(x = x, parameters = parameters))
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6]
return((k1Parameters - (.DsigmoidModel(x, totalParameters) + .D2sigmoidModel(x, totalParameters)/k3Parameters))/prematureKVK_Der(x = x, parameters = parameters))
}
}
k3KVK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
k3Parameters <- parameters[8]
}else{
k3Parameters <- parameters[6]
}
}
k1KKV_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
alphaParameters <- parameters[7]
return(alphaParameters)
}else{
alphaParameters <- parameters[5]
return(alphaParameters)
}
}
k2KKV_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
k2Parameters <- parameters[8]
} else {
k2Parameters <- parameters[6]
}
}
k3KKV_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k2Parameters <- parameters[8]
return((k1Parameters - .DimpulseModel(x, totalParameters))/(impulseModel(x, totalParameters) - k1Parameters/k2Parameters))
} else {
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k2Parameters <- parameters[6]
return((k1Parameters - .DsigmoidModel(x, totalParameters))/(sigmoidModel(x, totalParameters) - k1Parameters/k2Parameters))
}
}
k1VVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13]
return(.D2impulseModel(x, matureParameters)/impulseModel(x, k2Parameters) +
.DimpulseModel(x, matureParameters)*(1 - .DimpulseModel(x, k2Parameters)/impulseModel(x, k2Parameters)^2 + k3Parameters/impulseModel(x, k2Parameters)) +
impulseModel(x, matureParameters)*(k3Parameters - (k3Parameters*.DimpulseModel(x, k2Parameters))/impulseModel(x, k2Parameters)^2))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9]
return(.D2sigmoidModel(x, matureParameters)/sigmoidModel(x, k2Parameters) +
.DsigmoidModel(x, matureParameters)*(1 - .DsigmoidModel(x, k2Parameters)/sigmoidModel(x, k2Parameters)^2 + k3Parameters/sigmoidModel(x, k2Parameters)) +
sigmoidModel(x, matureParameters)*(k3Parameters - (k3Parameters*.DsigmoidModel(x, k2Parameters))/sigmoidModel(x, k2Parameters)^2))
}
}
k2VVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
k2Parameters <- parameters[7:12]
return(impulseModel(x, k2Parameters))
}else{
k2Parameters <- parameters[5:8]
return(sigmoidModel(x, k2Parameters))
}
}
k3VVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
k3Parameters <- parameters[13]
}else{
k3Parameters <- parameters[9]
}
}
k1VKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
return(.D2impulseModel(x, matureParameters)/k2Parameters +
.DimpulseModel(x, matureParameters)*(1 + impulseModel(x, k3Parameters)/k2Parameters) +
impulseModel(x, matureParameters)*(.DimpulseModel(x, k3Parameters)/k2Parameters + impulseModel(x, k3Parameters)))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
return(.D2sigmoidModel(x, matureParameters)/k2Parameters +
.DsigmoidModel(x, matureParameters)*(1 + sigmoidModel(x, k3Parameters)/k2Parameters) +
sigmoidModel(x, matureParameters)*(.DsigmoidModel(x, k3Parameters)/k2Parameters + sigmoidModel(x, k3Parameters)))
}
}
k2VKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
k2Parameters <- parameters[7]
}else{
k2Parameters <- parameters[5]
}
}
k3VKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
k3Parameters <- parameters[8:13]
return(impulseModel(x, k3Parameters))
}else{
k3Parameters <- parameters[6:9]
return(sigmoidModel(x, k3Parameters))
}
}
k1KVV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
alphaParameters <- parameters[7]
return(alphaParameters)
}else{
alphaParameters <- parameters[5]
return(alphaParameters)
}
}
k2KVV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
return((k1Parameters - (.DimpulseModel(x, totalParameters) + .D2impulseModel(x, totalParameters)/impulseModel(x, k3Parameters) - ((.DimpulseModel(x, totalParameters) - k1Parameters)*.DimpulseModel(x, k3Parameters))/impulseModel(x, k3Parameters)^2))/(impulseModel(x, totalParameters) + (.DimpulseModel(x, totalParameters) - k1Parameters)/impulseModel(x, k3Parameters)))
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
return((k1Parameters - (.DsigmoidModel(x, totalParameters) + .D2sigmoidModel(x, totalParameters)/sigmoidModel(x, k3Parameters) - ((.DsigmoidModel(x, totalParameters) - k1Parameters)*.DsigmoidModel(x, k3Parameters))/sigmoidModel(x, k3Parameters)^2))/(sigmoidModel(x, totalParameters) + (.DsigmoidModel(x, totalParameters) - k1Parameters)/sigmoidModel(x, k3Parameters)))
}
}
k3KVV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
k3Parameters <- parameters[8:13]
return(impulseModel(x, k3Parameters))
}else{
k3Parameters <- parameters[6:9]
return(sigmoidModel(x, k3Parameters))
}
}
k1VVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13:18]
return(.D2impulseModel(x, matureParameters)/impulseModel(x, k2Parameters) +
.DimpulseModel(x, matureParameters)*(1 - .DimpulseModel(x, k2Parameters)/impulseModel(x, k2Parameters)^2 + impulseModel(x, k3Parameters)/impulseModel(x, k2Parameters)) +
impulseModel(x, matureParameters)*(.DimpulseModel(x, k3Parameters)/impulseModel(x, k2Parameters) + impulseModel(x, k3Parameters) - (impulseModel(x, k3Parameters)*.DimpulseModel(x, k2Parameters))/impulseModel(x, k2Parameters)^2 ))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9:12]
return(.D2sigmoidModel(x, matureParameters)/sigmoidModel(x, k2Parameters) +
.DsigmoidModel(x, matureParameters)*(1 - .DsigmoidModel(x, k2Parameters)/sigmoidModel(x, k2Parameters)^2 + sigmoidModel(x, k3Parameters)/sigmoidModel(x, k2Parameters)) +
sigmoidModel(x, matureParameters)*(.DsigmoidModel(x, k3Parameters)/sigmoidModel(x, k2Parameters) + sigmoidModel(x, k3Parameters) - (sigmoidModel(x, k3Parameters)*.DsigmoidModel(x, k2Parameters))/sigmoidModel(x, k2Parameters)^2 ))
}
}
k2VVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
k2Parameters <- parameters[7:12]
return(impulseModel(x, k2Parameters))
}else{
k2Parameters <- parameters[5:8]
return(sigmoidModel(x, k2Parameters))
}
}
k3VVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
k3Parameters <- parameters[13:18]
return(impulseModel(x, k3Parameters))
}else{
k3Parameters <- parameters[9:12]
return(sigmoidModel(x, k3Parameters))
}
}
#######################################
### Premature derivative functions ####
#######################################
prematureKKK_Der <- function(x, parameters)
{
matureParameters <- parameters[1]
k2Parameters <- parameters[2]
k3Parameters <- parameters[3]
return((k3Parameters*matureParameters)/k2Parameters)
}
prematureVKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8]
return((.DimpulseModel(x, matureParameters) + k3Parameters * impulseModel(x, matureParameters))/k2Parameters)
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6]
return((.DsigmoidModel(x, matureParameters) + k3Parameters * sigmoidModel(x, matureParameters))/k2Parameters)
}
}
.DprematureVKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8]
M <- impulseModel(x, matureParameters)
DM <- .DimpulseModel(x, matureParameters)
D2M <- .D2impulseModel(x, matureParameters)
k3 <- k3Parameters
Dk3 <- 0
k2 <- k2Parameters
Dk2 <- 0
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6]
M <- sigmoidModel(x, matureParameters)
DM <- .DsigmoidModel(x, matureParameters)
D2M <- .D2sigmoidModel(x, matureParameters)
k3 <- k3Parameters
Dk3 <- 0
k2 <- k2Parameters
Dk2 <- 0
}
return((k2*(M*Dk3+k3*DM+D2M)-Dk2*(k3*M+DM))/k2^2)
}
prematureKVK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8]
return(impulseModel(x, totalParameters) + (.DimpulseModel(x, totalParameters) - k1Parameters)/k3Parameters)
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6]
return(sigmoidModel(x, totalParameters) + (.DsigmoidModel(x, totalParameters) - k1Parameters)/k3Parameters)
}
}
prematureKKV_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k2Parameters <- parameters[8]
return(k1Parameters/k2Parameters)
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k2Parameters <- parameters[6]
return(k1Parameters/k2Parameters)
}
}
prematureVVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13]
return((.DimpulseModel(x, matureParameters) + k3Parameters * impulseModel(x, matureParameters))/impulseModel(x, k2Parameters))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9]
return((.DsigmoidModel(x, matureParameters) + k3Parameters * sigmoidModel(x, matureParameters))/sigmoidModel(x, k2Parameters))
}
}
.DprematureVVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13]
M <- impulseModel(x, matureParameters)
DM <- .DimpulseModel(x, matureParameters)
D2M <- .D2impulseModel(x, matureParameters)
k2 <- impulseModel(x, k2Parameters)
Dk2 <- .DimpulseModel(x, k2Parameters)
k3 <- k3Parameters
Dk3 <- 0
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9]
M <- sigmoidModel(x, matureParameters)
DM <- .DsigmoidModel(x, matureParameters)
D2M <- .D2sigmoidModel(x, matureParameters)
k2 <- sigmoidModel(x, k2Parameters)
Dk2 <- .DsigmoidModel(x, k2Parameters)
k3 <- k3Parameters
Dk3 <- 0
}
return((k2*(M*Dk3+k3*DM+D2M)-Dk2*(k3*M+DM))/k2^2)
}
prematureVKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
return((.DimpulseModel(x, matureParameters) + impulseModel(x, k3Parameters) * impulseModel(x, matureParameters))/k2Parameters)
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
return((.DsigmoidModel(x, matureParameters) + sigmoidModel(x, k3Parameters) * sigmoidModel(x, matureParameters))/k2Parameters)
}
}
.DprematureVKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
M <- impulseModel(x, matureParameters)
DM <- .DimpulseModel(x, matureParameters)
D2M <- .D2impulseModel(x, matureParameters)
k2 <- k2Parameters
Dk2 <- 0
k3 <- impulseModel(x, k3Parameters)
Dk3 <- .DimpulseModel(x, k3Parameters)
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
M <- sigmoidModel(x, matureParameters)
DM <- .DsigmoidModel(x, matureParameters)
D2M <- .D2sigmoidModel(x, matureParameters)
k2 <- k2Parameters
Dk2 <- 0
k3 <- sigmoidModel(x, k3Parameters)
Dk3 <- .DsigmoidModel(x, k3Parameters)
}
return((k2*(M*Dk3+k3*DM+D2M)-Dk2*(k3*M+DM))/k2^2)
}
prematureKVV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
totalParameters <- parameters[1:6]
k1Parameters <- parameters[7]
k3Parameters <- parameters[8:13]
return(impulseModel(x, totalParameters) + (.DimpulseModel(x, totalParameters) - k1Parameters)/impulseModel(x, k3Parameters))
}else{
totalParameters <- parameters[1:4]
k1Parameters <- parameters[5]
k3Parameters <- parameters[6:9]
return(sigmoidModel(x, totalParameters) + (.DsigmoidModel(x, totalParameters) - k1Parameters)/sigmoidModel(x, k3Parameters))
}
}
prematureVVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13:18]
return((.DimpulseModel(x, matureParameters) + impulseModel(x, k3Parameters) * impulseModel(x, matureParameters))/impulseModel(x, k2Parameters))
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9:12]
return((.DsigmoidModel(x, matureParameters) + sigmoidModel(x, k3Parameters) * sigmoidModel(x, matureParameters))/sigmoidModel(x, k2Parameters))
}
}
.DprematureVVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
k2Parameters <- parameters[7:12]
k3Parameters <- parameters[13:18]
M <- impulseModel(x, matureParameters)
DM <- .DimpulseModel(x, matureParameters)
D2M <- .D2impulseModel(x, matureParameters)
k3 <- impulseModel(x, k3Parameters)
Dk3 <- .DimpulseModel(x, k3Parameters)
k2 <- impulseModel(x, k2Parameters)
Dk2 <- .DimpulseModel(x, k2Parameters)
}else{
matureParameters <- parameters[1:4]
k2Parameters <- parameters[5:8]
k3Parameters <- parameters[9:12]
M <- sigmoidModel(x, matureParameters)
DM <- .DsigmoidModel(x, matureParameters)
D2M <- .D2sigmoidModel(x, matureParameters)
k3 <- sigmoidModel(x, k3Parameters)
Dk3 <- .DsigmoidModel(x, k3Parameters)
k2 <- sigmoidModel(x, k2Parameters)
Dk2 <- .DsigmoidModel(x, k2Parameters)
}
return((k2*(M*Dk3+k3*DM+D2M)-Dk2*(k3*M+DM))/k2^2)
}
####################################
### Mature derivative functions ####
####################################
matureKKK_Der <- function(x, parameters)
{
matureParameters <- parameters[1]
return(matureParameters)
}
matureVKK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
matureParameters <- parameters[1:6]
return(impulseModel(x, matureParameters))
}else{
matureParameters <- parameters[1:4]
return(sigmoidModel(x, matureParameters))
}
}
matureKVK_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
return(impulseModel(x, totalParameters) - prematureKVK_Der(x, parameters))
}else{
totalParameters <- parameters[1:4]
return(sigmoidModel(x, totalParameters) - prematureKVK_Der(x, parameters))
}
}
matureKKV_Der <- function(x, parameters)
{
if(length(parameters)==8)
{
totalParameters <- parameters[1:6]
return(impulseModel(x, parameters) - prematureKKV_Der(x, parameters))
}else{
totalParameters <- parameters[1:4]
return(sigmoidModel(x, parameters) - prematureKKV_Der(x, parameters))
}
}
matureVVK_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
return(impulseModel(x, matureParameters))
}else{
matureParameters <- parameters[1:4]
return(sigmoidModel(x, matureParameters))
}
}
matureVKV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
matureParameters <- parameters[1:6]
return(impulseModel(x, matureParameters))
}else{
matureParameters <- parameters[1:4]
return(sigmoidModel(x, matureParameters))
}
}
matureKVV_Der <- function(x, parameters)
{
if(length(parameters)==13)
{
totalParameters <- parameters[1:6]
return(impulseModel(x, totalParameters) - prematureKVV_Der(x, parameters))
}else{
totalParameters <- parameters[1:4]
return(sigmoidModel(x, totalParameters) - prematureKVV_Der(x, parameters))
}
}
matureVVV_Der <- function(x, parameters)
{
if(length(parameters)==18)
{
matureParameters <- parameters[1:6]
return(impulseModel(x, matureParameters))
}else{
matureParameters <- parameters[1:4]
return(sigmoidModel(x, matureParameters))
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.