Вызов дополнительных функций в Shiny

Question

Я разработал простое блестящее приложение, которое принимает в качестве входов оценку my_x по распределению со средним my_mean и стандартным отклонением my_sd. В качестве вывода приложение возвращает график решетки с нормальным стандартным распределением с соответствующим z-scoremy_x. Код приложения можно найти по адресу GitHub.

Теперь я хотел бы добавить вторую функциональность приложения:

При проверке checkboxInput я бы вычислить, например, pnorm входов и тени относительной площади графика.

Я написал код для графика (здесь пример ожидаемого результата), но я не могу понять, как заставить его работать в Shiny. В частности, я не могу понять, как активировать функцию при правильной работе флажка с первой функцией, составляющей график.

library(lattice) 
e4a <- seq(60, 170, length = 10000) 
e4b <- dnorm(e4a, 110, 15) 
#z-score is calculated with the inputs listed above: 

z_score <- (my_x - my_mean)/my_sd 

plot_e4d <- xyplot(e4b ~ e4a, 
       type = "l", 
       main = "Plot 4", 
       scales = list(x = list(at = seq(60, 170, 10)), rot = 45), 
       panel = function(x,y, ...){ 
        panel.xyplot(x,y, ...) 
        panel.abline(v = c(z_score, 110), lty = 2) 

        xx <- c(60, x[x>=60 & x<=z_score], z_score) 
        yy <- c(0, y[x>=60 & x<=z_score], 0) 
        panel.polygon(xx,yy, ..., col='red') 
       }) 
print(plot_e4d) 

Answer 1

Я нашел решение функционирующий. Я уверен, что он не самый эффективный, но он работает. Он состоит из оператора if/else внутри функции сервера, вызывающей график. Я хотел бы поблагодарить @ zx8754 за вдохновение.

Вот ui.r файл:

library(shiny) 

shinyUI(pageWithSidebar(
headerPanel("Standard Normal"), 
sidebarPanel(
    numericInput('mean', 'Your mean', 0), 
    numericInput('sd', 'Your standard deviation', 0), 
    numericInput('x', 'Your score', 0), 
    checkboxInput('p1', label = 'Probability of getting a score smaller than x or z', value = FALSE) 
), 
mainPanel(
    h3('Standard Normal'), 
    plotOutput('sdNorm'), 
    h4('Your z-score is:'), 
    verbatimTextOutput('z'), 
    h4('Your lower tail probability is:'), 
    verbatimTextOutput('p1')  
    )) 

)

И файл server.R:

library(lattice) 

shinyServer(
function(input, output){ 
    output$sdNorm <- renderPlot({ 
     dt1 <- seq(-3, 3, length = 1000) 
     dt2 <- dnorm(dt1, 0, 1) 
     my_mean <- input$mean 
     my_sd <- input$sd 
     my_x <- input$x 
     z <- (my_x - my_mean)/my_sd 
     if(input$p1){ 

      xyplot(dt2 ~ dt1, 
        type = "l", 
        main = "Lower tail probability", 
        panel = function(x,y, ...){ 
         panel.xyplot(x,y, ...) 
         panel.abline(v = c(z, 0), lty = 2) 
         xx <- c(-3, x[x>=-3 & x<=z], z) 
         yy <- c(0, y[x>=-3 & x<=z], 0) 
         panel.polygon(xx,yy, ..., col='red') 
        }) 

     }else{ 
      xyplot(dt2 ~ dt1, 
        type = "l", 
        main = "Standard Normal Distribution", 
        panel = function(x, ...){ 
         panel.xyplot(x, ...) 
         panel.abline(v = c(z, 0), lty = 2) 
        }) 
     } 

     }) 
    output$z = renderPrint({ 
     my_mean <- input$mean 
     my_sd <- input$sd 
     my_x <- input$x 
     z <- (my_x - my_mean)/my_sd 
     z 
    }) 
    output$p1 <- renderPrint({ 
     if(input$p1){ 
      my_mean <- input$mean 
      my_sd <- input$sd 
      my_x <- input$x 
      p1 <- 1- pnorm(my_x, my_mean, my_sd) 
      p1 
     } else { 
      p1 <- NULL 
     } 

    }) 

} 

)

Answer 2

Это должно работать:

library(shiny) 
library(lattice) 

shinyApp(
    ui = { 
    pageWithSidebar(
     headerPanel("Standard Normal"), 
     sidebarPanel(
     numericInput('mean', 'Your mean', 80), 
     numericInput('sd', 'Your standard deviation', 2), 
     numericInput('x', 'Your score', 250), 
     checkboxInput("zScoreArea", label = "Area under z-score", value = TRUE) 
    ), 
     mainPanel(
     h3('Standard Normal'), 
     plotOutput('sdNorm'), 
     h4('Your z-score is:'), 
     verbatimTextOutput('z_score') 
    )) 
    }, 
    server = { 
    function(input, output){ 

     #data 
     dt1 <- seq(60, 170, length = 10000) 
     dt2 <- dnorm(dt1, 110, 15) 

     #xyplot panel= function() 
     myfunc <- reactive({ 
     if(input$zScoreArea){ 
      function(x,y, ...){ 
      panel.xyplot(x,y, ...) 
      panel.abline(v = c(z_score(), 110), lty = 2) 

      xx <- c(60, x[x >= 60 & x <= z_score()], z_score()) 
      yy <- c(0, y[x >= 60 & x <= z_score()], 0) 
      panel.polygon(xx,yy, ..., col='red') 
      } 
     }else{ 
      function(x, ...){ 
      panel.xyplot(x, ...) 
      panel.abline(v = c(z_score(), 110), lty = 2)} 

     } 
     }) 

     #reactive z_score for plotting 
     z_score <- reactive({ 
     my_mean <- input$mean 
     my_sd <- input$sd 
     my_x <- input$x 

     #return z score 
     (my_x - my_mean)/my_sd 
     }) 

     output$sdNorm <- renderPlot({ 
     xyplot(dt2 ~ dt1, 
       type = "l", 
       main = "Plot 4", 
       scales = list(x = list(at = seq(60, 170, 10)), rot = 45), 
       panel = myfunc() 
     ) 
     }) 

     output$z_score = renderPrint({ z_score() }) 
    } 
    } 
)