R [Shiny]：如何制作显示动态系统模型的响应式闪亮应用程序？答案

【问题标题】：R [Shiny]: How to make reactive shiny apps which display dynamic systems models?R [Shiny]：如何制作显示动态系统模型的响应式闪亮应用程序？
【发布时间】：2021-12-11 07:09:23
【问题描述】：

我想构建一个反应式 Rshiny 应用程序，它显示由 deSolve 包求解的动态模型的结果。

示例代码复制自 Jim Duggans System Dynamics Modeling with R。

这里是没有 R-Shiny 的代码，它是一个考虑资源消耗的经济模型：

library(deSolve)
library(ggplot2)
library(gridExtra)

##Values Specification for Model 
START <-0; FINISH<-200; STEP<-0.25
simtime <- seq(START, FINISH, by = STEP)
stocks <- c(sCapital=5, sResource=1000)
auxs <- c(aDesired.Growth = 0.07,
         aDepreciation  = 0.05,
         aCost.Per.Investment = 2,
         aFraction.Reinvested =0.12,
         aRevenue.Per.Unit =3.00)

x.Resource <- seq(0,1000, by=100)
y.Efficiency<- c(0,0.25,0.45,0.63,0.75,0.86,0.92, 0.96,0.98, 0.99,1.0)

func.Efficiency <- approxfun(x=x.Resource,
                             y=y.Efficiency,
                             method = "linear",
                             yleft = 0, yright = 1.0)

#The Model 
model <- function(time,stocks,auxs){
  with(as.list(c(stocks,auxs)),{
    aExtr.Efficiency <- func.Efficiency(sResource)
    
    fExtraction      <- aExtr.Efficiency*sCapital
    
    aTotal.Revenue   <- aRevenue.Per.Unit * fExtraction
    aCapital.Costs   <- sCapital *0.1
    aProfit          <- aTotal.Revenue - aCapital.Costs
    aCapital.Funds   <- aFraction.Reinvested * aProfit
    aMaximum.Investment <- aCapital.Funds/aCost.Per.Investment
    
    aDesired.Investment <- sCapital * aDesired.Growth
    
    fInvestment      <- min(aMaximum.Investment,
                            aDesired.Investment)
    fDepreciation    <- sCapital * aDepreciation
    
    dS_dt            <- fInvestment -fDepreciation
    dR_dt            <- -fExtraction
    
    return(list(c(dS_dt, dR_dt),
                DesiredInvestment=aDesired.Investment,
                MaximumInvestment=aMaximum.Investment,
                Investment=fInvestment,
                Depreciation=fDepreciation,
                Extraction=fExtraction))
  })
}

### Using the deSolve Package to solve the differential equation
o <- data.frame(ode(y=stocks, times=simtime, func = model,
                    parms = auxs, method = "euler"))

##different Plots

flow_plot <- ggplot(data = o, mapping = aes(time, Investment)) + theme_classic() +
              geom_line(data = o, mapping = aes(time, Investment), size = 1, color = "blue", linetype =2)+
              geom_line(data = o, mapping = aes(time, Depreciation), size = 1, color = "red",linetype =2)+
              geom_line(data = o, mapping = aes(time, Investment-Depreciation), size = 1, color = "black")

capital_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
                geom_line(data = o, mapping = aes(time, sCapital), size = 1, color = "blue", linetype =2)+
                geom_line(data = o, mapping = aes(time, Extraction), size = 1, color = "black")

ressource_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
                    geom_line(data = o, mapping = aes(time, sResource), size = 1, color = "black", linetype =1)

grid.arrange(flow_plot,capital_plot,ressource_plot, nrow = 3)

R-Shiny React 部分

现在我尝试将所有这些封装到一个非常基本的 R-Shiny 应用程序中，代码如下：

library(shiny)
library(deSolve)
library(ggplot2)
library(gridExtra)


ui <- fluidPage(
  sliderInput("iDesired.Growth", "Desired.Growth", min = 0, max = 0.15, step = 0.01, value = 0.07),
  sliderInput("iDepreciation", "Depreciation", min = 0, max = 0.15, step = 0.01, value = 0.07),
  
  plotOutput(outputId = "arrange")
  
)



