如何從用戶那里獲取輸入並將其用作 function r shiny 中的參數？

Question

我想在 r shiny 中使用 brms 構建貝葉斯 model。我的目標是從用戶那里獲取先驗的均值和標准差，以在 brm function 中作為參數使用。首先，我得到“c( prior(normal( 5, 5 ), coef= temperature ) )" by userınput 並將其發送到 brms:: brm function 作為參數。雖然沒有顯示任何錯誤，但我認為結果不正確，因為當我總結先驗時，我看不到任何先驗被創建。

ui.R：

library(shiny)
library(magrittr)
library(caret)
library(xlsx)
library(ggplot2)
library(ggcorrplot)
library(xlsx)
library(openxlsx)
library(brms)



ui <- fluidPage(
  
  titlePanel("Multiple Linear Regression"),
  
  sidebarLayout(
    
    sidebarPanel(
      
      
      radioButtons(inputId="format", label="Enter the format to load", 
                   choices = list(".csv/txt" = 1, ".xlsx" = 2),
                   selected = 1,
                   inline = TRUE ),     
      
      fileInput("file1","Load Data",accept = c(
        'text/csv',
        'text/comma-separated-values,text/plain',
        '.csv',
        '.xlsx'
      )),
      
      
      
      checkboxInput("header","Header",TRUE),
      radioButtons("sep","Seperator",choices = c(Comma=",", Semicolon=";",Tab="\t")),
      selectInput(inputId = "file2",
                  label = "Default DataSet",
                  choices = c("rock","pressure","cars","USArrests")),
      width=3
      
    ),
    
    
    mainPanel(
      
      tabsetPanel(
        
        tabPanel("Data",tabName="data",icon = icon("table"),
                 verbatimTextOutput(outputId = "data_out")),
        
        
        tabPanel(title="Structure",tabName="structure",icon=icon("atom"),
                 verbatimTextOutput("str_out")),
        
        tabPanel(title="Summary",tabName="summary",icon=icon("database"),
                 verbatimTextOutput("sum_out")),
        
        
        tabPanel("Histogram",tabName="histogram",icon = icon("database"),
                 br(), 
                 plotOutput("histogram"),
                 textOutput("hipotez0"),
                 textOutput("hipotez1"),
                 textOutput("shapiro"),
                 uiOutput("histo")),
        
        
        
        tabPanel("Outliers Detection",tabName="boxplot",icon = icon("atom"),
                 br(), 
                 plotOutput("BoxPlot"),
                 uiOutput("boxo")),
        
        tabPanel("ScatterPlot",tabName="scatterplot",icon=icon("first-order-alt"),
                 br(),
                 plotOutput("ScatterPlot"),
                 uiOutput("scatterx"),
                 uiOutput("scattery")),
        
        tabPanel("CorrelationMatrix",tabName="correlation",icon=icon("first-order-alt"),
                 h3("Correlation Matrix"),
                 plotOutput("CorrelationMatrix", width = "100%")),
        
        
        tabPanel("TimeSeriesDecomposition",tabName="decomposition",icon=icon("first-order-alt"),
                 plotOutput("tms"),
                 plotOutput("TimeSeriesDecomposition"),
                 uiOutput("deco")),
        
        
        
        tabPanel("Feature Selection",tabName="degisken",icon = icon("database"),
                 br(),
                 uiOutput("bagimli"),
                 br(),
                 uiOutput("bagimsiz")
                 
        ),
        
        
        tabPanel("Adding Prior",tabName="prior",icon = icon("database"),
                 br(),
                 uiOutput("prior"),
                 br(),
                 uiOutput("mean"),
                 br(),
                 uiOutput("std"),
                 tableOutput("Observe_Out_E"),
                 tableOutput("tr"),
                 actionButton("Go","Add Prior")
                 
                 # uiOutput("bagimsiz")
                 
        ),
        
        
        
        
        tabPanel("Regression Model Building ", tabName = "lr",icon = icon("atom"),
                 h3("Linear Regression"),
                 p("- Residuals :In regression analysis, the difference between the observed value of the dependent variable (y) and the predicted value (y) is called the residual (e). Each data point has one residual."),
                 p("- Coefficients : A regression coefficient describes the size and direction of the relationship between a predictor and the response variable. Coefficients are the numbers by which the values of the term are multiplied in a regression equation."),
                 p("- R squared: In statistics, the coefficient of determination, denoted R2 or r2 and pronounced R squared, is the proportion of the variance in the dependent variable that is predictable from the independent variable(s)."),
                 p("- p-value: The p-value for each term tests the null hypothesis that the coefficient is equal to zero (no effect). A low p-value (< 0.05) indicates that you can reject the null hypothesis. In other words, a predictor that has a low p-value is likely to be a meaningful addition to your model because changes in the predictor's value are related to changes in the response variable."),
                 
                 verbatimTextOutput("model")
        ),
        
        tabPanel("Bayesian Model", tabName = "by",icon = icon("atom"),
                 h3("Bayesian Regression"),
                 p("- In statistics, Bayesian linear regression is an approach to linear regression in which the statistical analysis is undertaken within the context of Bayesian inference.."),
                 p("-When the regression model has errors that have a normal distribution, and if a particular form of prior distribution is assumed, explicit results are available for the posterior probability distributions of the model's parameters.."),
                 verbatimTextOutput("model2")
        ),
        
        
        
        
        tabPanel("Train-Test", icon = icon("first-order-alt"),
                 br(),
                 h3("Validation"),
                 p("- The sample of data used to fit the model.",col = "Red"),
                 p("- Test data is used to provide an unbiased evaluation of a final model. It is not seen by your model at all. Test data should be your real-life data."),
                 uiOutput("obs"),
                 verbatimTextOutput("new_model")),
        
        tabPanel("Predictions",icon = icon("poll"),
                 plotOutput("predictions"),
                 tableOutput("tahmin_out"),
                 verbatimTextOutput("mse"),
                 downloadButton('download',"Save")
                 
        )
      )
    )
  )
)
   
    

