Nothing
R/TTS_10.R
In TTS: Master Curve Estimates Corresponding to Time-Temperature Superposition
#' Time-Temperature Superposition (TTS) analysis
#'
#' This function provides an estimate of the Master Curve in a similar way to
#' the TTS function, with the difference that, in this case, a thin plate
#' spline fit is performed (instead the B-splines smoothing), within the
#' framework of the application of generalized additive models (GAM), as
#' implemented in the mgcv package.
#'
#' @param x Matrix or data frame composed of three columns: a numeric column
#' vector with the experimental frequencies (in logarithmic scale, base-ten),
#' the response variable (E' or G' modulus, compliance, etc.) base-ten
#' logarithm vector and, finally the corresponding temperatures vector.
#' @param reference.temperature Value of the selected reference temperature
#' at which the Master Curve of the response variable (E' or G' modulus,
#' compliance, etc.) will be obtained, the default value of temperature is 40.
#' @param n Number of partitions in the frequency domain in order to fit the
#' B-spline basis. The default value is 100.
#' @param nB Number of bootstrap replicates to estimate confidence intervals
#' of Master Curve fitting. The default is 100.
#' @param method A string vector composed of one of the following options:
#' "derived" (by default), "WLF" and "Arrhenius".
#' @return The function returns a list composed of the following outputs:
#'
#' \item{data}{Input experimental data.} \item{aT}{Numerical vector of
#' horizontal shifts between the modulus curves.} \item{bT}{Numerical vector
#' of vertical shifts between the modulus curves.} \item{TTS.data}{Master
#' Curve Data frame defined by three columns: Log10_time, Log10_Compliance and
#' Temperature.} \item{ref.temp}{Reference temperature value.}
#' \item{TTS.gam}{Data frame of the Generalized Additive Model with B-splines
#' (GAM) estimate of the Master Curve. It contains two columns: time and
#' Prediction.} \item{I.lower}{Lower limit of bootstrap confidence interval
#' corresponding to the estimated B-splines Master Curve.}
#' \item{I.upper}{Upper limit of bootstrap confidence interval corresponding
#' to the estimated B-splines Master Curve.} \item{residuals}{Residuals
#' corresponding to the GAM with B-splines Master Curve fitting.}
#' @author Antonio Meneses \email{antoniomenesesfreire@@hotmail.com}, Salvador
#' Naya \email{salva@@udc.es} and Javier Tarrio-Saavedra
#' \email{jtarrio@@udc.es}
#' @references Naya, S., Meneses A., Tarrio-Saavedra, J., Artiaga R.,
#' Lopez-Beceiro, J. and Gracia-Fernandez C. (2013) New method for estimating
#' shift factors in time-temperatura superposition models. Journal of Thermal
#' Analysis and Calorimetry. ISSN 1388-6150. DOI 10.1007/s10973-013-3193-1.\cr
#'
#' Williams, M. L. (1964) Structural analysis of Viscoelastic materials. AIAA
#' Journal, 785-808.\cr
#'
#' Artiaga R., Garcia A. Fundamentals of DMA. In: 'Thermal analysis.
#' Fundamentals and applications to material characterization' (ed.: Artiaga
#' R.) Publicaciones de la Universidade da Coruna, A Coruna, Spain, 183-206
#' (2005).\cr
#'
#' Wood, S.N. (2017) Generalized Additive Models: An Introduction with R
#' (2nd edition). Chapman and Hall/CRC.\cr
#' @keywords TTS_10
#' @examples
#'
## library(TTS)
#' ## Epoxy
#' data(Epoxy)
#' x=Epoxy
#' ## TTS_10 function applied to Epoxy.
#' Q=TTS_10(x,reference.temperature=40, method=c("derived","WLF","Arrhenius"))
#' names(Q)
#' ## Horizontal shifts vector of compliance versus time curves.
#' Q$aT
#' ## Reference temperature
#' Q$ref.temp
#' PLOT <- PLOT.TTS(Q)
#' ## Generic plots of: data, aT, bT, TTS.data and TTS.gam
#' PLOT$PLOT.data(main="PLOT: Data",xlab="Log_time",
#' ylab="Log_Compliance")
#' PLOT$PLOT.aT(main="PLOT: horizontal shift factors",
#' xlab="Temperature", ylab="aT")
#' PLOT$PLOT.bT(main="PLOT: vertical shift factors",
#' xlab="Temperature",ylab="bT")
#' PLOT$PLOT.TTS.data(xlab="Log_time",
#' ylab="Log_Compliance")
#' PLOT$PLOT.TTS.gam( xlab="Log_time",
#' ylab="Log_Compliance",
#' main = "Fitted gam, Bootstrap confidence intervals",
#' sub = "Reference temperature = 40 Celsius degrees")
#' @export TTS_10
TTS_10 <-
function (x, reference.temperature = 40, n = 100, nB = 100,
method = c("derived", "WLF", "Arrhenius"))
{
BS1 <- c()
BS2 <- c()
BS3 <- c()
for (i in 1:length(unique(x[, 3]))) {
BS1 <- c(BS1, spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$x)
BS2 <- c(BS2, spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$y)
BS3 <- c(BS3, rep(unique(x[, 3])[i], n))
}
nCOL <- n * length(unique(x[, 3]))
BS <- matrix(c(BS1, BS2, BS3), nrow = nCOL, ncol = 3)
D2 <- c()
for (i in 1:length(unique(x[, 3]))) {
newdata1<- spline(x[,1][x[,3] == unique(x[, 3])[i]],
x[,2][x[, 3] == unique(x[, 3])[i]], n)$x
X1<-x[,1][x[,3] == unique(x[,3])[i]]
D2 <- c(D2, D1ss(spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$x,
as.vector(predict(gam(x[, 2][x[, 3] == unique(x[, 3])[i]]~ s(X1)),
newdata =data.frame( X1= newdata1)))))
}
D <- matrix(c(BS1, D2, BS3), nrow = nCOL, ncol = 3)
j <- c()
for (k in 1:(length(unique(D[, 3])) - 1)) {
MM <- c()
for (i in 1:n) {
LL <- mean(D[, 2][D[, 3] == unique(D[, 3])[k]][1:(n -
i + 1)] - D[, 2][D[, 3] == unique(D[, 3])[k +
1]][i:n], trim = 0.1 )
MM <- c(MM, LL)
}
for (i in 2:n) if (MM[i - 1] * MM[i] < 0)
j <- c(j, i)
}
LH <- c()
for (i in 1:(length(unique(D[, 3])) - 1)) {
lh <- (D[, 1][D[, 3] == unique(D[, 3])[i]][j[i]]) - (D[,
1][D[, 3] == unique(D[, 3])[i]][1])
LH <- c(LH, lh)
}
AH <- c()
for (i in 1:(length(LH) - 1)) {
AH <- c(AH, c(unique(D[, 3])[(i + 1)], cumsum(LH[i:1])[i:1],
0, cumsum(LH[(i + 1):length(LH)])))
}
LHH <- c(c(unique(D[, 3])[1], 0, cumsum(LH[1:length(LH)])),
AH, c(unique(D[, 3])[(length(LH) + 1)], cumsum(LH[length(LH):1])[length(LH):1],
0))
MATRIX.LH <- matrix(LHH, nrow = (length(LH) + 2), ncol = (length(LH) +
1))
for (i in 1:(length(LH) + 1)) {
if (reference.temperature == MATRIX.LH[1, i])
Mref <- MATRIX.LH[2:(length(LH) + 2), i]
}
if (x[1, 2] <= x[length(x[, 2][x[, 3] == unique(x[, 3])[1]]),
2]) {
m <- 1
}
else m <- 2
MrefIS <- c((-1)^(m + 1) * Mref[1:which(Mref == 0)], (-1)^m *
Mref[which(Mref == 0):length(Mref)][-1])
MrefISH <- c()
for (i in 1:length(MrefIS)) MrefISH <- c(MrefISH, rep(MrefIS[i],
n))
BSHH <- BS
BSHH[, 1] <- BS[, 1] + MrefISH
BSHV <- function(BSH, m, reference.temperature) {
if (m == 1) {
LV <- c()
for (i in 1:length(LH)) {
L1 <- max(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]] <= BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][n^(m - 1)]))
L2 <- min(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][n^(m * (2 - m))] <= BSH[, 1][BSH[,
3] == unique(BSH[, 3])[i]]))
L1S <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], n)
L1I <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], n)
LV <- c(LV, mean((L1S$y - L1I$y))) ###########
}
}
else {
LV <- c()
for (i in 1:(length(unique(BSH[, 3])) - 1)) {
L1 <- max(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]] <= BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][n^(m - 1)]))
L2 <- min(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][n^(m * (2 - m))] <= BSH[, 1][BSH[,
3] == unique(BSH[, 3])[i]]))
L1S <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], n)
L1I <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], n)
LV <- c(LV, mean(L1S$y - L1I$y))
}
}
AV <- c()
for (i in 1:(length(LV) - 1)) {
AV <- c(AV, c(unique(BSH[, 3])[(i + 1)], cumsum(LV[i:1])[i:1],
0, cumsum(LV[(i + 1):length(LV)])))
}
LVV <- c(c(unique(BSH[, 3])[1], 0, cumsum(LV[1:length(LV)])),
AV, c(unique(BSH[, 3])[(length(LV) + 1)], cumsum(LV[length(LV):1])[length(LV):1],
0))
MATRIX.LV <- matrix(LVV, nrow = (length(LV) + 2), ncol = (length(LV) +
1))
for (i in 1:(length(LV) + 1)) {
if (reference.temperature == MATRIX.LV[1, i])
Vref <- MATRIX.LV[2:(length(LV) + 2), i]
}
VrefIS <- c(-Vref[1:which(Vref == 0)], Vref[which(Vref ==
0):length(Vref)][-1])
VrefISV <- c()
for (i in 1:length(VrefIS)) VrefISV <- c(VrefISV, rep(VrefIS[i],
n))
BSV <- BSH
BSV[, 2] <- BSH[, 2] + VrefISV
list(BSV1 = BSV, VrefIS1 = VrefIS)
}
VrefIS <- BSHV(BSHH, m, reference.temperature)$VrefIS1
VrefISX <- c()
for (i in 1:length(VrefIS)) VrefISX <- c(VrefISX, rep(VrefIS[i],
length(x[, 2][x[, 3] == unique(x[, 3])[i]])))
MrefISX <- c()
for (i in 1:length(MrefIS)) MrefISX <- c(MrefISX, rep(MrefIS[i],
length(x[, 1][x[, 3] == unique(x[, 3])[i]])))
XX <- x
XX[, 1] <- x[, 1] + MrefISX
XX[, 2] <- x[, 2] + VrefISX
ii <- order(XX[, 1])
X.gam <- gam(XX[, 2][ii] ~ s(XX[, 1][ii]))
X.pred <- predict(X.gam, type = "response")
X.resid <- resid(X.gam)
ICB <- function(X, B = nB) {
ii <- order(X[, 1])
x.PC <- X[, 1][ii]
y.PC <- X[, 2][ii]
quantiles.PC <- function(x.PC, probs = c(0.025, 0.975)) {
quantile(x.PC, probs)
}
ajuste_gam.PC <- function(y.PC) {
predict.gam(gam(y.PC ~ s(x.PC)), type = "response")
}
muhat.PC <- predict.gam(gam(y.PC ~ s(x.PC)), type = "response")
e.PC <- y.PC - muhat.PC
e.PC <- e.PC - mean(e.PC)
sigma.PC <- sd(e.PC)
nn <- length(x.PC)
yboot.PC <- matrix(nrow = nn, ncol = B)
for (icol in 1:B) {
yboot.PC[, icol] <- muhat.PC + rnorm(nn) * sigma.PC
}
muhatboot.PC <- apply(yboot.PC, 2, ajuste_gam.PC)
ic.PC <- apply(muhatboot.PC, 1, quantiles.PC)
lib <- ic.PC[1, ]
lsb <- ic.PC[2, ]
list(X.PC = x.PC, LIB = lib, LSB = lsb)
}
WLF.x <- unique(x[, 3])[unique(x[, 3]) != reference.temperature]
WLF.Lh <- MrefIS[MrefIS != 0]
WLF2 <- 1/WLF.Lh
WLF1 <- 1/(WLF.x - reference.temperature)
ajuste <- lm(WLF2 ~ WLF1)
WLF.a <- -1/ajuste$coef[1]
WLF.b <- -WLF.a * ajuste$coef[2]
log.WLF.at <- -WLF.a * (unique(x[, 3]) - reference.temperature)/(WLF.b +
unique(x[, 3]) - reference.temperature)
WLF.MrefISH <- c()
for (i in 1:length(MrefIS)) WLF.MrefISH <- c(WLF.MrefISH,
rep(log.WLF.at[i], n))
WLF.BSH <- BS
WLF.BSH[, 1] <- BS[, 1] + WLF.MrefISH
WLF.VrefIS <- BSHV(WLF.BSH, m, reference.temperature)$VrefIS1
WLF.VrefISX <- c()
for (i in 1:length(WLF.VrefIS)) WLF.VrefISX <- c(WLF.VrefISX,
rep(WLF.VrefIS[i], length(x[, 2][x[, 3] == unique(x[,
3])[i]])))
WLF.MrefISX <- c()
for (i in 1:length(log.WLF.at)) WLF.MrefISX <- c(WLF.MrefISX,
rep(log.WLF.at[i], length(x[, 1][x[, 3] == unique(x[,
3])[i]])))
WLF.X <- x
WLF.X[, 1] <- x[, 1] + WLF.MrefISX
WLF.X[, 2] <- x[, 2] + WLF.VrefISX
iii <- order(WLF.X[, 1])
WLF.X.gam <- gam(WLF.X[, 2][iii] ~ s(WLF.X[, 1][iii]))
WLF.X.pred <- predict(WLF.X.gam, type = "response")
WLF.X.resid <- resid(WLF.X.gam)
AR.x <- unique(x[, 3]) + 273.15
AR <- MrefIS
AR.z <- 1/AR.x
ajusteAR <- lm(AR ~ AR.z)
AR.A <- ajusteAR$coef[1]
AR.BB <- ajusteAR$coef[2]
R <- 8.314
Ea <- AR.BB * R/log10(exp(1))
log.AR.at <- Ea * (1/AR.x - 1/(reference.temperature + 273.15))/R *
log10(exp(1))
AR.MrefISH <- c()
for (i in 1:length(MrefIS)) AR.MrefISH <- c(AR.MrefISH, rep(log.AR.at[i],
n))
AR.BSH <- BS
AR.BSH[, 1] <- BS[, 1] + AR.MrefISH
AR.VrefIS <- BSHV(AR.BSH, m, reference.temperature)$VrefIS1
AR.VrefISX <- c()
for (i in 1:length(AR.VrefIS)) AR.VrefISX <- c(AR.VrefISX,
rep(AR.VrefIS[i], length(x[, 2][x[, 3] == unique(x[,
3])[i]])))
AR.MrefISX <- c()
for (i in 1:length(log.AR.at)) AR.MrefISX <- c(AR.MrefISX,
rep(log.AR.at[i], length(x[, 1][x[, 3] == unique(x[,
3])[i]])))
AR.X <- x
AR.X[, 1] <- x[, 1] + AR.MrefISX
AR.X[, 2] <- x[, 2] + AR.VrefISX
iv <- order(AR.X[, 1])
AR.X.gam <- gam(AR.X[, 2][iv] ~ s(AR.X[, 1][iv]))
AR.X.pred <- predict(AR.X.gam, type = "response")
AR.X.resid <- resid(AR.X.gam)
ICB.X <- ICB(XX)
deriv.icb.x <- ICB.X$X.PC
d.lower1 <- ICB.X$LIB
d.lower2 <- ICB.X$LSB
ICB.WLF <- ICB(WLF.X)
WLF.icb.x <- ICB.WLF$X.PC
W.lower1 <- ICB.WLF$LIB
W.lower2 <- ICB.WLF$LSB
ICB.AR <- ICB(AR.X)
AR.icb.x <- ICB.AR$X.PC
A.lower1 <- ICB.AR$LIB
A.lower2 <- ICB.AR$LSB
der.gam <- data.frame(frequency = deriv.icb.x, prediction = X.pred)
W.gam <- data.frame(frequency = WLF.icb.x, prediction = WLF.X.pred)
A.gam <- data.frame(frequency = AR.icb.x, prediction = AR.X.pred)
if (method[1] == "derived")
DERIV <- list(data = x, aT = MrefIS, bT = VrefIS, TTS.data = XX,
ref.temp = reference.temperature, TTS.gam = der.gam,
I.lower = d.lower1, I.upper = d.lower2, residuals = X.resid)
else if (method[1] == "WLF")
W_L_F <- list(data = x, aT = log.WLF.at, bT = WLF.VrefIS,
TTS.data = WLF.X, ref.temp = reference.temperature,
TTS.gam = W.gam, I.lower = W.lower1, I.upper = W.lower2,
residuals = WLF.X.resid)
else if (method[1] == "Arrhenius")
ARRHEN <- list(data = x, aT = log.AR.at, bT = AR.VrefIS,
TTS.data = AR.X, ref.temp = reference.temperature,
TTS.gam = A.gam, I.lower = A.lower1, I.upper = A.lower2,
residuals = AR.X.resid)
}
Try the TTS package in your browser
Any scripts or data that you put into this service are public.
TTS documentation built on March 7, 2023, 8:02 p.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
#' Time-Temperature Superposition (TTS) analysis
#'
#' This function provides an estimate of the Master Curve in a similar way to
#' the TTS function, with the difference that, in this case, a thin plate
#' spline fit is performed (instead the B-splines smoothing), within the
#' framework of the application of generalized additive models (GAM), as
#' implemented in the mgcv package.
#'
#' @param x Matrix or data frame composed of three columns: a numeric column
#' vector with the experimental frequencies (in logarithmic scale, base-ten),
#' the response variable (E' or G' modulus, compliance, etc.) base-ten
#' logarithm vector and, finally the corresponding temperatures vector.
#' @param reference.temperature Value of the selected reference temperature
#' at which the Master Curve of the response variable (E' or G' modulus,
#' compliance, etc.) will be obtained, the default value of temperature is 40.
#' @param n Number of partitions in the frequency domain in order to fit the
#' B-spline basis. The default value is 100.
#' @param nB Number of bootstrap replicates to estimate confidence intervals
#' of Master Curve fitting. The default is 100.
#' @param method A string vector composed of one of the following options:
#' "derived" (by default), "WLF" and "Arrhenius".
#' @return The function returns a list composed of the following outputs:
#'
#' \item{data}{Input experimental data.} \item{aT}{Numerical vector of
#' horizontal shifts between the modulus curves.} \item{bT}{Numerical vector
#' of vertical shifts between the modulus curves.} \item{TTS.data}{Master
#' Curve Data frame defined by three columns: Log10_time, Log10_Compliance and
#' Temperature.} \item{ref.temp}{Reference temperature value.}
#' \item{TTS.gam}{Data frame of the Generalized Additive Model with B-splines
#' (GAM) estimate of the Master Curve. It contains two columns: time and
#' Prediction.} \item{I.lower}{Lower limit of bootstrap confidence interval
#' corresponding to the estimated B-splines Master Curve.}
#' \item{I.upper}{Upper limit of bootstrap confidence interval corresponding
#' to the estimated B-splines Master Curve.} \item{residuals}{Residuals
#' corresponding to the GAM with B-splines Master Curve fitting.}
#' @author Antonio Meneses \email{antoniomenesesfreire@@hotmail.com}, Salvador
#' Naya \email{salva@@udc.es} and Javier Tarrio-Saavedra
#' \email{jtarrio@@udc.es}
#' @references Naya, S., Meneses A., Tarrio-Saavedra, J., Artiaga R.,
#' Lopez-Beceiro, J. and Gracia-Fernandez C. (2013) New method for estimating
#' shift factors in time-temperatura superposition models. Journal of Thermal
#' Analysis and Calorimetry. ISSN 1388-6150. DOI 10.1007/s10973-013-3193-1.\cr
#'
#' Williams, M. L. (1964) Structural analysis of Viscoelastic materials. AIAA
#' Journal, 785-808.\cr
#'
#' Artiaga R., Garcia A. Fundamentals of DMA. In: 'Thermal analysis.
#' Fundamentals and applications to material characterization' (ed.: Artiaga
#' R.) Publicaciones de la Universidade da Coruna, A Coruna, Spain, 183-206
#' (2005).\cr
#'
#' Wood, S.N. (2017) Generalized Additive Models: An Introduction with R
#' (2nd edition). Chapman and Hall/CRC.\cr
#' @keywords TTS_10
#' @examples
#'
## library(TTS)
#' ## Epoxy
#' data(Epoxy)
#' x=Epoxy
#' ## TTS_10 function applied to Epoxy.
#' Q=TTS_10(x,reference.temperature=40, method=c("derived","WLF","Arrhenius"))
#' names(Q)
#' ## Horizontal shifts vector of compliance versus time curves.
#' Q$aT
#' ## Reference temperature
#' Q$ref.temp
#' PLOT <- PLOT.TTS(Q)
#' ## Generic plots of: data, aT, bT, TTS.data and TTS.gam
#' PLOT$PLOT.data(main="PLOT: Data",xlab="Log_time",
#' ylab="Log_Compliance")
#' PLOT$PLOT.aT(main="PLOT: horizontal shift factors",
#' xlab="Temperature", ylab="aT")
#' PLOT$PLOT.bT(main="PLOT: vertical shift factors",
#' xlab="Temperature",ylab="bT")
#' PLOT$PLOT.TTS.data(xlab="Log_time",
#' ylab="Log_Compliance")
#' PLOT$PLOT.TTS.gam( xlab="Log_time",
#' ylab="Log_Compliance",
#' main = "Fitted gam, Bootstrap confidence intervals",
#' sub = "Reference temperature = 40 Celsius degrees")
#' @export TTS_10
TTS_10 <-
function (x, reference.temperature = 40, n = 100, nB = 100,
method = c("derived", "WLF", "Arrhenius"))
{
BS1 <- c()
BS2 <- c()
BS3 <- c()
for (i in 1:length(unique(x[, 3]))) {
BS1 <- c(BS1, spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$x)
BS2 <- c(BS2, spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$y)
BS3 <- c(BS3, rep(unique(x[, 3])[i], n))
}
nCOL <- n * length(unique(x[, 3]))
BS <- matrix(c(BS1, BS2, BS3), nrow = nCOL, ncol = 3)
D2 <- c()
for (i in 1:length(unique(x[, 3]))) {
newdata1<- spline(x[,1][x[,3] == unique(x[, 3])[i]],
x[,2][x[, 3] == unique(x[, 3])[i]], n)$x
X1<-x[,1][x[,3] == unique(x[,3])[i]]
D2 <- c(D2, D1ss(spline(x[, 1][x[, 3] == unique(x[, 3])[i]],
x[, 2][x[, 3] == unique(x[, 3])[i]], n)$x,
as.vector(predict(gam(x[, 2][x[, 3] == unique(x[, 3])[i]]~ s(X1)),
newdata =data.frame( X1= newdata1)))))
}
D <- matrix(c(BS1, D2, BS3), nrow = nCOL, ncol = 3)
j <- c()
for (k in 1:(length(unique(D[, 3])) - 1)) {
MM <- c()
for (i in 1:n) {
LL <- mean(D[, 2][D[, 3] == unique(D[, 3])[k]][1:(n -
i + 1)] - D[, 2][D[, 3] == unique(D[, 3])[k +
1]][i:n], trim = 0.1 )
MM <- c(MM, LL)
}
for (i in 2:n) if (MM[i - 1] * MM[i] < 0)
j <- c(j, i)
}
LH <- c()
for (i in 1:(length(unique(D[, 3])) - 1)) {
lh <- (D[, 1][D[, 3] == unique(D[, 3])[i]][j[i]]) - (D[,
1][D[, 3] == unique(D[, 3])[i]][1])
LH <- c(LH, lh)
}
AH <- c()
for (i in 1:(length(LH) - 1)) {
AH <- c(AH, c(unique(D[, 3])[(i + 1)], cumsum(LH[i:1])[i:1],
0, cumsum(LH[(i + 1):length(LH)])))
}
LHH <- c(c(unique(D[, 3])[1], 0, cumsum(LH[1:length(LH)])),
AH, c(unique(D[, 3])[(length(LH) + 1)], cumsum(LH[length(LH):1])[length(LH):1],
0))
MATRIX.LH <- matrix(LHH, nrow = (length(LH) + 2), ncol = (length(LH) +
1))
for (i in 1:(length(LH) + 1)) {
if (reference.temperature == MATRIX.LH[1, i])
Mref <- MATRIX.LH[2:(length(LH) + 2), i]
}
if (x[1, 2] <= x[length(x[, 2][x[, 3] == unique(x[, 3])[1]]),
2]) {
m <- 1
}
else m <- 2
MrefIS <- c((-1)^(m + 1) * Mref[1:which(Mref == 0)], (-1)^m *
Mref[which(Mref == 0):length(Mref)][-1])
MrefISH <- c()
for (i in 1:length(MrefIS)) MrefISH <- c(MrefISH, rep(MrefIS[i],
n))
BSHH <- BS
BSHH[, 1] <- BS[, 1] + MrefISH
BSHV <- function(BSH, m, reference.temperature) {
if (m == 1) {
LV <- c()
for (i in 1:length(LH)) {
L1 <- max(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]] <= BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][n^(m - 1)]))
L2 <- min(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][n^(m * (2 - m))] <= BSH[, 1][BSH[,
3] == unique(BSH[, 3])[i]]))
L1S <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], n)
L1I <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], n)
LV <- c(LV, mean((L1S$y - L1I$y))) ###########
}
}
else {
LV <- c()
for (i in 1:(length(unique(BSH[, 3])) - 1)) {
L1 <- max(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]] <= BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][n^(m - 1)]))
L2 <- min(which(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][n^(m * (2 - m))] <= BSH[, 1][BSH[,
3] == unique(BSH[, 3])[i]]))
L1S <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i]][1:L2], n)
L1I <- spline(BSH[, 1][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], BSH[, 2][BSH[, 3] == unique(BSH[,
3])[i + 1]][L1:n], n)
LV <- c(LV, mean(L1S$y - L1I$y))
}
}
AV <- c()
for (i in 1:(length(LV) - 1)) {
AV <- c(AV, c(unique(BSH[, 3])[(i + 1)], cumsum(LV[i:1])[i:1],
0, cumsum(LV[(i + 1):length(LV)])))
}
LVV <- c(c(unique(BSH[, 3])[1], 0, cumsum(LV[1:length(LV)])),
AV, c(unique(BSH[, 3])[(length(LV) + 1)], cumsum(LV[length(LV):1])[length(LV):1],
0))
MATRIX.LV <- matrix(LVV, nrow = (length(LV) + 2), ncol = (length(LV) +
1))
for (i in 1:(length(LV) + 1)) {
if (reference.temperature == MATRIX.LV[1, i])
Vref <- MATRIX.LV[2:(length(LV) + 2), i]
}
VrefIS <- c(-Vref[1:which(Vref == 0)], Vref[which(Vref ==
0):length(Vref)][-1])
VrefISV <- c()
for (i in 1:length(VrefIS)) VrefISV <- c(VrefISV, rep(VrefIS[i],
n))
BSV <- BSH
BSV[, 2] <- BSH[, 2] + VrefISV
list(BSV1 = BSV, VrefIS1 = VrefIS)
}
VrefIS <- BSHV(BSHH, m, reference.temperature)$VrefIS1
VrefISX <- c()
for (i in 1:length(VrefIS)) VrefISX <- c(VrefISX, rep(VrefIS[i],
length(x[, 2][x[, 3] == unique(x[, 3])[i]])))
MrefISX <- c()
for (i in 1:length(MrefIS)) MrefISX <- c(MrefISX, rep(MrefIS[i],
length(x[, 1][x[, 3] == unique(x[, 3])[i]])))
XX <- x
XX[, 1] <- x[, 1] + MrefISX
XX[, 2] <- x[, 2] + VrefISX
ii <- order(XX[, 1])
X.gam <- gam(XX[, 2][ii] ~ s(XX[, 1][ii]))
X.pred <- predict(X.gam, type = "response")
X.resid <- resid(X.gam)
ICB <- function(X, B = nB) {
ii <- order(X[, 1])
x.PC <- X[, 1][ii]
y.PC <- X[, 2][ii]
quantiles.PC <- function(x.PC, probs = c(0.025, 0.975)) {
quantile(x.PC, probs)
}
ajuste_gam.PC <- function(y.PC) {
predict.gam(gam(y.PC ~ s(x.PC)), type = "response")
}
muhat.PC <- predict.gam(gam(y.PC ~ s(x.PC)), type = "response")
e.PC <- y.PC - muhat.PC
e.PC <- e.PC - mean(e.PC)
sigma.PC <- sd(e.PC)
nn <- length(x.PC)
yboot.PC <- matrix(nrow = nn, ncol = B)
for (icol in 1:B) {
yboot.PC[, icol] <- muhat.PC + rnorm(nn) * sigma.PC
}
muhatboot.PC <- apply(yboot.PC, 2, ajuste_gam.PC)
ic.PC <- apply(muhatboot.PC, 1, quantiles.PC)
lib <- ic.PC[1, ]
lsb <- ic.PC[2, ]
list(X.PC = x.PC, LIB = lib, LSB = lsb)
}
WLF.x <- unique(x[, 3])[unique(x[, 3]) != reference.temperature]
WLF.Lh <- MrefIS[MrefIS != 0]
WLF2 <- 1/WLF.Lh
WLF1 <- 1/(WLF.x - reference.temperature)
ajuste <- lm(WLF2 ~ WLF1)
WLF.a <- -1/ajuste$coef[1]
WLF.b <- -WLF.a * ajuste$coef[2]
log.WLF.at <- -WLF.a * (unique(x[, 3]) - reference.temperature)/(WLF.b +
unique(x[, 3]) - reference.temperature)
WLF.MrefISH <- c()
for (i in 1:length(MrefIS)) WLF.MrefISH <- c(WLF.MrefISH,
rep(log.WLF.at[i], n))
WLF.BSH <- BS
WLF.BSH[, 1] <- BS[, 1] + WLF.MrefISH
WLF.VrefIS <- BSHV(WLF.BSH, m, reference.temperature)$VrefIS1
WLF.VrefISX <- c()
for (i in 1:length(WLF.VrefIS)) WLF.VrefISX <- c(WLF.VrefISX,
rep(WLF.VrefIS[i], length(x[, 2][x[, 3] == unique(x[,
3])[i]])))
WLF.MrefISX <- c()
for (i in 1:length(log.WLF.at)) WLF.MrefISX <- c(WLF.MrefISX,
rep(log.WLF.at[i], length(x[, 1][x[, 3] == unique(x[,
3])[i]])))
WLF.X <- x
WLF.X[, 1] <- x[, 1] + WLF.MrefISX
WLF.X[, 2] <- x[, 2] + WLF.VrefISX
iii <- order(WLF.X[, 1])
WLF.X.gam <- gam(WLF.X[, 2][iii] ~ s(WLF.X[, 1][iii]))
WLF.X.pred <- predict(WLF.X.gam, type = "response")
WLF.X.resid <- resid(WLF.X.gam)
AR.x <- unique(x[, 3]) + 273.15
AR <- MrefIS
AR.z <- 1/AR.x
ajusteAR <- lm(AR ~ AR.z)
AR.A <- ajusteAR$coef[1]
AR.BB <- ajusteAR$coef[2]
R <- 8.314
Ea <- AR.BB * R/log10(exp(1))
log.AR.at <- Ea * (1/AR.x - 1/(reference.temperature + 273.15))/R *
log10(exp(1))
AR.MrefISH <- c()
for (i in 1:length(MrefIS)) AR.MrefISH <- c(AR.MrefISH, rep(log.AR.at[i],
n))
AR.BSH <- BS
AR.BSH[, 1] <- BS[, 1] + AR.MrefISH
AR.VrefIS <- BSHV(AR.BSH, m, reference.temperature)$VrefIS1
AR.VrefISX <- c()
for (i in 1:length(AR.VrefIS)) AR.VrefISX <- c(AR.VrefISX,
rep(AR.VrefIS[i], length(x[, 2][x[, 3] == unique(x[,
3])[i]])))
AR.MrefISX <- c()
for (i in 1:length(log.AR.at)) AR.MrefISX <- c(AR.MrefISX,
rep(log.AR.at[i], length(x[, 1][x[, 3] == unique(x[,
3])[i]])))
AR.X <- x
AR.X[, 1] <- x[, 1] + AR.MrefISX
AR.X[, 2] <- x[, 2] + AR.VrefISX
iv <- order(AR.X[, 1])
AR.X.gam <- gam(AR.X[, 2][iv] ~ s(AR.X[, 1][iv]))
AR.X.pred <- predict(AR.X.gam, type = "response")
AR.X.resid <- resid(AR.X.gam)
ICB.X <- ICB(XX)
deriv.icb.x <- ICB.X$X.PC
d.lower1 <- ICB.X$LIB
d.lower2 <- ICB.X$LSB
ICB.WLF <- ICB(WLF.X)
WLF.icb.x <- ICB.WLF$X.PC
W.lower1 <- ICB.WLF$LIB
W.lower2 <- ICB.WLF$LSB
ICB.AR <- ICB(AR.X)
AR.icb.x <- ICB.AR$X.PC
A.lower1 <- ICB.AR$LIB
A.lower2 <- ICB.AR$LSB
der.gam <- data.frame(frequency = deriv.icb.x, prediction = X.pred)
W.gam <- data.frame(frequency = WLF.icb.x, prediction = WLF.X.pred)
A.gam <- data.frame(frequency = AR.icb.x, prediction = AR.X.pred)
if (method[1] == "derived")
DERIV <- list(data = x, aT = MrefIS, bT = VrefIS, TTS.data = XX,
ref.temp = reference.temperature, TTS.gam = der.gam,
I.lower = d.lower1, I.upper = d.lower2, residuals = X.resid)
else if (method[1] == "WLF")
W_L_F <- list(data = x, aT = log.WLF.at, bT = WLF.VrefIS,
TTS.data = WLF.X, ref.temp = reference.temperature,
TTS.gam = W.gam, I.lower = W.lower1, I.upper = W.lower2,
residuals = WLF.X.resid)
else if (method[1] == "Arrhenius")
ARRHEN <- list(data = x, aT = log.AR.at, bT = AR.VrefIS,
TTS.data = AR.X, ref.temp = reference.temperature,
TTS.gam = A.gam, I.lower = A.lower1, I.upper = A.lower2,
residuals = AR.X.resid)
}
Try the TTS package in your browser
Any scripts or data that you put into this service are public.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.