Skip to content

GitLab

Commit 96513f57 authored by Virgile Baudrot's avatar Virgile Baudrot
Browse files

add options for damage IT and SD models

parent 4f459005
Hide whitespace changes
Inline Side-by-side
R/mod_tabItemDamage.R
View file @ 96513f57
......@@ -60,7 +60,7 @@ mod_tabItemDamage_ui <- function(id){
For the parameters provided by default, exposure is in squarred meter
so we convert LC50 in square meter (451*10000)."),
withMathJax(
helpText('$$\\Damage(x) = \\frac{1}{1 + (x/LC_{50})^\text{slope}}$$')
helpText('$$\\text{Damage}(x) = \\frac{1}{1 + (x/LC_{50})^{\text{slope}}}$$')
),
numericInput(inputId = ns("LC50DR"),
label = "LC50",
......@@ -70,18 +70,86 @@ mod_tabItemDamage_ui <- function(id){
value = -1.76)
),
tabPanel(title = "GUTS model - SD",
tabPanel(title = "TKTD model",
value = "GUTSsurvDAMAGE",
################
# CSV FILE BEGIN
################
#Selector for file upload
fileInput(ns('GUTSsurvDAMAGE'),
'Choose CSV file - GUTS',
accept=c('text/csv', 'text/comma-separated-values,text/plain'))
##############
# CSV FILE END
##############
p("For each parameter, you can either upload a single value or upload a vector."),
p("For more information about TKTD model, please see the
Scientific Opinion on the state of the art of Toxicokinetic/Toxicodynamic (TKTD) :",
a(href="", "https://www.efsa.europa.eu/fr/efsajournal/pub/5377")),
tabsetPanel(
id = ns("tabsetDAMAGEsurv_GUTS"),
tabPanel(title = "Stochastic Death",
value = "GUTSsurvDAMAGE_SD",
h4(tags$b("Toxicokinetic - TK")),
withMathJax(
helpText('$$\\frac{D_{int}}{dt} = k_d (C_{ext} - D_{int})$$')
),
numericInput(inputId = ns("kdSD"),
label = "TK parameter - kd",
value = 0.3),
fileInput(ns('kdSDvector'),
'Choose CSV file - kd',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
h4(tags$b("Toxicodynamic - TD")),
withMathJax(
helpText('$$S(t) = \\exp \\left( - \\int_0^t h_b + k_k \\max( D_{int}(\tau) -z) d \\tau \\right)$$')
),
numericInput(inputId = ns("hbSD"),
label = "Back ground mortality - hb",
value = 0),
fileInput(ns('hbSDvector'),
'Choose CSV file - hb',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
numericInput(inputId = ns("zSD"),
label = "Threshold - z",
value = 200),
fileInput(ns('zSDvector'),
'Choose CSV file - z',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
numericInput(inputId = ns("kkSD"),
label = "Killing rate - kk",
value = 0.02),
fileInput(ns('kkSDvector'),
'Choose CSV file - kk',
accept=c('text/csv', 'text/comma-separated-values,text/plain'))
),
tabPanel(title = "Individual Tolerance",
value = "GUTSsurvDAMAGE_IT",
h4(tags$b("Toxicokinetic - TK")),
withMathJax(
helpText('$$\\frac{D_{int}}{dt} = k_d (C_{ext} - D_{int})$$')
),
numericInput(inputId = ns("kdIT"),
label = "TK parameter - kd",
value = 0.3),
fileInput(ns('kdITvector'),
'Choose CSV file - kd',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
h4(tags$b("Toxicodynamic - TD")),
withMathJax(
helpText('$$S(t) = h_b + \\frac{1}{1 + (\\max(D_{int}(\tau))/\\alpha)^{\text{\\beta}}}$$')
),
numericInput(inputId = ns("hbIT"),
label = "Back ground mortality - hb",
value = 0),
fileInput(ns('hbITvector'),
'Choose CSV file - hb',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
numericInput(inputId = ns("alphaIT"),
label = "Threshold - alpha",
value = 200),
fileInput(ns('alphaITvector'),
'Choose CSV file - beta',
accept=c('text/csv', 'text/comma-separated-values,text/plain')),
numericInput(inputId = ns("betaIT"),
label = "Killing rate - kk",
value = 0.02),
fileInput(ns('betaITvector'),
'Choose CSV file - kk',
accept=c('text/csv', 'text/comma-separated-values,text/plain'))
)
)
),
selected = "DRsurvDAMAGE"
),
......@@ -207,7 +275,39 @@ mod_tabItemDamage_server <- function(input, output, session, r){
}
if(input$tabsetDAMAGEsurv == "GUTSsurvDAMAGE"){
library(deSolve)
if(input$tabsetDAMAGEsurv_GUTS == "GUTSsurvDAMAGE_SD"){
model_typeSelect = "SD"
parameterSelect = list(kk = input$kkSD,
kd = input$kdSD,
z = input$zSD,
hb = input$hbSD)
}
if(input$tabsetDAMAGEsurv_GUTS == "GUTSsurvDAMAGE_IT"){
model_typeSelect = "IT"
parameterSelect = list(alpha = input$alphaIT,
kd = input$kdIT,
hb = input$hbIT,
beta = input$betaSD)
}
# COMPUTE DAMAGE
damageINDIVIDUAL = r$exposureINDIVIDUAL
TimeLine = sort(unique(tidyr::unnest(r$exposureINDIVIDUAL, c(Date,EXPOSURE))[["Date"]]))
damageINDIVIDUAL$TIME = lapply(1:nrow(r$exposureINDIVIDUAL), function(i){
match(Date, TimeLine)
})
damageINDIVIDUAL$DAMAGE = lapply(
1:nrow(damageINDIVIDUAL),
function(i){
pSurvODE(damageINDIVIDUAL$EXPOSURE[[i]],
damageINDIVIDUAL$TIME[[i]],
model_typeSelect,
parameterSelect
)
})
# model
modelSD <- function(t, State, parms, input) {
with(as.list(c(parms, State)), {
......@@ -218,25 +318,32 @@ mod_tabItemDamage_server <- function(input, output, session, r){
list(res, hb = hb, signal=signal)
})
}
modelIT <- function(t, State, parms, input) {
with(as.list(c(parms, State)), {
signal = input(t) # exposure
dD <- kd * (signal - D) # internal concentration
dH <- kk * pmax(D - z, 0) + hb # risk function
res <- c(dD, dH)
list(res, hb = hb, signal=signal)
})
}
# -----------------------------
#
# /!\ real time (date) has to be convert in indice time but should start at 0, that is 0:(length-1) !!!
#
pSurvODE <- function(exposure,
time,
model_type = "SD",
parameter = list(kk, kd, z, hb)){
model_type = model_typeSelect,
parameter = parameterSelect){
## external signal with several rectangle impulses
signal <- data.frame(times = time, import = exposure)
sigimp <- stats::approxfun(signal$times, signal$import, method = "linear", rule = 2)
times = time
## The parameters
if(model_type == "SD"){
parms <- list(kk, kd, z, hb)
modelFUN = modelSD
}
if(model_type == "IT"){
parms <- list(beta, kd, alpha, hb)
modelFUN = modelIT
}
## Start values for steady state
......@@ -245,11 +352,17 @@ mod_tabItemDamage_server <- function(input, output, session, r){
out <- ode(y = xstart,
times = times,
func = modelFUN,
parms,
parms = parameter,
input = sigimp)
df = as.data.frame(out)
df$pSurv0 = exp(- df$hb *df$time)
df$pSurv = exp(- out[, grep("H", colnames(out))] )
if(model_type == "SD"){
df$pSurv0 = exp(- df$hb *df$time)
df$pSurv = exp(- out[, grep("H", colnames(out))] )
}
if(model_type == "IT"){
df$pSurv0 = exp(- df$hb *df$time)
#df$pSurv = exp(- out[, grep("H", colnames(out))] )
}
return(df)
}
......
R/mod_tabItemLandscape.R
View file @ 96513f57
......@@ -140,6 +140,7 @@ mod_tabItemLandscape_ui <- function(id){
style="color: #fff; background-color: #33595f; border-color: #052327")
),
column( width = 6,
p("Select ID only if you upload your own Emission profile after."),
selectizeInput(ns("ctrlIDsource"),
label = "Choose ID column",
choices = NULL,
......@@ -316,7 +317,7 @@ mod_tabItemLandscape_server <- function(input, output, session, r){
r$IDsource = "IDsource"
r$landscapeSOURCE = r$landscapeSOURCE %>%
dplyr::mutate(IDsource = 1:n())
}
}
if(input$ctrlEPSGsource != "initial"){
r$landscapeSOURCE <- st_transform(r$landscapeSOURCE, crs = as.numeric(input$ctrlEPSGsource))
}
......
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment

Mentions Légales et CGU