model.txt
[LONGITUDINAL] input={ka,V,Cl,ke0,Imax,IC50,S0,kout} EQUATION: {Cc, Ce} = pkmodel(ka, V, Cl, ke0) Ec = Imax*Cc/(Cc+IC50) E1 = S0*(1 - Ec) Ee = Imax*Ce/(Ce+IC50) E2 = S0*(1 - Ee) E3_0 = S0 ddt_E3 = kout*((1-Ec)*S0- E3)
ui.R
library(shinydashboard) sidebar <- dashboardSidebar( hr(), sidebarMenu(id="tabs", menuItem("Plot", tabName = "plot", icon = icon("line-chart"), selected=TRUE), menuItem("Codes", icon = icon("file-text-o"), menuSubItem("Mlxtran", tabName = "mlxtran", icon = icon("angle-right")), menuSubItem("ui.R", tabName = "ui", icon = icon("angle-right")), menuSubItem("server.R", tabName = "server", icon = icon("angle-right")), menuSubItem("shinymlxTools.R", tabName = "tools", icon = icon("angle-right")) ) ), hr(), fluidRow( column(1), column(9, checkboxGroupInput("out1", label="plot 1", choices='Cc', selected='Cc'), selectInput("x1", label="v.s.",c('time','Cc','E1','E2','E3')), hr(), checkboxGroupInput("out2", label="plot 2", choices=c('E1','E2','E3'), selected=c('E1','E2','E3')), selectInput("x2", label="v.s.",c('time','Cc','E1','E2','E3')), hr(), strong("add"), checkboxInput("legend", label="legend", value=TRUE), fluidRow( column(5,checkboxInput("boxref", label="ref.")), column(4,actionButton("butref", label = "Reset")) ), hr(), radioButtons("ilog", "scale", c("linear" = FALSE,"log" = TRUE), inline=TRUE), br() ) ), hr() ) body <- dashboardBody( tabItems( tabItem(tabName = "plot", fluidRow( box(width = 3, status = "primary", tabsetPanel(type='tabs', tabPanel('param1',br(), sliderInput("ka", label="ka",value=0.5,min=0.25,max=1,step=0.05), sliderInput("V", label="V",value=10,min=5,max=20,step=1), sliderInput("Cl", label="Cl",value=1,min=0.5,max=2,step=0.1), br() ), tabPanel('param2',br(), sliderInput("ke0", label="ke0",value=0.1,min=0.05,max=0.2,step=0.01), sliderInput("Imax", label="Imax",value=0.5,min=0.25,max=1,step=0.05), sliderInput("IC50", label="IC50",value=0.03,min=0.015,max=0.06,step=0.003), sliderInput("S0", label="S0",value=100,min=50,max=200,step=10), sliderInput("kout", label="kout",value=0.1,min=0.05,max=0.2,step=0.01), br() ), tabPanel('adm',br(), sliderInput("tfd1", label="tfd",value=5,min=2.5,max=10,step=0.5), sliderInput("nd1", label="nd",value=15,min=7.5,max=30,step=1.5), sliderInput("ii1", label="ii",value=12,min=6,max=24,step=1.2), sliderInput("amount1", label="amount",value=1,min=0.5,max=2,step=0.1), br() ), br() ) ), box(width = 9, height=530, status = "primary", plotOutput("plot") ) ) ), tabItem(tabName = "mlxtran", box( width = NULL, status = "primary", solidHeader = TRUE, title="model.txt", pre(includeText("model.txt")) ) ), tabItem(tabName = "ui", box( width = NULL, status = "primary", solidHeader = TRUE, title="ui.R", pre(includeText("ui.R")) ) ), tabItem(tabName = "server", box( width = NULL, status = "primary", solidHeader = TRUE, title="server.R", pre(includeText("server.R")) ) ), tabItem(tabName = "tools", box( width = NULL, status = "primary", solidHeader = TRUE, title="server.R", pre(includeText("shinymlxTools.R")) ) ) # tabItem(tabName = "about", includeMarkdown("../../about/about.Rmd")) ) ) dashboardPage( dashboardHeader(title = "PKPD models"), sidebar, body )
server.R
#source("../../initMlxR.R") library("mlxR") library("reshape") library("gridExtra") source("shinymlxTools.R") out1 <- list(name='Cc', time=seq(0,250,by=1)) out2 <- list(name=c('E1','E2','E3'), time=seq(0,250,by=1)) f <- list(out1, out2) nf <- length(f) info <- info_res(f) server <- function(input, output) { ref <- reactive({ input$butref p <- list(name = c('ka', 'V', 'Cl', 'ke0', 'Imax', 'IC50', 'S0', 'kout'), value = isolate(c(input$ka, input$V, input$Cl, input$ke0, input$Imax, input$IC50, input$S0, input$kout))) t1 <- isolate(input$tfd1) t2 <- isolate(input$ii1)*(isolate(input$nd1)-1)+t1 t.dose <- seq(t1,t2,by=isolate(input$ii1)) adm <- list(time=t.dose, amount=isolate(input$amount1)) r <- simulx( model = 'model.txt', treatment = adm, parameter = p, output = f) ref <- merge_res(r,f) return(ref) }) res <- reactive({ p <- list(name = c('ka', 'V', 'Cl', 'ke0', 'Imax', 'IC50', 'S0', 'kout'), value = c(input$ka, input$V, input$Cl, input$ke0, input$Imax, input$IC50, input$S0, input$kout)) t1 <- input$tfd1 t2 <- input$ii1*(input$nd1-1)+t1 t.dose <- seq(t1,t2,by=input$ii1) adm <- list(time=t.dose, amount=input$amount1) r <- simulx( model = 'model.txt', treatment = adm, parameter = p, output = f) res <- merge_res(r,f) return(res) }) output$plot <- renderPlot({ res=res() ref=ref() gr.txt <- "grid.arrange(" for (j in (1:length(f))){ xj <- "time" fj <- f[[j]] name.fj <- fj$name eval(parse(text=paste0("inputyj=input$out",j))) i.plot=FALSE if (!is.null(inputyj)){ ij <- which(name.fj %in% inputyj) if (length(ij>0)){ eval(parse(text=paste0("inputxj=input$x",j))) if (!is.null(inputxj)) xj <- inputxj } i.plot=TRUE } else if (is.null(inputyj) & length(f)==1){ ij=1 i.plot=TRUE } if (i.plot){ pl <- ggplotmlx() nfj <- length(name.fj) for (k in (1:nfj)){ if (k %in% ij){ if (input$boxref==TRUE){ pj <- paste0('pl <- pl + geom_path(data=ref, aes(x=',xj,',y=',name.fj[k],'),colour="grey",size=0.75)') eval(parse(text=pj)) } pj <- paste0('pl <- pl + geom_path(data=res, aes(x=',xj,',y=',name.fj[k],',colour="',info[[j]]$colour[k],'"),size=0.75)') eval(parse(text=pj)) } } pl <- pl + scale_colour_manual(values=info[[j]]$values, labels=info[[j]]$labels) if (length(ij)>1){ if (!is.null(input$legend) && input$legend==FALSE) pl <- pl + theme(legend.position="none") else pl <- pl + guides(colour=guide_legend(title=NULL)) + theme(legend.position=c(.9, .8)) pl <- pl + ylab("") }else{ pl <- pl + theme(legend.position="none") } if (input$ilog==TRUE) pl=pl + scale_y_log10() eval(parse(text=paste0("pl",j," <- pl"))) gr.txt <- paste0(gr.txt,"pl",j,",") } } gr.txt <- paste0(gr.txt,"ncol=1)") eval(parse(text=gr.txt)) }, height = 500) }
server.R
gg_color_hue <- function(n) { hues = seq(15, 375, length=n+1) hcl(h=hues, l=65, c=100)[1:n]} info_res <- function(f){ if (!is.null(names(f))) f <- list(f) nf <- length(f) info <- list() for (k in (1:nf)){ fk <- f[[k]] nk <- length(fk$name) lk <- as.character(1:nk) valk <- gg_color_hue(nk) names(valk) <- lk labk <- fk$name names(labk) <- lk info[[k]] <- list(values=valk, labels=labk, colour=lk) } return(info) } merge_res <- function(r1,f){ r2 <- list() nf <- length(f) for (j in (1:nf)){ fj <- f[[j]] nj <- length(fj$name) r <- r1[[fj$name[1]]] if (nj>1){ for (k in (2:nj)){ rk <- r1[[fj$name[k]]] r <- merge(r,rk) } } r2[[j]] <- r } r3 <- r2[[1]] if (nf>1){ for (k in (2:nf)) r3 <- merge(r3,r2[[k]]) } return(r3) }