library(shiny)
library(shinyBS)
library(shinydashboard)
library(shinyWidgets)
library(V8)
library(ggplot2)
library(shinyjs)
library(magrittr)
library(httk)
#server logic for HTTK model
shinyServer(function(input, output, session) {
shinyjs::useShinyjs()
# define the model name once here. It will be used throughout this server file
# this will make it easier to create new model UI/SERVERS
model <- "httk_pbtk"
# httk_chem <- chem.physical_and_invitro.data$CAS
# names(httk_chem)<- chem.physical_and_invitro.data$Compound
#updateSelectInput(session,"sel_chem4Partition",choices = httk_chem)
# this dataframe is only used to display the metabolism data.
#The actual model uses values stored in the database
metabolism_dataframe <- data.frame("Age"=c(25),"Clearance"=c(0),stringsAsFactors = F)
dataset <- reactiveValues()
dataset$savedat <- reactiveVal(c("No","none"))
dataset$iviveDat <- reactiveVal(c("No",0,0,0))
parameterSets <- reactiveValues()
parameterSets$savedat <- reactiveVal(c("No","",0))
parameterSets$sverestdat <- reactiveVal(c("None",0))
parameterSets$importdat <- reactiveVal(c("No","",0))
parameterSets$importSeem <- reactiveVal(c("No"))
parameterSets$sim_table <- data.frame("Col1"="","Col2"=0,"Col3"=0,row.names = NULL)
parameterSets$vardat <- reactiveVal(c("None","",0))
expo_set <- getAllSetChoices("expo")
physio_set <- getAllSetChoices("physio")
chem_set <- getAllSetChoices("chem")
metab_set <- getAllSetChoices("metab")
sim_set <- getAllSetChoices("sim")
physiovar <-getVariabilitySetChoices("physio")
chemvar <-getVariabilitySetChoices("chem")
expovar <-getVariabilitySetChoices("expo")
parameterSets$expo <- reactiveVal(expo_set)
parameterSets$physio <- reactiveVal(physio_set)
parameterSets$chem <- reactiveVal(chem_set)
parameterSets$metab <- reactiveVal(metab_set)
parameterSets$sim <- reactiveVal(sim_set)
parameterSets$physiovar <- reactiveVal(physiovar)
parameterSets$chemvar <- reactiveVal(chemvar)
parameterSets$expovar <- reactiveVal(expovar)
# conc_datasets <- c("none",getDatasetNames("conc"))
# updateSelectizeInput(session,"cplt_data",choices = conc_datasets)
observe({
exposet <- parameterSets$expo()
updateSelectizeInput(session,"sel_set_expo",choices = exposet)
physioset <- parameterSets$physio()
updateSelectizeInput(session,"sel_set_physio",choices = physioset)
chemset <- parameterSets$chem()
updateSelectizeInput(session,"sel_set_chem",choices = chemset)
metabset<- parameterSets$metab()
metabset <- c("Use Linear Metabolism"="1",metabset)
updateSelectizeInput(session,"sel_set_metab",choices = metabset)
physiovar <- parameterSets$physiovar()
physiovar <- c("None"="0",physiovar)
updateSelectizeInput(session,"sel_set_physiovar",choices = physiovar)
chemvar <- parameterSets$chemvar()
chemvar <- c("None"="0",chemvar)
updateSelectizeInput(session,"sel_set_chemvar",choices = chemvar)
expovar <- parameterSets$expovar()
expovar <- c("None"="0",expovar)
updateSelectizeInput(session,"sel_set_expovar",choices = expovar)
})
# get global variables needed to run the model
# get the connection to the master database
#db <- system.file("database/plethemdb.sqlite",package = "plethem.r.package",mustWork = TRUE)
#master_conn <- RSQLite::dbConnect(RSQLite::SQLite(),db)
# get the parameter table for physiological and exposure variables.
query <- sprintf("SELECT Name,Var,Units,ParamType,Variability FROM ParamNames Where Model='%s' AND ParamSet = 'Physiological' AND UIParams = 'TRUE';",
model)
physio_name_df <- mainDbSelect(query)
# res <- RSQLite::dbSendQuery(master_conn,query)
# physio_name_df <- RSQLite::dbFetch(res)
# RSQLite::dbClearResult(res)
query <- sprintf("SELECT Name,Var,Units,ParamType,Variability FROM ParamNames Where Model='%s' AND ParamSet = 'Exposure' AND UIParams = 'TRUE';",
model)
expo_name_df <- mainDbSelect(query)
# res <- RSQLite::dbSendQuery(master_conn,query)
# expo_name_df <- RSQLite::dbFetch(res)
# RSQLite::dbClearResult(res)
query <- sprintf("SELECT Name,Var,Units,ParamType,Variability FROM ParamNames Where Model='%s' AND ParamSet = 'Chemical'AND UIParams = 'TRUE';",
model)
chem_name_df <- mainDbSelect(query)
#### Update the parameter set dropdowns if they exist for physiological and exposure sets
set_choices <- getAllSetChoices(set_type = "physio")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_physio",choices = set_choices)
shinyBS::updateButton(session,"btn_use_lifecourse",style = "primary")
shinyBS::updateButton(session,"btn_useQSAR4Partition",style = "primary")
}
set_choices <- getAllSetChoices(set_type = "expo")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_expo",choices = set_choices)
}
set_choices <- getAllSetChoices(set_type = "chem")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_chem",choices = set_choices)
updateSelectizeInput(session,"sel_chem4Partition",choices = set_choices)
}
set_choices <- getAllSetChoices(set_type = "metab")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_metab",choices = set_choices)
}
set_choices <- getAllSetChoices(set_type = "sim")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_sim",choices = set_choices)
}
obs_conc_set <- getObservationSetChoices("conc")
if (length(obs_conc_set)>0){
updatePickerInput(session,"cplt_data",
choices = c("No Dataset"="none",obs_conc_set),
selected = "none")
}
set_choices<- getVariabilitySetChoices("physio")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_physio_var",
choices = set_choices)
}
set_choices<- getVariabilitySetChoices("chem")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_chem_var",
choices = set_choices)
}
set_choices<- getVariabilitySetChoices("expo")
if (length(set_choices)>0){
updateSelectizeInput(session,"sel_expo_var",
choices = set_choices)
}
########### The next chunck enables lumping compartments.
compartment_list <-c("skin","fat","muscle","bone","brain","lung","heart","gi","liver","kidney","rpf","spf")
vol_ids <- c("fat"="ms_vfatc","skin"="ms_vskinc",
"muscle"="ms_vmuscc","bone"="ms_vbonec",
"brain"="ms_vbrnc","lung"="ms_vlngc",
"heart"="ms_vhrtc","gi"="ms_vgic",
"liver"="ms_vlivc","kidney"="ms_vkdnc",
"rpf"="ms_vrpfc","spf"="ms_vspfc","blood"="ms_vbldc",
"bw"="ms_bw")
flow_ids <- c("fat"="ms_qfatc","skin"="ms_qskinc",
"muscle"="ms_qmuscc","bone"="ms_qbonec",
"brain"="ms_qbrnc","lung"="ms_qlngc",
"heart"="ms_qhrtc","gi"="ms_qgic","kidney"="ms_qkdnc",
"rpf"="ms_qrpfc","spf"="ms_qspfc")
observe({
selected_list<- as.vector(input$ms_cmplist)
inactive_list <- base::setdiff(compartment_list,selected_list)
# set volumes of inactive compartments to 1e-12 ( very low)
# set flows of inactive compartments to zero
for(x in inactive_list){
input_id <- as.character(flow_ids[x])
updateNumericInput(session,input_id,value =0)
input_id <- as.character(vol_ids[x])
updateNumericInput(session,input_id,value = 1e-12)
}
# disable the tab for inactive compartments
sapply(compartment_list,function(x){js$enableTab(x)})
sapply(inactive_list,function(x){js$disableTab(x)})
})
########### The next code chunk deals with updating select inputs for all parameter sets]
### Import button current for chemicals only
# Import a new chemical set from user or main database
#### Chunk for handling chemical tab
observeEvent(input$btn_import_chem,{
importHTTKDataUI(paste0("chem",input$btn_import_chem))
#importParameterSetUI(input$btn_import_chem,"chem")
parameterSets$importdat <- callModule(importHTTKData,paste0("chem",input$btn_import_chem))
})
#### Chunk for handling physiological tab
observeEvent(input$btn_import_physio,{
importParameterSetUI(input$btn_import_physio,"physio")
parameterSets$importdat <- callModule(importParameterSet,input$btn_import_physio,"physio")
})
# update the paramter set dropdown if it is changed
observe({
result_vector <- parameterSets$importdat
if(result_vector()[1]=="Yes"){
set_type <- result_vector()[2]
set_id <- result_vector()[3]
set_list <- getAllSetChoices(set_type)
parameterSets[[set_type]] <- reactiveVal(set_list)
updateSelectizeInput(session,paste0("sel_",set_type),choices = set_list, selected = set_id)
if(set_type == "chem"){
updateSelectizeInput(session,"sel_chem4Partition",choices = set_list)
}
# updateSelectizeInput(session,paste0("sel_scene_",set_type),choices = set_list)
}
})
# Import SEEM data
observeEvent(input$btn_seem_upload,{
path <-fpath()
importSEEMDataUI(paste0("seem",input$btn_seem_upload))
parameterSets$importSeem <- callModule(importSEEMData,paste0("seem",input$btn_seem_upload),
path,expo_name_df)
})
fpath <- reactive({
fpath <- file.choose()
return(fpath)
})
observe({
result_vector <- parameterSets$importSeem
if(result_vector()[1]=="Yes"){
set_type <- "expo"
set_list <- getAllSetChoices(set_type)
parameterSets[[set_type]] <- reactiveVal(set_list)
updateSelectizeInput(session,paste0("sel_",set_type),
choices = set_list)
}
})
#Save a new physiological parameter set
observeEvent(input$btn_saveas_physio,{
saveAsParameterSetUI(paste0("physio",input$btn_saveas_physio),"physio")
parameterSets$savedat <- callModule(saveAsParameterSet,
paste0("physio",input$btn_saveas_physio),
"physio",isolate(input),
physio_name_df)
})
#Save a new exposure parameter set
observeEvent(input$btn_saveas_expo,{
if((input$ms_bdose==0 || input$ms_breps == 0) && input$ms_ivdose==0){
shinyWidgets::sendSweetAlert(session,
title = "Invalid Exposure Parameters",
text = "Atleast one route of exposure should be active",
type = "error")
}else{
saveAsParameterSetUI(paste0("expo",input$btn_saveas_expo),"expo")
parameterSets$savedat <- callModule(saveAsParameterSet,
paste0("expo",input$btn_saveas_expo),
"expo",isolate(input),
expo_name_df)
}
})
#Save a new chemical parameter set
observeEvent(input$btn_saveas_chem,{
saveAsParameterSetUI(input$btn_saveas_chem,"chem")
parameterSets$savedat <- callModule(saveAsParameterSet,input$btn_saveas_chem,"chem",isolate(input),chem_name_df)
})
# update the paramter set dropdown if it is changed
observe({
result_vector <- parameterSets$savedat
if(result_vector()[1]=="Yes"){
set_type <- result_vector()[2]
set_id <- result_vector()[3]
set_list <- getAllSetChoices(set_type)
parameterSets[[set_type]] <- reactiveVal(set_list)
updateSelectizeInput(session,paste0("sel_",set_type),choices = set_list, selected = set_id)
if(set_type == "chem"){
print("update here")
updateSelectizeInput(session,"sel_chem4Partition",choices = set_list)
}
parameterSets$savedat <- reactiveVal(c("No","",0))
# updateSelectizeInput(session,paste0("sel_scene_",set_type),choices = set_list)
}
})
#Save/Restore Button function
observeEvent(input$btn_sverest_physio,{
physioid <- input$sel_physio
set_values <- getParameterSet("physio",physioid)
UI_values <- reactiveValuesToList(input)[paste0("ms_",physio_name_df$Var)]
names(UI_values) <- gsub("ms_","",names(UI_values))
saveRestoreParameterSetUI(input$btn_sverest_physio)
parameterSets$sverestdat <- callModule(saveRestoreParameterSet,
input$btn_sverest_physio,
UI_values,set_values,
physio_name_df,"physio")
})
#Save/Restore Button function
observeEvent(input$btn_sverest_expo,{
expoid <- input$sel_expo
set_values <- getParameterSet("expo",expoid)
UI_values <- reactiveValuesToList(input)[paste0("ms_",expo_name_df$Var)]
names(UI_values) <- gsub("ms_","",names(UI_values))
saveRestoreParameterSetUI(input$btn_sverest_expo)
parameterSets$sverestdat <- callModule(saveRestoreParameterSet,
input$btn_sverest_expo,
UI_values,set_values,
expo_name_df,"expo")
})
#Save/Restore Button function
observeEvent(input$btn_sverest_chem,{
chemid <- input$sel_chem
set_values <- getParameterSet("chem",chemid)
UI_values <- reactiveValuesToList(input)[paste0("ms_",chem_name_df$Var)]
names(UI_values) <- gsub("ms_","",names(UI_values))
saveRestoreParameterSetUI(input$btn_sverest_chem)
parameterSets$sverestdat <- callModule(saveRestoreParameterSet,
input$btn_sverest_chem,
UI_values,set_values,
chem_name_df,"chem")
})
observe({
result_vector <- parameterSets$sverestdat()
ops_type <- result_vector[1]
if (ops_type == "save"){
type <- result_vector[5]
input_id <- as.integer(isolate(input[[paste0("sel_",type)]]))
id_name <- paste0(type,"id")
if (type == "physio"){
table_name <- "Physiological"
}else if(type == "chem"){
table_name <- "Chemical"
}else{
table_name <- "Exposure"
}
# create a data frame for the mapply below
val_df <- data.frame("var"=result_vector[2],"val"= result_vector[4],stringsAsFactors = FALSE,row.names = NULL)
# create the query
query_list <-mapply(function(var,val,tbl_nme,id_nme,id){
temp <- sprintf("UPDATE %s SET value = %s WHERE %s = %i AND param = '%s';",
tbl_nme,val,id_nme,id,var)
return(temp)
},
val_df$Variable,val_df$Current.Value,table_name,id_name,input_id,SIMPLIFY = T)
lapply(query_list,projectDbUpdate)
}else if (ops_type == "restore"){
type <- result_vector[5]
if (type == "physio"){
name_data <- physio_name_df
}else if(type == "chem"){
name_data <- chem_name_df
}else{
name_data <- expo_name_df
}
var_type <- sapply(result_vector$Variable,function(var){
tempvar <- name_data$ParamType[which(name_data$Var == var, arr.ind = T)]
return(tempvar)})
change_df <- data.frame("Var"=result_vector$Variable,
"Val" = result_vector[["Original Value"]],
"ParamType"=var_type,
row.names = NULL,
stringsAsFactors = F)
updateUIInputs(session,change_df)
# a <- mapply(function(var,org){
# print(var)
# tempvar <- name_data$ParamType[which(name_data$Var == var, arr.ind = T)]
# return(var,tempvar)
# },table_data$Variable,table_data$Original.Value)
}
})
observeEvent(input$btn_new_varphys,{
param_names <- physio_name_df$Name[which(physio_name_df$Variability == "TRUE")]
param_vars <- physio_name_df$Var[which(physio_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("vpn_",input$btn_new_varphys)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"physio","new",param_vars)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observeEvent(input$btn_edit_varphys,{
param_names <- physio_name_df$Name[which(physio_name_df$Variability == "TRUE")]
param_vars <- physio_name_df$Var[which(physio_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("vpe_",input$btn_edit_varphys)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"physio","edit",
param_vars,input$sel_physio_var)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observeEvent(input$btn_new_varchem,{
param_names <- chem_name_df$Name[which(chem_name_df$Variability == "TRUE")]
param_vars <- chem_name_df$Var[which(chem_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("vcn_",input$btn_new_varchem)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"chem","new",param_vars)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observeEvent(input$btn_edit_varchem,{
param_names <- chem_name_df$Name[which(chem_name_df$Variability == "TRUE")]
param_vars <- chem_name_df$Var[which(chem_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("vce_",input$btn_edit_varchem)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"chem","edit",
param_vars,input$sel_chem_var)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observeEvent(input$btn_new_varexpo,{
param_names <- expo_name_df$Name[which(expo_name_df$Variability == "TRUE")]
param_vars <- expo_name_df$Var[which(expo_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("ven_",input$btn_new_varexpo)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"expo","new",param_vars)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observeEvent(input$btn_edit_varexpo,{
param_names <- expo_name_df$Name[which(expo_name_df$Variability == "TRUE")]
param_vars <- expo_name_df$Var[which(expo_name_df$Variability == "TRUE")]
names(param_vars) <- param_names
ns <- paste0("vee_",input$btn_edit_varexpo)
newEditVariabilityUI(ns)
parameterSets$vardat <- callModule(newEditVariability,ns,"expo","edit",
param_vars,input$sel_expo_var)
### Variability Tab
},ignoreInit = T, ignoreNULL = T)
observe({
result_vector <- parameterSets$vardat
if (result_vector()[1]=="Yes"){
set_type <- result_vector()[2]
varid <- result_vector()[3]
set_list <- getVariabilitySetChoices(set_type)
parameterSets[[paste0(set_type,"var")]] <- reactiveVal(set_list)
updateSelectizeInput(session,paste0("sel_",set_type,"_var"),choices = NULL)
updateSelectizeInput(session,
paste0("sel_",set_type,"_var"),
choices = set_list,
selected = as.integer(varid))
}
})
observeEvent(input$sel_physio_var,{
varid <- input$sel_physio_var
query <- sprintf("Select var_tble from Variability where varid = %d;",as.integer(varid))
var_data <- projectDbSelect(query)
dataset <- unserialize(charToRaw(var_data$var_tble))
output$physio_var_tble <- DT::renderDT(DT::datatable(dataset))
},ignoreInit = TRUE, ignoreNULL = TRUE)
observeEvent(input$sel_chem_var,{
varid <- input$sel_chem_var
query <- sprintf("Select var_tble from Variability where varid = %d;",as.integer(varid))
var_data <- projectDbSelect(query)
dataset <- unserialize(charToRaw(var_data$var_tble))
output$chem_var_tble <- renderTable(dataset)
},ignoreInit = TRUE, ignoreNULL = TRUE)
observeEvent(input$sel_expo_var,{
varid <- input$sel_expo_var
query <- sprintf("Select var_tble from Variability where varid = %d;",as.integer(varid))
var_data <- projectDbSelect(query)
dataset <- unserialize(charToRaw(var_data$var_tble))
output$expo_var_tble <- renderTable(dataset)
},ignoreInit = TRUE, ignoreNULL = TRUE)
# # Handle radio buttons for changing organisms
# observeEvent(input$ms_org,{
# if(input$ms_org == "ha"){
# shinyjs::enable("ms_gender")
# shinyjs::enable("ms_age")
# }else{
# #shinyjs::disable("ms_gender")
# #shinyjs::disable("ms_age")
# physioid <- 1
# query <- sprintf("Select param,value from Physiological where physioid = 1;")
# param_values <- mainDbSelect(query)
# param_names <- param_values$param
# param_values <- param_values$value
# names(param_values)<- param_names
# # get all numeric values in the physio names dataframe
# params_df <- physio_name_df
# params_df$Val <- param_values[physio_name_df$Var]
# updateUIInputs(session,params_df)
#
# }
# })
#update the inputs for the parameter set selected
observeEvent(input$sel_physio,{
physioid <- input$sel_physio
#get values for the inputs
physio_values <- getParameterSet("physio",physioid)
# get all numeric values in the physio names dataframe
params_df <- physio_name_df
params_df$Val <- physio_values[physio_name_df$Var]
updateUIInputs(session,params_df)
shinyBS::updateButton(session,"btn_use_lifecourse",style = "primary")
shinyBS::updateButton(session,"btn_useQSAR4Partition",style = "primary")
},ignoreInit = TRUE, ignoreNULL = TRUE)
observeEvent(input$sel_expo,{
expoid <- input$sel_expo
#get the values for inputs
expo_values <- getParameterSet("expo",expoid)
params_df <- expo_name_df
params_df$Val <- expo_values[expo_name_df$Var]
updateUIInputs(session,params_df)
},ignoreInit = TRUE, ignoreNULL = TRUE)
observeEvent(input$sel_chem,{
chemid <- input$sel_chem
#get the values for inputs
chem_values <- getParameterSet("chem",chemid)
params_df <- chem_name_df
params_df$Val <- chem_values[chem_name_df$Var]
updateUIInputs(session,params_df)
},ignoreInit = TRUE, ignoreNULL = TRUE)
### This code chunk deals with updating pair using qsar models
observeEvent(input$qsar4chem_props,{
qsar_model <- input$qsarModelChem
org <- ifelse(input$ms_org=="ha","human","rat")
chemical_params <- list("den"=input$ms_den, "mw"=input$ms_mw,
"vpa"=input$ms_vpa, "dkow"=input$ms_dkow,
"lkow"=input$ms_lkow, "wsol"=input$ms_wsol,
"res"=input$ms_res, "vmaxc"=input$ms_vmaxc,
"km"=input$ms_km)
partitions <- calculatePartitionCoefficients(qsar_model,
chemical_params,
NULL,
org)
pair <- partitions$pair
frwsol <- partitions$frwsol
updateNumericInput(session,"ms_frwsol",value = frwsol)
})
## This code chunk deals with performing IVIVE for the chemical
observeEvent(input$btn_ivive_chem,{
performIVIVEUI(input$btn_ivive_chem)
dataset$iviveDat <<- callModule(performIVIVE,input$btn_ivive_chem,input$ms_km)
})
observe({
ivive_val <- dataset$iviveDat()
if(ivive_val[1]=="Yes"){
updateNumericInput(session,"ms_vkm1c",value = signif(as.numeric(ivive_val[2]),4))
updateNumericInput(session,"ms_vmaxc",value = signif(as.numeric(ivive_val[3]),4))
updateNumericInput(session,"ms_km",value = signif(as.numeric(ivive_val[4]),4))
}
})
#### The next code chunk resets all the exposures in the app to zero.
observeEvent(input$clear_expo,{
input_names <- c("ms_bdose","ms_drdose","ms_vdw","ms_inhdose","ms_ivdose")
lapply(input_names, function(x){updateNumericInput(session,x,value = 0)})
})
# metab_colnames <- reactive({
# if (input$metab_type == "m2"){
# c("Age(years)","Clearance(L/h/kg Liver)")
# }else{
# c("Age(years)","Clearance (\u00B5M/h/kg BW ^ 0.75)")
# }
# })
output$metab_tble <- DT::renderDT(formatRound(DT::datatable(metabolism_dataframe,
caption = "Metabolism Table",
rowname = NULL,editable = F,
options= list(dom = "tp",pageLength = 5)),
2,digits = 4,mark = "" ),
server = T)
metab_proxy <- DT::dataTableProxy("metab_tble",session)
#Save current metabolism set.
observeEvent(input$btn_saveas_metab,{
if(is.null(input$metab_csv)){
sendSweetAlert(session,"Error","No Dataset Uploaded","error")
}else if(input$metab_set_name=="" || input$metab_set_descrp==""){
sendSweetAlert(session,"Error","Both name and description are required","error")
}else{
#validate(need(input$metab_csv,"Metabolism Data"))
#id <- input$sel_metab
set_type <- "metab"
id_name <- "metabid"
set_table_name <- "MetabolismSet"
set_name <- "Metabolism"
# get the current ID for the parameter set.
query <- sprintf("SELECT %s FROM %s ;",id_name,set_table_name)
id_list <- projectDbSelect(query)
if (length(id_list[[id_name]])==0){
id_num = 1
}else{
id_num = max(id_list[[id_name]])+1
}
metab_type <- input$metab_type
ref_age <- input$metab_ref_age
use_ref <- as.character(input$use_ref)
# write the name to correct "Set" table
query <- sprintf("INSERT INTO %s (%s, name, descrp) VALUES (%d, '%s' , '%s' );",
set_table_name,id_name,id_num,
input$metab_set_name,input$metab_set_descrp)
projectDbUpdate(query)
# serialize and convert the loaded table to database
serialized_metab_tble <- rawToChar(serialize(metab_tble(),NULL,T))
query <- sprintf("INSERT INTO Metabolism (metabid,type,use_ref,ref_age,metab_tble) Values (%d,'%s','%s',%f,'%s');",
id_num,
metab_type,
use_ref,
ref_age,
serialized_metab_tble)
projectDbUpdate(query)
set_list <- getAllSetChoices(set_type)
parameterSets[[set_type]]<- reactiveVal(set_list)
updateSelectizeInput(session,paste0("sel_",set_type),choices = set_list, selected = id_num)
}
})
#update the UI on selecting input
observeEvent(input$sel_metab,{
metab_id <- input$sel_metab
# get the name a description and update
query <- sprintf("Select name,descrp From MetabolismSet where metabid = %d;",
as.integer(metab_id))
ret_data <- projectDbSelect(query)
updateTextInput(session,"metab_set_name",value = ret_data[["name"]])
updateTextAreaInput(session,"metab_set_descrp",value = ret_data[["descrp"]])
query <- sprintf("Select type,ref_age,metab_tble From Metabolism where metabid = %d",
as.integer(metab_id))
ret_data <- projectDbSelect(query)
#print(ret_data)
shinyWidgets::updateRadioGroupButtons(session,"metab_type",selected = ret_data[["type"]])
shinyWidgets::updateAwesomeCheckbox(session,"use_ref",value = as.logical(ret_data[["use_ref"]]))
updateNumericInput(session,"metab_ref_age",value = ret_data[["ref_age"]])
metabolism_dataframe <<- unserialize(charToRaw(ret_data[["metab_tble"]]))
DT::replaceData(metab_proxy,metabolism_dataframe,rownames = F)
},ignoreInit = TRUE, ignoreNULL = TRUE)
# Metabolism is handled in a very different manner than the rest of the sets.
# show the modal to upload files when
observeEvent(input$btn_metab_upload,{showModal(modalDialog(title = "Upload Metabolism Data",
tagList(
fluidPage(
fluidRow(
column(width = 5,
fileInput("metab_csv","Upload Metabolism Data")),
column(width = 5,
downloadLink("metab_template","Template for metabolism file"))
),
fluidRow(
column(width = 4,
textInput("metab_set_name","Name",
placeholder = "Enter the name for this metabolism set")),
column(width = 8,
textAreaInput("metab_set_descrp","Description",
resize = "none" ,row = 1))
),
fluidRow(column(width = 6,
shinyWidgets::radioGroupButtons("metab_type",justified = T,
"Select Meatbolism Type",
choices = c("Linear"="m2"))
)
),
fluidRow(
column(width = 6,
shinyBS::popify(numericInput("metab_ref_age",
"Reference age in Years",
value = 25, min = 0),
title = "",
content = "If age defined in the physiological parameters is not a part of the table, the value at this age will be used")
)
),
fluidRow(
fluidRow(column(width = 6, offset = 3,
DT::DTOutput("metab_upload_tble")))
)
)
),
size ="l",
footer = tagList(
actionButton("metab_upload_done","Add Metabolism"),
modalButton("Cancel")
)
))
})
##Metabolism realated functions
output$metab_template <- downloadHandler(
filename = function(){"Metabolism_Template.csv"},
content = function(file){write.csv(data.frame("Age"=c(25),"Clearence"=c(0),stringsAsFactors = F),
file,
row.names = F)
},
contentType = "text/csv"
)
# The selected file
metabFile <- reactive({
input$metab_csv
})
# The user's data, parsed into a data frame
metab_upload_tble <- reactive({
validate(need(input$metab_csv,"No dataset uploaded"))
#if(!(is.null(input$metab_csv))){
ret_dat <- read.csv(metabFile()$datapath,header = T,stringsAsFactors = F)
#}else{
# ret_dat <- data.frame("Age"=c(25),"Clearance"=c(0),stringsAsFactors = F)
#}
return(ret_dat)
})
output$metab_upload_tble <- DT::renderDT(formatRound(DT::datatable(metab_upload_tble(),
caption = "Metabolism Table",
rowname = NULL,editable = F,
options= list(dom = "tp",pageLength = 5)),
2,digits = 4,mark = "" ),
server = T)
observeEvent(input$metab_upload_done,{
if(is.null(input$metab_csv)){
sendSweetAlert(session,"Error","No Dataset Uploaded","error")
}else if(input$metab_set_name=="" || input$metab_set_descrp==""){
sendSweetAlert(session,"Error","Both name and description are required","error")
}else{
#validate(need(input$metab_csv,"Metabolism Data"))
#id <- input$sel_metab
set_type <- "metab"
id_name <- "metabid"
set_table_name <- "MetabolismSet"
set_name <- "Metabolism"
# get the current ID for the parameter set.
query <- sprintf("SELECT %s FROM %s ;",id_name,set_table_name)
id_list <- projectDbSelect(query)
if (length(id_list[[id_name]])==0){
id_num = 2
}else{
id_num = max(id_list[[id_name]])+1
}
metab_type <- input$metab_type
ref_age <- input$metab_ref_age
# serialize and convert the loaded table to database
metab_tble<-metab_upload_tble()
if (!(ref_age %in% metab_tble$Age)){
sendSweetAlert(session,"Error","Reference age must be a part of the table","error")
}else{
# write the name to correct "Set" table
query <- sprintf("INSERT INTO %s (%s, name, descrp) VALUES (%d, '%s' , '%s' );",
set_table_name,id_name,id_num,
input$metab_set_name,input$metab_set_descrp)
projectDbUpdate(query)
serialized_metab_tble <- rawToChar(serialize(metab_tble,NULL,T))
query <- sprintf("INSERT INTO Metabolism (metabid,type,ref_age,metab_tble) Values (%d,'%s',%f,'%s');",
id_num,
metab_type,
ref_age,
serialized_metab_tble)
projectDbUpdate(query)
set_list <- getAllSetChoices(set_type)
updateSelectizeInput(session,paste0("sel_",set_type),choices = set_list, selected = id_num)
metabset <- c("Use Linear Metabolism"="1",set_list)
updateSelectizeInput(session,"sel_set_metab",choices = metabset)
removeModal()
}
}
})
#### END METABOLISM TAB
### CODE CHUNK FOR HANDLING SIMULATIONS TAB
# Save a new simulation
observeEvent(input$save_sim,{
if (any(c(input$sim_name,input$sim_descrp)=="")){
sendSweetAlert(session,"Error",
"Need to provide Name and Decription for the simulation",
type = "error")
}else{
simid <- getNextID("SimulationsSet")
sim_name <- input$sim_name
sim_descrp <- input$sim_descrp
sim_start <- 0
sim_dur <- input$sim_dur
mc_num <- ifelse(input$mc_mode,input$mc_num,0)
chemid <- as.integer(input$sel_set_chem)
physioid <- as.integer(input$sel_set_physio)
expoid <- as.integer(input$sel_set_expo)
metabid <- as.integer(input$sel_set_metab)
physiovarid <- as.integer(input$sel_set_physiovar)
chemvarid <- as.integer(input$sel_set_chemvar)
expovarid <- as.integer(input$sel_set_expovar)
query <- paste(strwrap(sprintf("INSERT INTO SimulationsSet (simid,name,descrp,expoid,physioid,
chemid,metabid,physiovarid, chemvarid,expovarid,tstart,sim_dur,mc_num) Values
(%d,'%s','%s',%i,%i,%i,%i,%i,%i,%i,%f,%f,%i) ;",
simid,sim_name,sim_descrp,
expoid,physioid,
chemid,metabid,
physiovarid,chemvarid,
expovarid,
sim_start,sim_dur,mc_num),
simplify = T),
sep = " ",collapse = "")
projectDbUpdate(query)
sim_sets <- getAllSetChoices("sim")
updateSelectizeInput(session,"sel_sim",choices = sim_sets)
updateTextInput(session,"sim_name",value = "")
updateTextAreaInput(session,"sim_descrp",value = "")
sendSweetAlert(session,"Success",
sprintf("Simulation saved as %s",sim_name),
type = "success")
}
})
observeEvent(input$sel_sim,{
simid <- as.integer(input$sel_sim)
# get pertinent data from the database
# get All values from the simulations database
query <- sprintf("Select name,descrp,metabid,expoid,physioid,chemid,tstart,sim_dur FROM SimulationsSet Where simid = %i;",
simid)
result <- projectDbSelect(query)
metabid <- as.integer(result[["metabid"]])
chemid <- as.integer(result[["chemid"]])
expoid <- as.integer(result[["expoid"]])
physioid <- as.integer(result[["physioid"]])
sim_name <- result[["name"]]
sim_descrp <- result[["descrp"]]
tstart <- round(result[["tstart"]],2)
sim_dur <- round(result[["sim_dur"]],2)
output$sim_name <- renderText(sim_name)
output$sim_descrp <- renderText(sim_descrp)
output$sim_start <- renderText(as.character(tstart))
output$sim_dur <- renderText(as.character(sim_dur))
# get chemical name from chem table
query <- sprintf("SELECT name from ChemicalSet WHERE chemid = %i ;",
chemid)
result <- projectDbSelect(query)
chem_name <- result$name
output$sim_chem <- renderText(chem_name)
# get exposure name form exposure set table
query <- sprintf("SELECT name from ExposureSet WHERE expoid = %i ;",
expoid)
result <- projectDbSelect(query)
expo_name <- result$name
output$sim_expo <- renderText(expo_name)
# get metabolism data.
metab_data <- getMetabData(metabid,physioid,chemid,model)
output$sim_metab_type <- renderText(metab_data$Type)
output$sim_metab_units <- renderText(metab_data$Units)
output$sim_metab_val <- renderText(as.character(round(metab_data$Value,2)))
},ignoreInit = TRUE, ignoreNULL = TRUE)
# Code chunk to run the simulation.
results <- reactiveValues(pbpk=NULL,simid = NULL,mode = NULL)
observeEvent(input$run_sim,{
simid <- as.integer(input$sel_sim)
results$simid <- simid
# get the parameters needed to run the model
model_params <- getAllParamValuesForModel(simid,model)
#get total volume
# active_comp <- input$ms_cmplist
# vol_comps <- c(active_comp,"blood")
# total_vol <- sum(unlist(lapply(vol_comps,
# function(x){
# input[[vol_ids[x]]]
# })
# )
# )
query <- sprintf("Select mc_num From SimulationsSet where simid = %i",simid)
mc_num <- as.integer(projectDbSelect(query)$mc_num)
model_params$vals[["total_vol"]]<- 1#total_vol
if (mc_num > 1){
MC.matrix <- getAllVariabilityValuesForModel(simid,model_params$vals,mc_num)
query <- sprintf("Select model_var from ResultNames where mode = 'MC' AND model = '%s'",
model)
mc_vars<- mainDbSelect(query)$model_var
mc_results <- lapply(mc_vars,function(x,n){
return(x = rep(NA,n))
},mc_num)
names(mc_results)<- mc_vars
for (i in 1:mc_num){
model_params$vals[colnames(MC.matrix)]<- MC.matrix[i,]
initial_values <- model_params
tempDF <- runFDPBPK(initial_values,model)
max_list <- unlist(lapply(mc_vars,function(x,data){
var_name <- gsub("_max","",x)
val <- max(data[[var_name]])
return(val)
},as.data.frame(tempDF$pbpk)))
names(max_list)<- mc_vars
for (x in mc_vars){
mc_results[[x]][[i]]<- max_list[[x]]
}
updateProgressBar(session,"pb",value = i, total = mc_num)
}
results$pbpk <- as.data.frame(mc_results)
results$mode <- "MC"
updateNavbarPage(session,"menu","output")
}else{
#rep_flag <- all_params["rep_flag"]
#model_params <- all_params["model_params"]
initial_values <- model_params# calculateInitialValues(model_params)
updateProgressBar(session,"pb",value = 100, total = 100,
status = "info")
tempDF <- runFDPBPK(initial_values,model)
results$pbpk<- tempDF$pbpk
results$mode <- "FD"
updateNavbarPage(session,"menu","output")
}
})
############### Code chunk for handling populating simulations tab
# sim_table <- reactiveVal({data.frame("Name"='<input type = "text" id = "r1-name" placeholder = "Enter Name" class = "shiny-bound-input />',
# "Col2"=1,
# "Col3"=0)
# })
#
# output$sim_tble <- DT::renderDataTable(
# DT::datatable(isolate(sim_table()),
# rownames = F,escape = F,
# selection = "single",
# options = list(dom = "t",paging = F
# )),
# server = FALSE)
# sim_tble_proxy <- DT::dataTableProxy("sim_tble")
#
# sim_table <- eventReactive(input$add_row,{
# org_table<- sim_table()
# data_added <- list("Name"=0,"Col2"=1,"Col3"=2)
# sim_table <- rbind(org_table,data_added)
# return(sim_table)
# })
# # parameterSets$sim_table <- eventReactive(input$add_row,{
# # org_table<- isolate(parameterSets$sim_table())
# # data_added <- c("Col1"=0,"Col2"=1,"Col3"=2)
# # sim_table <- rbind(org_table,data_added)
# # return(sim_table)
# # },ignoreInit = TRUE,ignoreNULL = FALSE)
# observe({
# replaceData(sim_tble_proxy,sim_table())
# })
btnDismiss = reactiveValues(modal_closed=F)
#########################new Chemical Modal
observeEvent(input$newChem, {
btnDismiss$modal_closed <- F
showModal(modalDialog(
chemicalInput("chemCRUD"),
easyClose = FALSE,
fade = TRUE,
size = "m",
footer = actionButton("dismiss_modal",label = "Dismiss")
))
chemCRUD <- callModule(chemical, "chemCRUD", stringsAsFactors = FALSE)
})
observeEvent({input$dismiss_modal},{
btnDismiss$modal_closed <- T
removeModal()
chems <- getAllMainChemicals(session, "main")
updateSelectizeInput(session, "selectedChem", "Select a chemical", choices = chems, selected = chems[[1]])
updateSelectizeInput(session, "chemScenFilter", "Select a chemical", choices = chems)
})
#update scenario dropdown based on selected chemical and exposure type (oral, inh...)
observeEvent({input$scenarioFilter
},{
chemId <- input$chemScenFilter
expoKey <- input$exposureType
scenarios <- getAllScenarios(session, input, chemId, expoKey)
if(is.null(scenarios)){
updateSelectizeInput(session, "filteredScen", "Select a Scenario", choices = c("None"="0"), selected = "0")
}else{
updateSelectizeInput(session, "filteredScen", "Select a Scenario", choices = as.list(scenarios), selected = scenarios[[1]])
}
})
######################UPDATE SELECTED EXPOSURE TYPE
observeEvent({input$exposureType},{
expoType <- input$exposureType
updateTabItems(session, "expos_sidebar", expoType)
})
#####################UPDATE SELECTED CHEMICAL
observeEvent({input$chemScenFilter},{
chems <- getAllMainChemicals(session, "main")
#Scenario filter current chem iD
id <- input$chemScenFilter
chem <- currentChem(session, input, id)
updateSelectizeInput(session, "selectedChem", "Select a chemical", choices = chems, selected = chem[[1]])
})
####################Update UI values to match Current scenario Values
# observeEvent({
# input$filteredScen
# },{
# scenKey <- input$filteredScen ##current scenario key
# expoType <- input$exposureType ##current Scenario Exposure type
#
# ###get Scenario exposure params
# selectedExpo <- getExpoParams(session, input, scenKey, expoType)
#
# ###Update Physiological parameters
# # updatePhysioParams(session, input, scenKey)
# })
#system intro for pages under Model Setup
observeEvent(input$btnSetupIntro,{
conn <- dbConnect(SQLite(), dbname = "../../Data/cefic.sqlite")
modelSetup = input$modelSetupTabs
tmpUiItems <- dbSendQuery(conn, sprintf("select id, objectId, message, tab from Intro where tab == '%s' OR tab == '%s' OR tab == '%s'", 'ms', 'na', modelSetup))
uiItems <- fetch(tmpUiItems, n=-1)
dbClearResult(tmpUiItems)
#adding '#' to the ui object ids
uiItems$object <- paste("#",uiItems$object,sep = "")
steps <- data.frame(element = c(uiItems$object), intro = c(uiItems$message))
introjs(session,options = list(steps=steps))
})
#system intro for pages under Model Output
observeEvent(input$btnOutputIntro,{
conn <- dbConnect(SQLite(), dbname = "../../Data/cefic.sqlite")
modelOutput = input$Modeloutput
tmpUiItems <- dbSendQuery(conn, sprintf("select id, objectId, message, tab from Intro where tab == '%s' OR tab == '%s' OR tab == '%s' ", 'mo', 'na', modelOutput))
uiItems <- fetch(tmpUiItems, n=-1)
dbClearResult(tmpUiItems)
#adding '#' to the ui object ids
uiItems$object <- paste("#",uiItems$object,sep = "")
steps <- data.frame(element = c(uiItems$object), intro = c(uiItems$message))
introjs(session,options = list(steps=steps))
})
#############dismiss New Scenario Modal
observeEvent(input$dismissScenModal,{
btnDismiss$modal_closed <- T
removeModal()
})
##########new Scenario Modal
observeEvent(input$newScenario, {
scenarioModal(session, input, btnDismiss$modal_closed <- F, FALSE, "")
})
##########################New scenario
observeEvent({input$submitNewScen},{
chemId <- input$selectedChem
qsarModel <- input$qsarModel
expoType <- input$expos_sidebar
scenData <- list("scenName"=input$scenName, "scenDescription"=input$scenDescription, "chemId"=chemId, "qsarModel"=qsarModel, "expoType"=expoType)
expoData <- list("oralDose"=input$ms_oralDose, "dbr"=input$ms_dbr, "blen"=input$ms_blen, "repTime"=input$ms_repTime, "inhDose"=input$ms_inhDose, "dermDose"=input$ms_dermDose, "expoType" = expoType)
physiData <- list( "gender"=input$ms_gender, "age"=input$ms_age, "qcc"=input$ms_qcc, "bw"=input$ms_bw, "vbc"=input$ms_vbc, "qven"=input$ms_qven,"qart"=input$ms_qart,"vfat"=input$ms_vfat, "qfat"=input$ms_qfat,
"pfat"=input$ms_pfat,"vskin"=input$ms_vskin, "qskin"=input$ms_qskin, "pskin"=input$ms_pskin, "vmusc"=input$ms_vmusc, "qmusc"=input$ms_qmusc, "pmusc"=input$ms_pmusc, "vmarr"=input$ms_vmarr, "qmarr"=input$ms_qmarr,
"pmarr"=input$ms_pmarr,"vbone"=input$ms_vbone, "qbone"=input$ms_qbone, "pbone"=input$ms_pbone, "vbrn"=input$ms_vbrn, "qbrn"=input$ms_qbrn, "pbrn"=input$ms_pbrn, "vlng"=input$ms_vlng, "qlng"=input$ms_qlng,
"plng"=input$ms_plng,"qhrt"=input$ms_qhrt, "ahvnt"=input$ms_ahvnt, "alvnt"=input$ms_alvnt, "phrt"=input$ms_phrt, "vhrt"=input$ms_vhrt, "vgrt"=input$ms_vgrt, "pgs"=input$ms_pgs, "vliv"=input$ms_vliv,
"qaliv"=input$ms_qaliv,"qvliv"=input$ms_qvliv, "pliv"=input$ms_pliv, "vkdn"=input$ms_vkdn, "qkdn"=input$ms_qkdn, "uflw"=input$ms_uflw, "gfltr"=input$ms_gfltr, "pkdn"=input$ms_pkdn)
if(is.null(scenData$chemId)){
showNotification(tags$p(paste0("You may have forgot to select a chemical"), style="color: red"), duration = 10)
}else{
callNewScenarioModal <- newScenario(session, scenData, expoData, physiData)
if(callNewScenarioModal != ""){
scenarioModal(session, input, FALSE, FALSE, callNewScenarioModal)
}else{
btnDismiss$modal_closed <- T
removeModal()
showNotification(tags$p("Scenario Created Successfully", style="color: green"), duration = 10)
}
}
})
#############dismiss New Scenario Modal
observeEvent(input$dismissScenModal,{
btnDismiss$modal_closed <- T
removeModal()
})
######################Restore Selected Parameters
observeEvent(input$restore,{
param_data <- getChangedTable(isolate(input),paraValueList)
output$restore_table <- DT::renderDT(dt::datatable(param_data,rownames = FALSE), server = TRUE)
})
observeEvent(input$apply,{
param_data <- getChangedTable(isolate(input),param_values_list)
row_count <- isolate(input$restore_table_rows_selected)
for (i in 1:length(row_count)){
var = paste0(sprintf("%s",param_data[row_count[i], 1])) #variable name
val = as.numeric(paste0(param_data[row_count[i], 3])) #original value
updateNumericInput(session, var, value = val)
}
toggleModal(session,"restore_modal",toggle = "close")
}) #end retore btn
# Life course equation
tissue_volumes<- reactive({
tissues <- c(input$ms_cmplist,"blood")
perfc <- input$ms_perfc
vols <- getLifecourseTissueVolumes(input$ms_age, input$ms_gender,perfc, tissues)
vols["bw"] <- getLifecourseBodyWeight(input$ms_age,input$ms_gender)
return(vols)
})
tissue_ratios<- reactive({
tissues <- c(input$ms_cmplist)
flows <- getLifecourseTissuePerfusion(input$ms_age, input$ms_gender, tissues)
flows["qc"]<- getLifecourseCardiacOutput(input$ms_age,input$ms_gender)
#tissues <- list("fat", "skin", "muscle", "bone", "boneMarow", "brain", "lung", "heart", "gastric", "liver", "kidney")
return(flows)
})
#LifeCourse Equation
observeEvent(input$btn_use_lifecourse,{
shinyBS::updateButton(session,"btn_use_lifecourse",style = "primary")
age <- input$ms_age
gender<- input$ms_gender
# get volumes from life course equations
tissues <- c(input$ms_cmplist,"blood")
perfc <- input$ms_perfc
vols <- getLifecourseTissueVolumes(age,gender,perfc, tissues)
vols["bw"] <- getLifecourseBodyWeight(age,gender)
#update the UI with new volumes
updateVolumes(session,vols)
#Get blood flow ratios from life course equations
tissues <- input$ms_cmplist # since there is no blood flow through blood
flows <- getLifecourseTissuePerfusion(age,gender, tissues)
flows["qc"]<- getLifecourseCardiacOutput(age,gender)
updateRatios(session, flows)
ventilation_rate <- getLifecourseVentilationRate(age,gender)
updateNumericInput(session,"ms_respr",value = signif(ventilation_rate,4))
tidal_volume <- getLifecourseTidalVolume(age,gender)
updateNumericInput(session,"ms_tv",value = signif(tidal_volume,4))
ds <- getLifecourseLungDeadSpace(age,gender)
updateNumericInput(session,"ms_ds",value = signif(ds,4))
gfr<- getLifecourseGlomerularFiltrationRate(age,gender)
updateNumericInput(session,"ms_gfr",value = signif(gfr,4))
})
# when age and gender are changed, change the type of button to indicate things are out of sync
observeEvent({input$ms_age ;input$ms_gender; input$ms_cmplist},{
shinyBS::updateButton(session,"btn_use_lifecourse",style = "warning")
},ignoreInit = TRUE )
#Qsar models
observeEvent(input$btn_useQSAR4Partition,
{
shinyBS::updateButton(session,"btn_useQSAR4partition",style = "primary")
chemid <- input$sel_chem4Partition
#chemcas <- input$sel_chem4Partition
qsar_model <- input$sel_qsar4Partition
org <-input$ms_Org #ifelse(input$ms_org=="ha","human","rat")
query <- sprintf("SELECT param,value FROM Chemical Where chemid = %i",
as.integer(chemid))
ret_data <- projectDbSelect(query)
#print(ret_data)
chemical_params <- setNames(ret_data$value,ret_data$param)
query <- sprintf("Select name,cas FROM ChemicalSet where chemid = %i",
as.integer(chemid))
ret_data <- projectDbSelect(query)
chemical_params[["Compound"]]<- ret_data$name
chemical_params[["CAS"]]<- ret_data$cas
chem_name <- ret_data$name
# # #print(chemical_params)
# chemical_params <- chemical_params[-which(names(chemical_params)%in% c("Clmetabolismc","Corg"))]
# data2add <- data.frame(lapply(chemical_params, function(x) t(data.frame(x))))
# # print(data2add)
# data_list <- setNames(names(chemical_params),names(chemical_params))
#unlockBinding("chem.physical_and_invitro.data",environment())
#httkAddTable(data2add,data_list)
# temp_httk_table <- httk::add_chemtable(data2add,
# data_list,species = "Human",
# current.table = chem.physical_and_invitro.data,
# reference = "None",
# overwrite = T)
# httk::chem.physical_and_invitro.data <- temp_httk_table
params <- httkParameterPBTK(chem_name,org)
#parameterize_pbtk(chem.cas = ret_data$cas)
updatePhysiology(session,params,physio_name_df)
# tissue_list <- list()
# active_tissues <- input$ms_cmplist
# active_tissues <- active_tissues[!(active_tissues %in% c("rpf","spf"))]
# tissue_list$active <- active_tissues
# tissue_list$spf <- c()
# tissue_list$rpf <- c()
# calculatedCoeff <- calculatePartitionCoefficients(qsar_model,chemical_params,tissue_list,org)
# updateCoeffs(session, calculatedCoeff)
# updateNumericInput(session,"ms_pair",value = calculatedCoeff$pair)
})
# when chemical and/or model are changed, change the type of button to indicate things are out of sync
observeEvent({input$sel_chem4partition ;input$sel_qsar4Partition},{
shinyBS::updateButton(session,"btn_useQSAR4Partition",style = "warning")
},ignoreInit = TRUE )
#Current Parameters table under Model output
current_params <- reactive({
temp <- getAllParamValuesForModel(input$sel_sim,model = model)
# get exposure paramteres
expo_list <- temp[expo_name_df$Var]
expo_params <- data.frame("var" = expo_name_df$Var, "val" = temp[expo_name_df$Var],
stringsAsFactors = F)
physio_params <- data.frame("var" = physio_name_df$Var, "val" = temp[physio_name_df$Var],
stringsAsFactors = F)
current_params <- data.frame("var" = names(temp),"val" = temp,stringsAsFactors = F)
#current_params <- temp$a
#current_params <- cbind(gsub("ms_", "",temp$b),current_params)
return(list("cur" = current_params,"expo" = expo_params,"physio" = physio_params))
})
output$pamamstbl <- DT::renderDT(DT::datatable(current_params()$cur,
rownames = F),
colnames=c("Variable names", "Value"))
output$expo_params_tble <- DT::renderDT(DT::datatable(current_params()$expo,
rownames = F),
colnames=c("Variable names", "Value"))
output$physio_params_tble <- DT::renderDT(DT::datatable(current_params()$physio,
rownames = F),
colnames=c("Variable names", "Value"))
#*******************these are not called anywhere.
# These functions update the current values used in the restore paramsparams
# resetParaValueList <- function(session, paraValueList, volumes, ratios){
#
# for(name in names(volumes)){
# paraValueList[name] <<- volumes[[name]]
# }
# for(name in names(ratios)){
# paraValueList[name] <<- ratios[[name]]
# }
#
# return(paraValueList)
# }
#
#
# resetParam_values_list <- function(session, param_values_list, volumes, ratios){
# for(name in names(volumes)){
# param_values_list[name] <<- volumes[[name]]
# }
#
#
# for(name in names(ratios)){
# param_values_list[name] <<- ratios[[name]]
# }
# return(param_values_list)
# }
observeEvent(input$run,{
active_comp <- input$ms_cmplist
compartment_list <-c("skin","fat","muscle","bone","brain","lung","heart","gi","liver","kidney","rpf","spf")
inactive_comp <- setdiff(compartment_list,active_comp)
vol_comps <- c(active_comp,"blood")
perfc <- input$ms_perfc
total_vol <- sum(unlist(lapply(vol_comps,function(x){input[[vol_ids[x]]]})))
#exposure
if ("gi" %in% active_comp && !("liver" %in% active_comp)){
showModal(
modalDialog(
tags$h4("Invalid Compartment Configuration"),
tags$h5("Liver compartment needs to be active if GI compartment is active"),
title = "Error"
)
)
}else if (length(active_comp) == 0){
showModal(
modalDialog(
tags$h4("Invalid Compartment Configuration"),
tags$h5("At least one compartment needs to be active for the model to run."),
title = "Error"
)
)
}else if(abs(total_vol-perfc)>0.03){
showModal(
modalDialog(
tags$h4("Invalid Compartment Configuration"),
tags$h5("The total volume of all compartments does not add up to 85%"),
title = "Error"
)
)
}else if((input$ms_bdose>0 || input$ms_drdose>0) && !("gi" %in% active_comp)){
showModal(
modalDialog(
tags$h4("Invalid Compartment Configuration"),
tags$h5("GI compartment must be active for Oral and Drinking water routes of exposure"),
title = "Error"
)
)
}else{
# set volumes of inactive compartments to 1e-8 ( very low)
sapply(inactive_comp,function(x){updateNumericInput(session,vol_ids[x],value = 1e-8)})
# set blood flow of inactive compartments to 0 ( very low)
sapply(inactive_comp,function(x){updateNumericInput(session,flow_ids[x],value = 0)})
withProgress({
tempDF <- runPBPKmodel(input, total_vol,perfc)
results$pbpk<- tempDF$pbpk
},
message = "Running Simulation",
value = 0.75
)
}
}
)
observeEvent(input$btnAddData,{
addDataSetUI(input$btnAddData,"Generic PBPK")
dataset$savedat <- callModule(addDataSet,input$btnAddData,"Generic PBPK")
# conc_datasets <- c("none",getDatasetNames("conc"))
# updateSelectizeInput(session,"cplt_data",choices = conc_datasets)
})
observe({
if(dataset$savedat()[1]=="Yes"){
type <- dataset$savedat()[2]
set_list <- getObservationSetChoices(type)
if(type == "conc"){
ui_id <- "cplt_data"
}else{
ui_id <- "cl_data"
}
shinyWidgets::updatePickerInput(session,ui_id,
choices = c("No Dataset"="none",set_list),
selected = "none")
dataset$savedat <- reactiveVal(c("No","None"))
# updateSelectizeInput(session,paste0("sel_scene_",set_type),choices = set_list)
}
})
# Exposure PLots data
exposureData <- reactive({
result<- as.data.frame(results$pbpk)
values <- c()
legend_names<-c("odose"= "Instantaneous Oral Dose",
"totodose"="Total Oral Dose",
"ddose"= "Instantaneous Drinking Dose",
"totddose"="Total Drinking Dose",
"ainh"="Total Inhalation Dose",
"InstInhDose"="Instantaneous Inhalation Dose")#,
#"ADRM"= "Total Dermal Dose",
#"InstDrmDose"= "Instantaneous Dermal Dose"
#)
# get exposure values for the simulation just run
simid <- results$simid
if(is.null(simid)){
bdose <- 0
ddose <- 0
idose <- 0
}else{
query <- sprintf("SELECT expoid FROM SimulationsSet Where simid = %i ;",
simid)
expoid <- projectDbSelect(query)$expoid
query <- sprintf("Select param,value FROM Exposure WHERE expoid = %i;",
expoid)
ret_data <- projectDbSelect(query)
expo_data <- setNames(as.character(ret_data$value),
ret_data$param)
bdose <- as.numeric(expo_data['bdose'])
ddose <- as.numeric(expo_data['drdose'])
idose <- as.numeric(expo_data['inhdose'])
}
if (input$r_expo_type == "act"){
if (input$ch_dose == TRUE){
if (bdose >0){
values<- c("odose",values)
}else if(ddose > 0){
values <- c("ddose",values)
}else if(idose >0){
values<- c("InstInhDose",values)
# }else if(drmdlen>0){
# values<- c("InstDrmDose",values)
}
}
if(input$ch_totdose == TRUE){
if (bdose >0){
values<- c("totodose",values)
}else if (ddose >0){
values<- c("totddose",values)
}else if(idose >0){
values<- c("ainh",values)
}
# }else if(drmdlen>0){
# values<- c("adrm",values)
#}
}
}else{
if (input$ch_dose == TRUE){
values <- c('odose','ddose','InstInhDose',values)
}
if(input$ch_totdose == TRUE){
values <- c('totodose','totddose','ainh',values)
}
}
if (exists("plot_frame")){
rm(plot_frame)
}
# check if model was ever run
if (dim(result)[1]==0){
x<- 1:10
}else{
x<- as.integer(result$time)
}
plot_frame <- data.frame(time = x)
#select appropriate variables to plot
if (dim(result)[1]==0){
plot_frame["Model not yet run"]<-rep(0,length(x))
}
else if(length(values) >0 ){
for (plt_name in values){
y<- result[[plt_name]]
plot_frame[legend_names[plt_name]] <-y
}
}else{
plot_frame["No Data Selected"]<-rep(0,length(x))
}
plot_frame <- reshape2::melt(plot_frame,id.vars = "time")
return(plot_frame)
})
# Dataset plotting
concDataset <- reactive({
if (input$cplt_data=="none"){
return(data.frame("time"=c(0),"mean"=c(0),"sd"=c(0)))#data.frame("time"=NULL,"mean"=NULL,"sd"=NULL))
}else{
obsid <- input$cplt_data
query <- sprintf("SELECT units, obs_tble FROM Observation WHERE obsid = %i",
as.integer(obsid))
obs_data <- projectDbSelect(query)
dataset <- unserialize(charToRaw(obs_data$obs_tble))
if (ncol(dataset)<3){
dataset[,"sd"]<- 0
}
names(dataset)<- c("time","mean","sd")
return(dataset)
}
})
concDatasetName <- reactive({
if (input$cplt_data=="none"){
return("No Dataset Selected")#data.frame("time"=NULL,"mean"=NULL,"sd"=NULL))
}else{
obsid <- input$cplt_data
query <- sprintf("SELECT name FROM ObservationSet WHERE obsid = %i",
as.integer(obsid))
obs_name <- projectDbSelect(query)
return(obs_name)
}
})
# Concentration plot Data
concData <- reactive({
result <- results$pbpk
units <- input$r_cplt_type
simid <- results$simid
mode <- results$mode
if(is.null(simid)){
mw <- 1000 # to keep the multiplier as 1
}else{
query <- sprintf("SELECT mc_num,chemid FROM SimulationsSet Where simid = %i ;",
simid)
chemid <- projectDbSelect(query)$chemid
mc_num <- projectDbSelect(query)$mc_num
query <- sprintf("Select value FROM Chemical WHERE chemid = %i AND param = 'mw';",
chemid)
mw <- projectDbSelect(query)$value
}
#get value multiplier based on concentration units
if(units == "um"){
multiplier <- 1
}else{
multiplier <- mw/1000
}
result<- as.data.frame(result)
values <- c()
query <- sprintf("Select model_var,plot_var,name from ResultNames where param_set = 'conc' AND model='%s' AND mode = '%s';",model,mode)
legend_df <- mainDbSelect(query)
legend_names <- setNames(legend_df$name,legend_df$model_var)
var_names <- setNames(legend_df$model_var,legend_df$plot_var)
plot_vals<- input$cplt_comp
values <- unlist(lapply(plot_vals,function(x){var_names[x]}))
names(values)<- NULL
if (exists("plot_frame")){
rm(plot_frame)
}
# check if model was ever run
if (dim(result)[1]==0){
plot_frame<- 1:10
}else{
if(mode == "FD"){
x<- result$time
plot_frame <- data.frame("time" = result$time,
stringsAsFactors = F)
}else{
x <- 1:nrow(result)
plot_frame <- data.frame("sample" = 1:nrow(result),
stringsAsFactors = F)
}
}
# select appropriate variables to plot
if (dim(result)[1]==0){
plot_frame["Model not yet run"]<-rep(0,length(x))
}
else if(length(values) >0 ){
for (plt_name in values){
y<- result[[plt_name]] * multiplier
plot_frame[[legend_names[plt_name]]] <-y
}
}else{
plot_frame["No Data Selected"]<-rep(0,length(x))
}
if (mode == "FD"){
plot_frame <- reshape2::melt(plot_frame,id.vars = "time")
}else{
plot_frame <- reshape2::melt(plot_frame,id.vars = "sample")
}
return(plot_frame)
})
amtData <- reactive({
result <- results$pbpk
simid <- results$simid
mode <- results$mode
values <- c()
query <- sprintf("Select model_var,plot_var,name from ResultNames where param_set = 'amt' AND model='%s' AND mode = '%s';",model,mode)
legend_df <- mainDbSelect(query)
legend_names <- setNames(legend_df$name,legend_df$model_var)
var_names <- setNames(legend_df$model_var,legend_df$plot_var)
plot_vals<- input$aplt_comp
values <- unlist(lapply(plot_vals,function(x){var_names[x]}))
names(values)<- NULL
#
# if (exists("plot_frame")){
# rm(plot_frame)
# }
# # check if model was ever run
# if (dim(result)[1]==0){
# x<- 1:10
# }else{
# x<- result$time
# }
# plot_frame<- data.frame(time = x)
# # select appropriate variables to plot
# if (dim(result)[1]==0){
# plot_frame["Model not yet run"]<-rep(0,length(x))
# }
# else if(length(values) >0 ){
# for (plt_name in values){
# y<- result[[plt_name]]
# plot_frame[[legend_names[plt_name]]] <-y
# }
# }else{
# plot_frame["No Data Selected"]<-rep(0,length(x))
# }
# plot_frame <- reshape2::melt(plot_frame,id.vars = "time")
# return(plot_frame)
if (exists("plot_frame")){
rm(plot_frame)
}
# check if model was ever run
if (dim(result)[1]==0){
plot_frame<- 1:10
}else{
if(mode == "FD"){
x<- result$time
plot_frame <- data.frame("time" = result$time,
stringsAsFactors = F)
}else{
x <- 1:nrow(result)
plot_frame <- data.frame("sample" = 1:nrow(result),
stringsAsFactors = F)
}
}
# select appropriate variables to plot
if (dim(result)[1]==0){
plot_frame["Model not yet run"]<-rep(0,length(x))
}
else if(length(values) >0 ){
for (plt_name in values){
y<- result[[plt_name]]
plot_frame[[legend_names[plt_name]]] <-y
}
}else{
plot_frame["No Data Selected"]<-rep(0,length(x))
}
if (mode == "FD"){
plot_frame <- reshape2::melt(plot_frame,id.vars = "time")
}else{
plot_frame <- reshape2::melt(plot_frame,id.vars = "sample")
}
return(plot_frame)
})
AUCData <- reactive({
#getAUCPlotData(input,results$pbpk)
})
balData<- reactive({
result<- as.data.frame(results$pbpk)
# check if model was ever run
if (dim(result)[1]==0){
x<- 1:10
}else{
x<- result$time
}
plot_frame<-data.frame(time = x)
# select appropriate variables to plot
if (dim(result)[1]==0){
plot_frame["Model not yet run"]<-rep(0,length(x))
}else{
plot_frame["Mass Balance"]<- result$mbal
}
plot_frame <- reshape2::melt(plot_frame,id.vars = "time")
return(plot_frame)
})
# output$concplt <- plotly::renderPlotly(plotly::ggplotly(ggplot()
# +geom_line(data = concData(), aes(x=time,y=value,color = variable))
# +geom_pointrange(data = concDataset(),aes(x = time,y = mean, ymin = mean-sd ,ymax = mean+sd,fill = "Dataset (mg/L)"))
#
# +labs(x="Time (h)",y="Concentration")
# +theme(axis.text=element_text(size = 15),axis.title=element_text(size = 25),legend.text=element_text(size=15),legend.title=element_blank())))
concplt <- reactive({
if (results$mode == "FD"){
plotly::plot_ly()%>%
plotly::add_trace(data = concData(),x = ~time,
y = ~value,color = ~variable,
type = "scatter",mode = "lines") %>%
plotly::add_trace(data = concDataset(),x = ~time,y = ~mean,
type = "scatter",mode = "markers",
name = concDatasetName(),
marker = list(color = "#000"),
error_y = list(array= ~sd,
color = '#000')
)%>%
plotly::layout(xaxis = list(title = ('Time(days)')),
yaxis = list(title = (ifelse(input$r_cplt_type=="um",'Concentration (\u00B5M)',
'Concentration (mg/L)'))))
}else{
plotly::plot_ly()%>%
plotly::add_trace(data = concData(),
y = ~value,color = ~variable,
type = "box")
}
})
amtplt <- reactive({
if (results$mode == "FD"){
plotly::plot_ly() %>%
plotly::add_trace(data = amtData(),x =~time,
y= ~value,color = ~variable,
type = "scatter",mode="lines")
# plotly::ggplotly(ggplot(amtData(), aes(x=time,y=value,color = variable))+geom_line()
# +labs(x="Time (h)",y="Amount")
# +theme(axis.text=element_text(size = 15),axis.title=element_text(size = 25),legend.text=element_text(size=15),legend.title=element_blank()))
}else{
plotly::plot_ly()%>%
plotly::add_trace(data = amtData(),
y = ~value,color = ~variable,
type = "box")
}
})
output$concplt <- plotly::renderPlotly(concplt())
output$exposureplt <- plotly::renderPlotly(plotly::ggplotly(ggplot(exposureData(), aes(x=time,y=value,color = variable))+geom_line()
+labs(x="Time (days)",y="Amount(umoles)")
+theme(axis.text=element_text(size = 15),axis.title=element_text(size = 25),legend.text=element_text(size=15),legend.title=element_blank())))
output$amtplt <- plotly::renderPlotly(amtplt())
# output$aucplt <- renderPlot(ggplot(AUCData(), aes(x=time,y=value,color = variable))+geom_line()
# +labs(x="Time (h)",y="AUC (mg*h/L)")
# +theme(axis.text=element_text(size = 15),axis.title=element_text(size = 25),legend.text=element_text(size=15),legend.title=element_blank()))
output$balplt <- renderPlot(ggplot(balData(), aes(x=time,y=value,color = variable))+geom_line()
+labs(x="Time (h)",y="Amount (umoles)")
#+ylim(-1e-5,1e-5)
+theme(axis.text=element_text(size = 15),axis.title=element_text(size = 25),legend.position="none")
)
#data tables
output$conctble <- renderDataTable(reshapePlotData(concData()))
output$expotble <- renderDataTable(reshapePlotData(exposureData()))
output$amttble <- renderDataTable(reshapePlotData(amtData()))
output$baltble <- renderDataTable(reshapePlotData(balData()))
#output$auctble <- renderDataTable(reshapePlotData(AUCData()))
#Download Plots data Tables
output$expodwnld <- downloadHandler(
filename = function(){
return("expo_data.csv")
},
contentType = "text/csv",
content = function(file) {
write.csv(reshapePlotData(exposureData()), file)
}
)
output$cdwnld <- downloadHandler(
filename = function(){
return("conc_data.csv")
},
contentType = "text/csv",
content = function(file) {
write.csv(reshapePlotData(concData()), file)
}
)
output$amwnld <- downloadHandler(
filename = function(){
return("amt_data.csv")
},
contentType = "text/csv",
content = function(file) {
write.csv(reshapePlotData(amtData()), file)
}
)
output$aucdwnld <- downloadHandler(
filename = function(){
return("auc_data.csv")
},
contentType = "text/csv",
content = function(file) {
write.csv(reshapePlotData(AUCData()), file)
}
)
output$cmbaldwnld <- downloadHandler(
filename = function(){
return("balance_data.csv")
},
contentType = "text/csv",
content = function(file) {
write.csv(reshapePlotData(results()), file)
}
)
# power button to shut down the app
observeEvent(input$menu,{
if(input$menu=="Stop"){
shinyWidgets::confirmSweetAlert(session,"close_dialog", "Close Application",
"Any changes will be saved. Proceed?",type = "info",danger_mode = T)
}
})
observeEvent(input$close_dialog,{
if (input$close_dialog){
saveProject()
stopApp()
}else{
updateNavbarPage(session,"menu","setup")
}
})
})
calculateInitialValues <- function(params_list){
params <- params_list$vals
brep_flag <- as.logical(params[["brep_flag"]])
iv_flag <- as.logical(params[["ivrep_flag"]])
params <- params[which(grepl("[-]?[0-9]+[.]?[0-9]*|[-]?[0-9]+[L]?|[-]?[0-9]+[.]?[0-9]*[eE][0-9]+",params))]
params <- lapply(params,function(x){as.numeric(x)})
initial_params <- within(as.list(params),{
#Scaled Tissue Volumes
vbld <- vbldc*(perfc/total_vol)*bw #L;Blood
vpls <- vbld*(1-hct)
vfat <- vfatc*(perfc/total_vol)*bw
vskin <- vskinc*(perfc/total_vol)*bw
vmusc <- vmuscc*(perfc/total_vol)*bw
vbone <- vbonec*(perfc/total_vol)*bw
vbrn <- vbrnc*(perfc/total_vol)*bw
vlng <- vlngc*(perfc/total_vol)*bw
vhrt <- vhrtc*(perfc/total_vol)*bw
vkdn <- vkdnc*(perfc/total_vol)*bw
vgi <- vgic*(perfc/total_vol)*bw
vliv <- vlivc*(perfc/total_vol)*bw
vrpf <- vrpfc*(perfc/total_vol)*bw
vspf <- vspfc*(perfc/total_vol)*bw
#Total Fractional Perfusion
total_perf <- qfatc+qskinc+qmuscc+qbonec+qbrnc+qlngc+qhrtc+qkdnc+qvlivc+qrpfc+qspfc # This does not include flow to GI since that is a part of liver venous flow
#Scaled Perfusion
qcp <- qcc*(1-hct)
qfat <- qfatc*(1/total_perf)*qcp
qskin <- qskinc*(1/total_perf)*qcp
qmusc <- qmuscc*(1/total_perf)*qcp
qbone <- qbonec*(1/total_perf)*qcp
qbrn <- qbrnc*(1/total_perf)*qcp
qlng <- qlngc*(1/total_perf)*qcp
qhrt <- qhrtc*(1/total_perf)*qcp
qkdn <- qkdnc*(1/total_perf)*qcp
qvliv <- qvlivc*(1/total_perf)*qcp
qgi <- (qgic/(qgic+qalivc))*qvliv
qaliv <- (qalivc/(qgic+qalivc))*qvliv
qrpf <- qrpfc*(1/total_perf)*qcp
qspf <- qspfc*(1/total_perf)*qcp
#Scaled tissue permeability coefs
pafat <- pafat*vfat**0.75
paskin <- paskin*vskin**0.75
pamusc <- pamusc*vmusc**0.75
pabone <- pabone*vbone**0.75
pabrn <- pabrn*vbrn**0.75
palng <- palng*vlng**0.75
pahrt <- pahrt*vhrt**0.75
pakdn <- pakdn*vkdn**0.75
pagi <- pagi*vgi**0.75
paliv <- paliv*vliv**0.75
parpf <- parpf*vrpf**0.75
paspf <- paspf*vspf**0.75
vkm1 <- vkm1c*vliv
vmaxliv <- vmaxc*bw**0.75
tstop <- tstart+sim_dur
cinh <- inhdose/24.45
qalv <- (tv-ds)*respr
pair <- ifelse(pair >0,pair,1E-10)
})
#function for dosing
mw <- initial_params[["mw"]]
bw <- initial_params[["bw"]]
#ORAL
bdose <- initial_params[["bdose"]]
breps <- initial_params[["breps"]]
blen <- initial_params[["blen"]]
totbreps <- initial_params[["totbreps"]]<-breps*blen
#Drinking Water
ddose <- initial_params[["drdose"]]
vdw <- initial_params[["vdw"]]
dreps <- initial_params[["dreps"]]
#inhalation
inhdose <- initial_params[["inhdose"]]
inhtlen <- initial_params[["inhtlen"]]
inhdays <- initial_params[["inhdays"]]
#iv
ivdose <- initial_params[["ivdose"]]
ivlen <- initial_params[["ivlen"]]
#simulation
tstart <- initial_params[["tstart"]]
totdays <- initial_params[["totdays"]]
tstop <- initial_params[["tstop"]]
#if bolus oral dose is administered
if (bdose > 0){
# var to change
state_Var <- c("odose","totodose")
# operation of event
operation <- c("add","add")
# times of event
if (breps==1){
# Value of change
change_val1<- (bdose*bw*1000/mw)
change_val2<- change_val1
change_arr <- c(change_val1,change_val2)
#only one bolus dose per day
if (brep_flag){
event_times <- head(seq(tstart,tstop,24),-1)
}else{
event_times <- c(tstart)
}
}else{
# Value of change
change_val1<- (bdose*bw*1000/mw)/totbreps
change_val2<- change_val1
change_arr <- c(change_val1,change_val2)
#multiple bolus doses per day
if (brep_flag){
event_times <- unlist(lapply(X = 1:totdays,
FUN = function(x){
head(seq(0,blen,1/breps),-1)+(24*(x-1))
}
)
)
}else{
#only one day
event_times <- unlist(lapply(X = 1,
FUN = function(x){
head(seq(0,blen,1/breps),-1)+(24*(x-1))
}
)
)
}
}
eventDat <- data.frame(
var = rep(x = state_Var,each = length(event_times)),
time = rep(event_times,length(state_Var)),
value = rep(x = change_arr,each = length(event_times)),
method = rep(x = operation,each = length(event_times))
)
# if drinking water dose is administered
}else if (ddose >0){
# var to change
state_Var <- c("ddose","totddose")
# Value of change
change_val1 <- (ddose*1000*vdw/mw)/dreps
change_val2 <- change_val1
change_arr <- c(change_val1,change_val2)
# operation of event
operation <- c("add","add")
# times of event
event_times <- unlist(lapply(X = 1:totdays,function(x){head(seq(0,24,by = 24/dreps),-1)+24*(x-1)}))
eventDat <- data.frame(
var = rep(x = state_Var,each = length(event_times)),
time = rep(event_times,length(state_Var)),
value = rep(x = change_arr,each = length(event_times)),
method = rep(x = operation,each = length(event_times))
)
# if inhalation dose is administered
}else if (inhdose >0){
# var to change
state_var1 <- "inhswch"
state_var2 <- "inhswch"
# Value of change
change_val1 <- 1
change_val2 <- 0
# operation of event
operation1 <- "rep"
operation2 <- "rep"
# times of event
#days on which dosing can occue
event_days<- unlist(lapply(X=1:totdays,function(x){lapply(1:inhdays,function(y){(x-1)*7+y})}))
event_times1 <- unlist(lapply(event_days,function(x){0+24*(x-1)}))
event_times1 <- event_times1[event_times1 < tstop]
event_times2 <- unlist(lapply(event_days,function(x){inhtlen+24*(x-1)}))
event_times2 <- event_times2[event_times2 < tstop]
eventDat <- data.frame(
var = c(rep(x = state_var1,each = length(event_times1)),rep(x = state_var2,each = length(event_times2))),
time = c(event_times1,event_times2),
value = c(rep(x = change_val1,each = length(event_times1)),rep(x = change_val2,each = length(event_times2))),
method = c(rep(x = operation1,each = length(event_times1)),rep(x = operation2,each = length(event_times2)))
)
}else if (ivdose >0){
# var to change
state_var1 <- "ivswch"
state_var2 <- "ivswch"
# Value of change
change_val1 <- 1
change_val2 <- 0
# operation of event
operation1 <- "rep"
operation2 <- "rep"
# times of event
#days on which dosing can occue
#event_days = unlist(lapply(X=1:7,function(x){lapply(1:inhdays,function(y){(x-1)*7+y})}))
event_days <- unlist(lapply(X=1:totdays,function(x){lapply(1:7,function(y){(x-1)*7+y})}))
event_times1 <- unlist(lapply(event_days,function(x){0+24*(x-1)}))
event_times1 <- event_times1[event_times1 < tstop]
event_times2 <- unlist(lapply(event_days,function(x){ivlen+24*(x-1)}))
event_times2 <- event_times2[event_times2 < tstop]
eventDat <- data.frame(
var = c(rep(x = state_var1,each = length(event_times1)),rep(x = state_var2,each = length(event_times2))),
time = c(event_times1,event_times2),
value = c(rep(x = change_val1,each = length(event_times1)),rep(x = change_val2,each = length(event_times2))),
method = c(rep(x = operation1,each = length(event_times1)),rep(x = operation2,each = length(event_times2)))
)
}
times <- seq(tstart,tstop,by=0.1)
eventDat <- eventDat[order(eventDat$time),]
state <- c(
#exposure related
inhswch=0,ainh=0,aexh=0,
totodose=0,odose=0,totddose=0,ddose=0,aabsgut=0,
ivswch=0,aiv=0,
#compartments
abld=0,
abfat=0,atfat=0,
abskin=0,atskin=0,
abmusc=0,atmusc=0,
abbone=0,atbone=0,
abbrn=0,atbrn=0,
ablng=0,atlng=0,
abhrt=0,athrt=0,
abgi=0,atgi=0,
abliv=0,atliv=0,
abkdn=0,atkdn=0,
abrpf=0,atrpf=0,
abspf=0,atspf=0,
# Clearance
ametliv1=0,ametliv2=0,aclbld=0,auexc=0,anabsgut=0)
initial_values <- list("evnt_data"= eventDat,
"initial_params"= initial_params[params_list$names],
"times"=times,
"tstop"=tstop,"tstart"=tstart,
"state"= state)
return(initial_values)
}
#update Physiology inputs
updatePhysiology <- function(session,params,physio_name_df){
for (x in names(params)){
if(x %in% physio_name_df$Var){
type <- physio_name_df$ParamType[which(physio_name_df["Var"]==x)]
input_id <- paste0("ms_",x)
if(type == "Select"){
updateSelectInput(sesion,input_id,selected = params[[x]])
}else{
updateNumericInput(session,input_id,value = signif(as.numeric(params[[x]]),4))
}
}
}
}
#Update Volume ratios
updateVolumes <- function(session, tissue_volumes){
inputs <- c("Vlungc","Vartc","Vgutc","Vkidneyc","Vliverc",
"heart"="ms_vhrtc","gi"="ms_vgic",
"liver"="ms_vlivc","kidney"="ms_vkdnc",
"rpf"="ms_vrpfc","spf"="ms_vspfc","blood"="ms_vbldc",
"bw"="ms_bw")
tissue_volumes <- isolate(tissue_volumes)
volumes <- tissue_volumes
names(volumes)<- lapply(names(tissue_volumes),function(x){input_ids[x]})
for(elem in names(volumes)){
if(elem!="ms_bw"){
volumes[[elem]]<- volumes[[elem]]/(volumes[["ms_bw"]])
}
updateNumericInput(session, elem, value = signif(volumes[[elem]],4))
}
}
#Update tissues Blood flow ratio
updateRatios <- function(session, tissue_ratios){
tissue_ratios <- isolate(tissue_ratios)
input_ids <- c("fat"="ms_qfatc","skin"="ms_qskinc",
"muscle"="ms_qmuscc","bone"="ms_qbonec",
"brain"="ms_qbrnc","lung"="ms_qlngc",
"heart"="ms_qhrtc","gi"="ms_qgic",
"liver_art"="ms_qalivc","liver_ven"="ms_qvlivc",
"kidney"="ms_qkdnc","rpf"="ms_qrpfc","spf"="ms_qspfc",
"qc"="ms_qcc")
ratios <- tissue_ratios
names(ratios)<- lapply(names(tissue_ratios),function(x){input_ids[x]})
for(elem in names(ratios)){
if(elem!="ms_qcc"){
ratios[[elem]]<- ratios[[elem]]/ratios[["ms_qcc"]]
}
updateNumericInput(session, elem, value = signif(ratios[[elem]],4))
}
}
#Update tissue coefficient when Qsar is being used
updateCoeffs <- function(session, calculatedCoeff){
names(calculatedCoeff) <- paste("ms_", names(calculatedCoeff), sep = "")
for(elem in names(calculatedCoeff)){
updateNumericInput(session, elem, value = calculatedCoeff[[elem]])
}
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.