server <- function(input, output, session) {
  
  
  START <-0; FINISH<-200; STEP<-0.25
  simtime <- seq(START, FINISH, by = STEP)
  stocks <- c(sCapital=5, sResource=1000)
  auxs <- list(aDesired.Growth = reactiveVal(input$iDesired.Growth),
              aDepreciation  = reactiveVal(input$iDepreciation),
              aCost.Per.Investment = 2,
              aFraction.Reinvested =0.12,
              aRevenue.Per.Unit =3.00)
    

  
  x.Resource <- seq(0,1000, by=100)
  y.Efficiency<- c(0,0.25,0.45,0.63,0.75,0.86,0.92, 0.96,0.98, 0.99,1.0)
  
  func.Efficiency <- approxfun(x=x.Resource,
                               y=y.Efficiency,
                               method = "linear",
                               yleft = 0, yright = 1.0)
  
  
  model <- function(time,stocks,auxs){
    with(as.list(c(stocks,auxs)),{
      aExtr.Efficiency <- func.Efficiency(sResource)
      
      fExtraction      <- aExtr.Efficiency*sCapital
      
      aTotal.Revenue   <- aRevenue.Per.Unit * fExtraction
      aCapital.Costs   <- sCapital *0.1
      aProfit          <- aTotal.Revenue - aCapital.Costs
      aCapital.Funds   <- aFraction.Reinvested * aProfit
      aMaximum.Investment <- aCapital.Funds/aCost.Per.Investment
      
      aDesired.Investment <- sCapital * aDesired.Growth
      
      fInvestment      <- min(aMaximum.Investment,
                              aDesired.Investment)
      fDepreciation    <- sCapital * aDepreciation
      
      dS_dt            <- fInvestment -fDepreciation
      dR_dt            <- -fExtraction
      
      return(list(c(dS_dt, dR_dt),
                  DesiredInvestment=aDesired.Investment,
                  MaximumInvestment=aMaximum.Investment,
                  Investment=fInvestment,
                  Depreciation=fDepreciation,
                  Extraction=fExtraction))
    })
  }
  
  o <- data.frame(ode(y=stocks, times=simtime, func = model,
                      parms = auxs, method = "euler"))
  
  
  flow_plot <- ggplot(data = o, mapping = aes(time, Investment)) + theme_classic() +
    geom_line(data = o, mapping = aes(time, Investment), size = 1, color = "blue", linetype =2)+
    geom_line(data = o, mapping = aes(time, Depreciation), size = 1, color = "red",linetype =2)+
    geom_line(data = o, mapping = aes(time, Investment-Depreciation), size = 1, color = "black")
  
  f <-   renderPlot({
          flow_plot <- ggplot(data = o, mapping = aes(time, Investment)) + theme_classic() +
            geom_line(data = o, mapping = aes(time, Investment), size = 1, color = "blue", linetype =2)+
            geom_line(data = o, mapping = aes(time, Depreciation), size = 1, color = "red",linetype =2)+
            geom_line(data = o, mapping = aes(time, Investment-Depreciation), size = 1, color = "black")
  })
  
  capital_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
    geom_line(data = o, mapping = aes(time, sCapital), size = 1, color = "blue", linetype =2)+
    geom_line(data = o, mapping = aes(time, Extraction), size = 1, color = "black")
  
  ressource_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
    geom_line(data = o, mapping = aes(time, sResource), size = 1, color = "black", linetype =1)
  
  output$arrange <- renderPlot({
    grid.arrange(flow_plot,capital_plot,ressource_plot, nrow = 3)
    })
}



shinyApp(ui, server)

现在我很确定问题出在 auxs 变量的类型上：

  auxs <- list(aDesired.Growth = reactiveVal(input$iDesired.Growth),
              aDepreciation  = reactiveVal(input$iDepreciation),
              aCost.Per.Investment = 2,
              aFraction.Reinvested =0.12,
              aRevenue.Per.Unit =3.00)

你知道我是否可以在不更改函数的情况下实现响应性：模型或我必须使哪些函数/变量具有响应性以及如何实现？

非常感谢。

【问题讨论】：

标签： r shiny desolve

【解决方案1】：

需要一些小的调整。试试这个

library(shiny)
library(deSolve)
library(ggplot2)
library(gridExtra)

ui <- fluidPage(
  sliderInput("iDesired.Growth", "Desired.Growth", min = 0, max = 0.15, step = 0.01, value = 0.07),
  sliderInput("iDepreciation", "Depreciation", min = 0, max = 0.15, step = 0.01, value = 0.07),
  
  plotOutput(outputId = "arrange")
)

