小贝子编程

在R Shiny中，我如何使用操作按钮来更改主面板中的输出



下面的MWE代码基本上按预期工作(为了便于演示，有些小错误并不重要；这些错误是在精简代码时出现的(。当用户输入左侧面板时，主面板中的绘图输出会反应性地(立即(反映这些输入。到目前为止我想要什么。

注意在主面板顶部的2个动作按钮：；矢量图"；以及"；矢量值"；(分别为id="showVectorPlotBtn"one_answers"showVector ValueBtn"(。如何调整代码以反映以下功能？(a( 当用户点击"；矢量值"；，将该图替换为具有相同值的数据表——该数据表将具有与该图相同的反应性；(b( 当用户点击"时；矢量图"；同时观看"；矢量值"；，在不重置值的情况下恢复绘图-最后输入的值保留在绘图中；以及(c(当首次调用应用程序时，主面板始终默认为当前的绘图。

如何做到这一点？我已经摆弄了一段时间，陷入了困境。

这是MWE代码：

library(shiny)
library(shinyMatrix)
library(shinyjs)
matrix1.input <- function(x){
matrixInput(x, 
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE,  names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2.input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE,  names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}  
matrix.validate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x 
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)  
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vector.base <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vector.multi <- function(x,y,z){                                            
a <- rep(NA, x)
a[y] <- z                                       
a[seq_len(min(y)-1)] <- a[min(y)]               
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}     
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y    
b <- seq(1:x)                                                       
c <- data.frame(x = b, z = a)                                       
return(c)}
vector.multiFinal <- function(x,y){vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}
button  <- function(x,y){actionButton(x,y,)}
matrix.link <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}
ui <- 
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Dynamic", value=2,
helpText("Select output:"),
actionButton('showVectorPlotBtn','Vector plots',style="width:90px;font-size:80%"),
actionButton('showVectorValueBtn','Vector values',style="width:90px;font-size:80%"),
plotOutput("graph1")),
tabPanel("Data", value=3, 
conditionalPanel(condition="input.choice==2"),
conditionalPanel(condition="input.choice==3")),
tabPanel("Plot", value=4, plotOutput("plot")), 
id = "tabselected")
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods              <-  reactive(input$periods)
base_input           <-  reactive(input$base_input)
vector_input         <-  reactive(input$vector_input)

output$Panels <- renderUI({
tagList( 
conditionalPanel(
condition="input.tabselected==2",
numericInput('begin.bal','',value=100000,step=1000,width = '100%'),
sliderInput('periods','',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showVectorBtn','Show',style="width:8vw;margin-bottom:10px"), 
actionButton('hideVectorBtn','Hide',style="width:8vw;margin-bottom:10px"),
actionButton('resetVectorBtn','Reset',style="width:8vw;margin-bottom:10px"),
hidden(uiOutput("Vectors"))),
conditionalPanel(
condition="input.tabselected==3"),
conditionalPanel(
condition="input.tabselected==4")
) # close tagList
}) # close renderUI

renderUI({matrix.link("vector_input",input$base_input[1,1])})

output$Vectors <- renderUI({
input$resetVectorBtn
tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]))
}) # close render UI

observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

output$graph1 <- renderPlot(
plot(if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))))
}) # close server
shinyApp(ui, server)

我不确定你想做什么。不过，你的操作按钮现在应该可以工作了。请根据您的用例进行调整。

ui <- 
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Dynamic", value=2,
helpText("Select output:"),
actionButton('showVectorPlotBtn','Vector plots',style="width:90px;font-size:80%"),
actionButton('showVectorValueBtn','Vector values',style="width:90px;font-size:80%"),
#plotOutput("graph1")
uiOutput("graphrtable")
),
tabPanel("Data", value=3, 
conditionalPanel(condition="input.choice==2"),
conditionalPanel(condition="input.choice==3")),
tabPanel("Plot", value=4, plotOutput("plot")), 
id = "tabselected")
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods              <-  reactive(input$periods)
base_input           <-  reactive(input$base_input)
vector_input         <-  reactive(input$vector_input)
rv <- reactiveValues()

output$Panels <- renderUI({
tagList( 
conditionalPanel(
condition="input.tabselected==2",
numericInput('begin.bal','',value=100000,step=1000,width = '100%'),
sliderInput('periods','',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showVectorBtn','Show',style="width:8vw;margin-bottom:10px"), 
actionButton('hideVectorBtn','Hide',style="width:8vw;margin-bottom:10px"),
actionButton('resetVectorBtn','Reset',style="width:8vw;margin-bottom:10px"),
hidden(uiOutput("Vectors"))),
conditionalPanel(
condition="input.tabselected==3"),
conditionalPanel(
condition="input.tabselected==4")
) # close tagList
}) # close renderUI

renderUI({matrix.link("vector_input",input$base_input[1,1])})

output$Vectors <- renderUI({
input$resetVectorBtn
tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]))
}) # close render UI

observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

# output$graph1 <- renderPlot(
#   plot(if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
#        else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))))

output$graph1 <- renderPlot({
plot(vector.base(periods(),input$base_input[1,1]))
#plot(cars) ## replace this with your plot
})

output$table1 <- renderDT({
#vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))
datatable(cars) ## replace this with your table
})

observeEvent(input$showVectorPlotBtn, {
rv$showme <- plotOutput("graph1")
}, ignoreNULL = FALSE)