服務器.R：

server <- function(input, output, session) {
  
  rv<-reactiveValues()
  
  data<-reactive({
    
    infile<-input$file1
    
    if (is.null(infile))
      
      return(switch(input$file2,
                    "rock" = rock,
                    "pressure" = pressure,
                    "cars" = cars,
                    "USArrests" = USArrests))
    
    if (input$format=="1") {
      
      read.csv(input$file1$datapath,header = input$header, sep=input$sep,quote=input$quote)
      
    } else {
      
      read.xlsx(input$file1$datapath, 1)
      
      
    }
    
    
    
  })
  
  
  output$data_out<-renderPrint({
    data()
  })
  
  output$str_out<-renderPrint({
    str(data())
  })
  output$sum_out<-renderPrint({
    summary(data())
  })
  
  
  observe({rv$Train<-data()})
  
  output$bagimli<-renderUI({
    
    selectInput("bagimli", h4("Choose Dependent Variable"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
    
    
  })
  
  
  
  output$prior<-renderUI({
    
    selectInput("prior", h4("Choose Variable"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
    
    
  })
  
  output$mean<-renderUI({
    
    textInput("mean",h4("Mean"))
    
    
  })
  
  output$std<-renderUI({
    
    textInput("std",h4("Standard Deviation"))
    
    
  })
  
  
  #We can change any input as much as we want, but the code wont run until the trigger
  #input$Go is pressed.
  val<-reactiveValues()
  val$txt<-""
  observeEvent(input$Go, {
    A<-input$prior
    B<-input$mean
    C<-input$std
    new<-paste(B,",",C,")",",coef=",A)
    val$txt<-paste( val$txt,"prior(normal(",new,"),",sep='\n')
    val$txt2<-paste("c(",val$txt,")")
    val$txt3<-paste(substring(val$txt2,1,nchar(val$txt2)-3),")")
    #val$txt3<-gsub(" ", "", val$txt3)
    #val
    #df<-c(A,B,C)
    output$Observe_Out_E<-renderTable({val$txt3})
  })
  

  
  # #We can change any input as much as we want, but the code wont run until the trigger
  # # input$Go is pressed.
  # val<-reactiveValues()
  # 
  # 
  # observeEvent(input$Go, {
  #   A<-input$prior
  #   B<-input$mean
  #   C<-input$std
  #   val = list(prior = brms::prior_string(paste0("normal(", B, ",",C,")"), coef=A))
  #   output$Observe_Out_E<-renderTable({val})
  #   
  # })
  
  
  
  output$bagimsiz<-renderUI({
    
    checkboxGroupInput("bagimsiz", h4("Choose Independent Variable"),
                       choices = names(rv$Train[]),
                       selected = names(rv$Train[]),inline=TRUE)
  })
  
  
  output$histo<-renderUI({
    
    selectInput("histo", h4("Select Variable for Histogram"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
    
    
  })
  
  data1 <- reactive({
    input$histo
  })
  
  output$histogram<-renderPlot({
    #histo<-input$histo
    #req(data1)
    hist(rv$Train[[data1()]],
         xlab = colnames(rv$Train[data1()]),
         col = "blue",
         main=paste("Histogram of",input$histo))
    # ggplot(rv$Train,aes(x=rv$Train[[data1()]]))+geom_histogram(bins = 5,col="black",fill='#F79420')+ggtitle("Histogram") + xlab(colnames(rv$Train[data1()]))
  })
  
  output$boxo<-renderUI({
    
    selectInput("boxo", h4("Select Variable for Boxplot"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
    
    
  })
  
  data2<-reactive({
    input$boxo
  })
  
  output$BoxPlot<-renderPlot({
    boxplot(rv$Train[[data2()]],
            main=paste("Boxplot of ",input$boxo),
            col = "pink",
            xlab=colnames(rv$Train[data2()]))
    #ggplot(rv$Train, aes(y=rv$Train[[data2()]]))+geom_boxplot()
    
  })
  
  output$scatterx<-renderUI({
    selectInput("scatterx",h4("Select X Variable"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
  })
  
  output$scattery<-renderUI({
    selectInput("scattery",h4("Select Y Variable"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
  })
  
  data3<-reactive({
    input$scatterx
  })
  
  data4<-reactive({
    input$scattery
  })
  
  output$ScatterPlot<-renderPlot({
    #plot(rv$Train[[data3()]],rv$Train[[data4()]],xlab=colnames(rv$Train[data3()]),col="#69b3a2",main="Scatterplot",ylab=colnames(rv$Train[data4()]))
    #abline(lm( rv$Train[[data4()]]~ rv$Train[[data3()]]))
    ggplot(rv$Train, aes(x=rv$Train[[data3()]],y=rv$Train[[data4()]]))+  
      geom_point(colour="black",size=3)+
      labs(title = paste("ScatterPlot",input$scatterx,"vs",input$scattery),x=colnames(rv$Train[data3()]),y=colnames(rv$Train[data4()]))+
      geom_smooth(method='lm')+
      theme(
        plot.title = element_text(color = "black", size=16, face="bold",hjust = 0.5)
      )
  })
  
  
  
  output$CorrelationMatrix<-renderPlot({
    corr<-round(cor(rv$Train[]), 2)
    ggcorrplot(corr,hc.order = TRUE,
               lab = TRUE,
               outline.color = "white",
               type = "lower")
  }, height = 700, width = 800)
  
  output$deco<-renderUI({
    
    selectInput("deco", h4("Select Variable for TimeSeries"),
                choices = names(rv$Train[]),
                selected = names(rv$Train[]))
    
    
  })
  
  data5<-reactive({
    input$deco
  })
  
  output$TimeSeriesDecomposition <- renderPlot({
    ds_ts <- ts(rv$Train[[data5()]], frequency=12)
    f <- decompose(ds_ts)
    plot(f)
  })
  
  output$tms<-renderPlot({
    ggplot(rv$Train,aes(x=as.numeric(seq(1:nrow(data()))),y=rv$Train[[data5()]]))+
      geom_line()+
      labs(title = paste("Time Series Plot of",input$deco),x="Time",y=colnames(rv$Train[data5()]))+
      theme(
        plot.title = element_text(color = "black", size=16, face="bold",hjust = 0.5)
      )
    
    
  })
  
  output$hipotez0<-renderText({
    
    paste("Normally Distributed")
    
  })
  
  output$hipotez1<-renderText({
    
    paste("Not Normally Distributed")
    
  })
  
  output$shapiro<-renderPrint({
    
    shapiro.test(rv$Train[[data1()]])
    
  })
  ?shapiro.test
  output$model<-renderPrint({
    input$bagimli
    input$bagimsiz
    veri<-data()
    
    
    form <- as.formula(paste(names(data())[names(data()) %in% input$bagimli], "~",
                             paste(names(data())[names(data()) %in% input$bagimsiz], collapse="+")))
    
    model <- lm(as.formula(form),data=veri)
    print(summary(model))
    
  })
  ##bayesian model
  output$model2<-renderPrint({
    input$bagimli
    input$bagimsiz
    veri<-data()
  
    
  
    
    
    
    
    form <- as.formula(paste(names(data())[names(data()) %in% input$bagimli], "~",
                             paste(names(data())[names(data()) %in% input$bagimsiz], collapse="+")))
    
    model2 <- brms::brm(as.formula(form),prior=val$txt3,warmup=1000,iter=5000,chains=2,core=4,data=veri)
    print(summary(model2))
    print(prior_summary(model2))
    
  })
  
  
  
  
  
  output$obs = renderUI({
    sliderInput('obs', label = "Split Data",min = 0, max = 1, value = 0.8,width = 400)
  })
  
  t_i<- reactive({
    createDataPartition(y = rv$Train[,input$bagimli], p = input$obs, list=F, times=1)
  })
  
  egt <- reactive({
    rv$Train[t_i(),]
  })
  
  test <- reactive({
    rv$Train[-t_i(),]
  })
  
  egt_x<- reactive({
    bagimli <- input$bagimli
    bagimsiz<- input$bagimsiz
    egt() %>% dplyr::select(-bagimli) %>% dplyr::select(bagimsiz)
  })
  
  egt_y<- reactive({
    bagimli <- input$bagimli
    egt() %>% dplyr::select(bagimli)
  })
  
  test_x<- reactive({
    bagimli <- input$bagimli
    bagimsiz<- input$bagimsiz
    test() %>% dplyr::select(-bagimli) %>% dplyr::select(bagimsiz)
  })
  
  test_y<- reactive({
    bagimli <- input$bagimli
    test() %>% dplyr::select(bagimli)
  })
  
  egt_tum<- reactive({
    data.frame(egt_x(), dv = egt_y())
  })
  
  new_formul<- reactive({
    as.formula(paste(input$bagimli, paste(input$bagimsiz, collapse=" + "), sep=" ~ "))
  })
  
  output$new_model <- renderPrint({
    
    veri <- egt_tum()
    egitim_x <- egt_x()
    egitim_y <- egt_y()
    
    form1 <- as.formula(paste(names(egt_y())[names(egt_y()) %in% input$bagimli], "~", 
                              paste(names(egt_x())[names(egt_x()) %in% input$bagimsiz],
                                    collapse="+")))
    
    model1 <- lm(as.formula(form1),data=veri)
    summary(model1)
    
  })
  
  new_model_rea <- reactive({
    
    veri <- egt_tum()
    egitim_x <- egt_x()
    egitim_y <- egt_y()
    
    form1 <- as.formula(paste(names(egt_y())[names(egt_y()) %in% input$bagimli], "~", 
                              paste(names(egt_x())[names(egt_x()) %in% input$bagimsiz],
                                    collapse="+")))
    
    model1 <- lm(as.formula(form1),data=veri)
    
  })
  
  pred <- reactive({
    round(predict(new_model_rea(), test_x()),digits = 3)
  })
  
  output$predictions<-renderPlot({
    ggplot(data = as.data.frame(input$tahmin), aes(x = as.numeric(seq(1:nrow(test_y()))))) + 
      geom_line(aes(y = round(as.numeric(unlist(test_y())), digits = 3), color = "darkred")) + 
      geom_line(aes(y = as.double(unlist(pred())), color="steelblue")) +
      scale_color_discrete(name = "Values", labels = c("Actual", "Fitted"))+
      xlab('Index') +
      ylab('Values')+
      ggtitle("Actual VS Predicted")
  })
  
  output$tahmin_out <- renderTable({
    data.frame( "Index" = seq(1:nrow(test_y())),
                "Actual" =test_y(),
                "Fitted" =pred())
  })
  
  tahmin <- reactive({
    pred <- as.double(unlist(pred()))
    test_y <- round(as.numeric(unlist(test_y())), digits = 3)
    
    data.frame( "Index" = seq(1:nrow(test_y())),
                "Actual" = test_y,
                "Fitted" = pred)
  })
  
  output$mse <- renderPrint({
    pred <- as.numeric(unlist(pred()))
    test_y <- round(as.numeric(unlist(test_y())), digits = 3)
    defaultSummary(data.frame(obs = test_y,
                              pred = as.vector(pred()))
    )
  })
  
  output$dto <- renderDataTable({tahmin()})
  output$download <- downloadHandler(
    filename = function(){"predicted.csv"}, 
    content = function(fname){
      write.csv(tahmin(), fname)
    }
  )
  
}

shinyApp(ui, server)
   

您可以看到我的 ui 獲取先驗和貝葉斯回歸的 output 看起來如何

我在這里遺漏或誤解了什么？ 如何解決這種情況？

請幫忙！

謝謝

編輯：你可以在這里看到 output of val$prior

Answer 1

也許你可以在你的observeEvent()中創建這樣的東西

prior = brms::prior_string(paste0("normal(", B, ",",C,")"), coef=A)

然后，您可以在調用brms::brms()時執行此操作

...prior = val$prior

明確地，如果我們定義了A 、 B和C ，如下所示：

A = "temperature"
B = 4
C = 4

然后，觀察

val = list(prior = brms::prior_string(paste0("normal(", B, ",",C,")"), coef=A))

是一個列表，其中一個元素稱為prior ，該元素的 class 是“brmsprior”