server <- function(input, output, session) {
  
  growth <- reactiveVal(1)
  dep <- reactiveVal(1)
  
  START <-0; FINISH<-200; STEP<-0.25
  simtime <- seq(START, FINISH, by = STEP)
  stocks <- c(sCapital=5, sResource=1000)
  
  x.Resource <- seq(0,1000, by=100)
  y.Efficiency<- c(0,0.25,0.45,0.63,0.75,0.86,0.92, 0.96,0.98, 0.99,1.0)
  func.Efficiency <- approxfun(x=x.Resource,
                               y=y.Efficiency,
                               method = "linear",
                               yleft = 0, yright = 1.0)
  
  observe({
    
    model <- function(time,stocks,auxs){
      with(as.list(c(stocks,auxs)),{
        aExtr.Efficiency <- func.Efficiency(sResource)
        
        fExtraction      <- aExtr.Efficiency*sCapital
        
        aTotal.Revenue   <- aRevenue.Per.Unit * fExtraction
        aCapital.Costs   <- sCapital *0.1
        aProfit          <- aTotal.Revenue - aCapital.Costs
        aCapital.Funds   <- aFraction.Reinvested * aProfit
        aMaximum.Investment <- aCapital.Funds/aCost.Per.Investment
        
        aDesired.Investment <- sCapital * aDesired.Growth
        
        fInvestment      <- min(aMaximum.Investment,
                                aDesired.Investment)
        fDepreciation    <- sCapital * aDepreciation
        
        dS_dt            <- fInvestment -fDepreciation
        dR_dt            <- -fExtraction
        
        return(list(c(dS_dt, dR_dt),
                    DesiredInvestment=aDesired.Investment,
                    MaximumInvestment=aMaximum.Investment,
                    Investment=fInvestment,
                    Depreciation=fDepreciation,
                    Extraction=fExtraction))
      })
    }
    
    growth(input$iDesired.Growth)
    dep(input$iDepreciation)
    
    auxs <- list(aDesired.Growth = growth(),
                 aDepreciation  = dep(),
                 aCost.Per.Investment = 2,
                 aFraction.Reinvested =0.12,
                 aRevenue.Per.Unit =3.00)
    
    o <- data.frame(ode(y=stocks, times=simtime, func = model,
                        parms = auxs, method = "euler"))
    
    
    flow_plot <- ggplot(data = o, mapping = aes(time, Investment)) + theme_classic() +
      geom_line(data = o, mapping = aes(time, Investment), size = 1, color = "blue", linetype =2)+
      geom_line(data = o, mapping = aes(time, Depreciation), size = 1, color = "red",linetype =2)+
      geom_line(data = o, mapping = aes(time, Investment-Depreciation), size = 1, color = "black")
    
    f <-   renderPlot({
      flow_plot <- ggplot(data = o, mapping = aes(time, Investment)) + theme_classic() +
        geom_line(data = o, mapping = aes(time, Investment), size = 1, color = "blue", linetype =2)+
        geom_line(data = o, mapping = aes(time, Depreciation), size = 1, color = "red",linetype =2)+
        geom_line(data = o, mapping = aes(time, Investment-Depreciation), size = 1, color = "black")
    })
    
    capital_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
      geom_line(data = o, mapping = aes(time, sCapital), size = 1, color = "blue", linetype =2)+
      geom_line(data = o, mapping = aes(time, Extraction), size = 1, color = "black")
    
    ressource_plot <- ggplot(data = o, mapping = aes(time, sCapital)) + theme_classic() +
      geom_line(data = o, mapping = aes(time, sResource), size = 1, color = "black", linetype =1)
    
    output$arrange <- renderPlot({
      grid.arrange(flow_plot,capital_plot,ressource_plot, nrow = 3)
    })
  
  })
}

shinyApp(ui, server)

【讨论】：

【解决方案2】：

感谢@YBS 的回答，基于 OP 的广泛示例。这里还有一个不需要observe 函数的最小可重现示例。如果需要额外的功能，它可以很容易地扩展，包括reactive，如果需要还可以observe。好消息是，reactive 会缓存其结果，只要输入保持不变。

library("deSolve")
library("shiny")

brusselator <- function(t, y, p) {
  with(as.list(c(y, p)), {
    dX <- k1*A   - k2*B*X    + k3*X^2*Y - k4*X
    dY <- k2*B*X - k3*X^2*Y
    list(c(X=dX, Y=dY))
  })
}

server <- function(input, output) {
  output$brussels <- renderPlot({
    parms <- c(A=input$A, B=input$B, k1=1, k2=1, k3=1, k4=1)
    out <- ode(y = c(X=1, Y=1), times=seq(0, 100, .1), brusselator, parms)
    matplot.0D(out)
  })
}

ui <- fluidPage(
  numericInput("A", label = "A", value = 1),
  numericInput("B", label = "B", value = 3),
  plotOutput("brussels")
)

shinyApp(ui=ui, server=server)

更多带有 shiny 和 R 的动态模型示例可在过去用户的教程中找到！在布鲁塞尔here 和其他一些地方举行会议。

【讨论】：