observeEvent(input$showVectorValueBtn, {
rv$showme <- DTOutput("table1")
})

output$graphrtable <- renderUI({
rv$showme
})


}) # close server
shinyApp(ui, server)

根据YBS的建议，以下是完整的已解决MWE代码：

library(shiny)
library(shinyMatrix)
library(shinyjs)
library(DT)
matrix1.input <- function(x){
matrixInput(x, 
value = matrix(c(0.2), 4, 1, dimnames = list(c("A","B","C","D"),NULL)),
rows = list(extend = FALSE,  names = TRUE),
cols = list(extend = FALSE, names = FALSE, editableNames = FALSE),
class = "numeric")}
matrix2.input <- function(x,y,z){
matrixInput(x,
value = matrix(c(y,z),1,2,dimnames=list(NULL,c("Y","Z"))),
rows = list(extend = TRUE,  names = FALSE),
cols = list(extend = FALSE, names = TRUE, editableNames = FALSE),
class = "numeric")}  
matrix.validate <- function(x,y){
a <- y
a[,1][a[,1]>x] <- x 
b <- diff(a[,1,drop=FALSE])
b[b<=0] <- NA
b <- c(1,b)  
a <- cbind(a,b)
a <- na.omit(a)
a <- a[,-c(3),drop=FALSE]
return(a)}
vector.base <- function(x,y){
a <- rep(y,x)
b <- seq(1:x)
c <- data.frame(x = b, y = a)
return(c)}
vector.multi <- function(x,y,z){                                            
a <- rep(NA, x)
a[y] <- z                                       
a[seq_len(min(y)-1)] <- a[min(y)]               
if(max(y) < x){a[seq(max(y)+1, x, 1)] <- 0}     
a <- approx(seq_along(a)[!is.na(a)],a[!is.na(a)],seq_along(a))$y    
b <- seq(1:x)                                                       
c <- data.frame(x = b, z = a)                                       
return(c)}
vector.multiFinal <- function(x,y){vector.multi(x,matrix.validate(x,y)[,1],matrix.validate(x,y)[,2])}
button  <- function(x,y){actionButton(x,y,)}
matrix.link <- function(x,y){
observeEvent(input$periods|input$base_input,{
updateMatrixInput(session,x,value=matrix(c(input$periods,y),1,2,dimnames=list(NULL, c("y","z"))))})}

ui <- 
pageWithSidebar(
headerPanel("Model"),
sidebarPanel(uiOutput("Panels")),
mainPanel(
tabsetPanel(
tabPanel("Dynamic", value=2,
helpText("Select output:"),
actionButton('showVectorPlotBtn','Vector plots',style="width:90px;font-size:80%"),
actionButton('showVectorValueBtn','Vector values',style="width:90px;font-size:80%"),
uiOutput("vectorTable")
),
tabPanel("Data", value=3, 
conditionalPanel(condition="input.choice==2"),
conditionalPanel(condition="input.choice==3")),
tabPanel("Plot", value=4, plotOutput("plot")), 
id = "tabselected")
) # close main panel
) # close page with sidebar
server <- function(input,output,session)({
periods              <-  reactive(input$periods)
base_input           <-  reactive(input$base_input)
vector_input         <-  reactive(input$vector_input)
rv                   <-  reactiveValues()

output$Panels <- renderUI({
tagList( 
conditionalPanel(
condition="input.tabselected==2",
numericInput('begin.bal','',value=100000,step=1000,width = '100%'),
sliderInput('periods','',min=1,max=120,value=60),
matrix1.input("base_input"),
useShinyjs(),
actionButton('showVectorBtn','Show',style="width:8vw;margin-bottom:10px"), 
actionButton('hideVectorBtn','Hide',style="width:8vw;margin-bottom:10px"),
actionButton('resetVectorBtn','Reset',style="width:8vw;margin-bottom:10px"),
hidden(uiOutput("Vectors"))),
conditionalPanel(
condition="input.tabselected==3"),
conditionalPanel(
condition="input.tabselected==4")
) # close tagList
}) # close renderUI

renderUI({matrix.link("vector_input",input$base_input[1,1])})

output$Vectors <- renderUI({
input$resetVectorBtn
tagList(matrix2.input("vector_input",input$periods,input$base_input[1,1]))
}) # close render UI

observeEvent(input$showVectorBtn,{shinyjs::show("Vectors")})
observeEvent(input$hideVectorBtn,{shinyjs::hide("Vectors")})

output$graph1 <- renderPlot(
plot(if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))))

output$table1 <- renderDT({
if(input$showVectorBtn == 0) vector.base(periods(),input$base_input[1,1])
else vector.multiFinal(periods(),matrix.validate(periods(),vector_input()))
})

observeEvent(input$showVectorPlotBtn,{rv$showme <- plotOutput("graph1")},ignoreNULL = FALSE)
observeEvent(input$showVectorValueBtn,{rv$showme <- DTOutput("table1")})
output$vectorTable <- renderUI({rv$showme})
}) # close server
shinyApp(ui, server)

相关内容

最新更新


热门标签：

javascript python java c# php android html jquery c++ css ios sql mysql arrays asp.net json python-3.x ruby-on-rails .net sql-server django objective-c excel regex ruby linux ajax iphone xml vba spring asp.net-mvc database wordpress string postgresql wpf windows xcode bash git oracle list vb.net multithreading eclipse algorithm macos powershell visual-studio image forms numpy scala function api selenium