根据数据表行选择更新小部件值
Update widget values based on datatable row selection
我有下面这个闪亮的应用程序，我可以在其中添加带有小部件值的行或 select 行并删除它。此外，如果我单击一行并更改小部件值并按 Edit，则相对单元格值正在更改。
我想添加的是，当我单击一行时，所有小部件值将被相对 selected 行值替换。
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)
Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
16070,
17084, 17084
), class = "Date"), `Sale Date` = structure(c(
18627,
NA, 18545
), class = "Date"), `Amount Invested` = c(
10000,
8000, 10000
)), class = c(
"spec_tbl_df", "tbl_df", "tbl",
"data.frame"
), row.names = c(NA, -3L))
shinyApp(
ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
sidebar = dashboardSidebar(
minified = F, collapsed = F,
textInput(
"sectype", "Security Type",
"Stock")
,
textInput(
"sectick", "Ticker",
"XOM")
,
dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
numericInput(
"aminv", "Amount Invested",
10000)
,
actionButton("add", "Add"),
actionButton("edit", "Edit"),
actionButton("deleteRows", "Delete Rows")
),
body = dashboardBody(
h3("Results"),
tabsetPanel(
id = "tabs",
tabPanel(
"InsiderTraining",
dataTableOutput("TBL1")
)
)
),
controlbar = dashboardControlbar(width = 300),
title = "DashboardPage"
)), ###### SERVER
server = function(input, output) {
# Init with some example data
#data <- reactiveVal(Input)
rv <- reactiveValues(df = Input, row_selected = NULL)
observeEvent(
input$add,
{
# start with current data
rv$df <- rv$df %>%
add_row(
`Security Type` = isolate(input$sectype),
Ticker = isolate(input$sectick),
`Purchase Date` = isolate(input$PurDate),
`Sale Date` = isolate(input$selDate),
`Amount Invested` = isolate(input$aminv)
)# %>%
# update data value
#data()
}
)
observeEvent(input$deleteRows,{
if (!is.null(input$TBL1_rows_selected)) {
#data(data()[-as.numeric(input$TBL1_rows_selected),])
rv$df <- rv$df[-as.numeric(input$TBL1_rows_selected), ]
}
})
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
output$TBL1 <- renderDataTable(
rv$df,selection="single"
)
}
)
我们可以添加一个观察器，每次选择一行（在本例中一次只选择一个），然后小部件将更新为该行中包含的值。
由于所有小部件只显示一个值，我们可以使用 exec 并像这样遍历所有小部件：
请注意，缺少值（如第二行中的值）会使小部件为空。
##### UPDATE WIDGETS WITH SELECTED ROW ######
widgts_nms <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
update_funs <- c('updateTextInput', 'updateTextInput', 'updateDateInput', 'updateDateInput', 'updateNumericInput')
#This will happen automatically on row click.
observe({
req(input$TBL1_rows_selected)
vals <- rv$df[input$TBL1_rows_selected, ]
pwalk(list(update_funs, widgts_nms, vals), ~ exec(..1, !!!list(inputId = ..2, value = ..3[1]),.env = ))
})
应用代码：
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)
library(fontawesome)
library(tidyverse)
Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
16070,
17084, 17084
), class = "Date"), `Sale Date` = structure(c(
18627,
NA, 18545
), class = "Date"), `Amount Invested` = c(
10000,
8000, 10000
)), class = c(
"spec_tbl_df", "tbl_df", "tbl",
"data.frame"
), row.names = c(NA, -3L))
shinyApp(
ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
sidebar = dashboardSidebar(
minified = F, collapsed = F,
textInput(
"sectype", "Security Type",
"Stock")
,
textInput(
"sectick", "Ticker",
"XOM")
,
dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
numericInput(
"aminv", "Amount Invested",
10000)
,
actionButton("add", "Add"),
actionButton("edit", "Edit"),
actionButton("deleteRows", "Delete Rows")
),
body = dashboardBody(
h3("Results"),
tabsetPanel(
id = "tabs",
tabPanel(
"InsiderTraining",
dataTableOutput("TBL1")
)
)
),
controlbar = dashboardControlbar(width = 300),
title = "DashboardPage"
)), ###### SERVER
server = function(input, output, session) {
rv <- reactiveValues(df = Input, row_selected = NULL)
observeEvent(
input$add,
{
rv$df <- rv$df %>%
add_row(
`Security Type` = isolate(input$sectype),
Ticker = isolate(input$sectick),
`Purchase Date` = isolate(input$PurDate),
`Sale Date` = isolate(input$selDate),
`Amount Invested` = isolate(input$aminv)
)
}
)
observeEvent(input$deleteRows,{
if (!is.null(input$TBL1_rows_selected)) {
rv$df <- rv$df[-as.numeric(input$TBL1_rows_selected), ]
}
})
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
##### UPDATE WIDGETS WITH SELECTED ROW ######
widgts_nms <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
update_funs <- c('updateTextInput', 'updateTextInput', 'updateDateInput', 'updateDateInput', 'updateNumericInput')
#This will happen automatically on row click.
observe({
req(input$TBL1_rows_selected)
vals <- rv$df[input$TBL1_rows_selected, ]
pwalk(list(update_funs, widgts_nms, vals), ~ exec(..1, !!!list(inputId = ..2, value = ..3[1]),.env = ))
})
output$TBL1 <- renderDataTable(
rv$df,selection = "single"
)
}
)
我有下面这个闪亮的应用程序，我可以在其中添加带有小部件值的行或 select 行并删除它。此外，如果我单击一行并更改小部件值并按 Edit，则相对单元格值正在更改。
我想添加的是，当我单击一行时，所有小部件值将被相对 selected 行值替换。
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)
Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
16070,
17084, 17084
), class = "Date"), `Sale Date` = structure(c(
18627,
NA, 18545
), class = "Date"), `Amount Invested` = c(
10000,
8000, 10000
)), class = c(
"spec_tbl_df", "tbl_df", "tbl",
"data.frame"
), row.names = c(NA, -3L))
shinyApp(
ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
sidebar = dashboardSidebar(
minified = F, collapsed = F,
textInput(
"sectype", "Security Type",
"Stock")
,
textInput(
"sectick", "Ticker",
"XOM")
,
dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
numericInput(
"aminv", "Amount Invested",
10000)
,
actionButton("add", "Add"),
actionButton("edit", "Edit"),
actionButton("deleteRows", "Delete Rows")
),
body = dashboardBody(
h3("Results"),
tabsetPanel(
id = "tabs",
tabPanel(
"InsiderTraining",
dataTableOutput("TBL1")
)
)
),
controlbar = dashboardControlbar(width = 300),
title = "DashboardPage"
)), ###### SERVER
server = function(input, output) {
# Init with some example data
#data <- reactiveVal(Input)
rv <- reactiveValues(df = Input, row_selected = NULL)
observeEvent(
input$add,
{
# start with current data
rv$df <- rv$df %>%
add_row(
`Security Type` = isolate(input$sectype),
Ticker = isolate(input$sectick),
`Purchase Date` = isolate(input$PurDate),
`Sale Date` = isolate(input$selDate),
`Amount Invested` = isolate(input$aminv)
)# %>%
# update data value
#data()
}
)
observeEvent(input$deleteRows,{
if (!is.null(input$TBL1_rows_selected)) {
#data(data()[-as.numeric(input$TBL1_rows_selected),])
rv$df <- rv$df[-as.numeric(input$TBL1_rows_selected), ]
}
})
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
output$TBL1 <- renderDataTable(
rv$df,selection="single"
)
}
)
我们可以添加一个观察器，每次选择一行（在本例中一次只选择一个），然后小部件将更新为该行中包含的值。
由于所有小部件只显示一个值，我们可以使用 exec 并像这样遍历所有小部件：
请注意，缺少值（如第二行中的值）会使小部件为空。
##### UPDATE WIDGETS WITH SELECTED ROW ######
widgts_nms <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
update_funs <- c('updateTextInput', 'updateTextInput', 'updateDateInput', 'updateDateInput', 'updateNumericInput')
#This will happen automatically on row click.
observe({
req(input$TBL1_rows_selected)
vals <- rv$df[input$TBL1_rows_selected, ]
pwalk(list(update_funs, widgts_nms, vals), ~ exec(..1, !!!list(inputId = ..2, value = ..3[1]),.env = ))
})
应用代码：
library(shiny)
library(shinydashboard)
library(shinydashboardPlus)
library(DT)
library(tidyverse)
library(fontawesome)
library(tidyverse)
Input <- structure(list(`Security Type` = c("Stock", "Stock", "Load Fund"), Ticker = c("XOM", "NFLX", "AMCPX"), `Purchase Date` = structure(c(
16070,
17084, 17084
), class = "Date"), `Sale Date` = structure(c(
18627,
NA, 18545
), class = "Date"), `Amount Invested` = c(
10000,
8000, 10000
)), class = c(
"spec_tbl_df", "tbl_df", "tbl",
"data.frame"
), row.names = c(NA, -3L))
shinyApp(
ui = tags$body(class = "skin-blue sidebar-mini control-sidebar-open", dashboardPage(
options = list(sidebarExpandOnHover = TRUE),
header = dashboardHeader(title = "Investment Advisor Monitoring - Insider Trading", titleWidth = 450),
sidebar = dashboardSidebar(
minified = F, collapsed = F,
textInput(
"sectype", "Security Type",
"Stock")
,
textInput(
"sectick", "Ticker",
"XOM")
,
dateInput("PurDate", "Purchase Date", value = as.Date("2013-12-31")),
dateInput("selDate", "Sale Date", value = as.Date("2019-01-31")),
numericInput(
"aminv", "Amount Invested",
10000)
,
actionButton("add", "Add"),
actionButton("edit", "Edit"),
actionButton("deleteRows", "Delete Rows")
),
body = dashboardBody(
h3("Results"),
tabsetPanel(
id = "tabs",
tabPanel(
"InsiderTraining",
dataTableOutput("TBL1")
)
)
),
controlbar = dashboardControlbar(width = 300),
title = "DashboardPage"
)), ###### SERVER
server = function(input, output, session) {
rv <- reactiveValues(df = Input, row_selected = NULL)
observeEvent(
input$add,
{
rv$df <- rv$df %>%
add_row(
`Security Type` = isolate(input$sectype),
Ticker = isolate(input$sectick),
`Purchase Date` = isolate(input$PurDate),
`Sale Date` = isolate(input$selDate),
`Amount Invested` = isolate(input$aminv)
)
}
)
observeEvent(input$deleteRows,{
if (!is.null(input$TBL1_rows_selected)) {
rv$df <- rv$df[-as.numeric(input$TBL1_rows_selected), ]
}
})
observeEvent(input$edit,{
if (!is.null(input$TBL1_rows_selected)) {
cols_to_edit <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
colnms <- c('Security Type', 'Ticker', 'Purchase Date', 'Sale Date', 'Amount Invested')
"remember the row selected"
rv$row_selected <- input$TBL1_rows_selected
walk2(cols_to_edit, colnms, ~{rv$df[input$TBL1_rows_selected, ..2] <<- input[[..1]]})
}
})
##### UPDATE WIDGETS WITH SELECTED ROW ######
widgts_nms <- c('sectype', 'sectick', 'PurDate', 'selDate', 'aminv')
update_funs <- c('updateTextInput', 'updateTextInput', 'updateDateInput', 'updateDateInput', 'updateNumericInput')
#This will happen automatically on row click.
observe({
req(input$TBL1_rows_selected)
vals <- rv$df[input$TBL1_rows_selected, ]
pwalk(list(update_funs, widgts_nms, vals), ~ exec(..1, !!!list(inputId = ..2, value = ..3[1]),.env = ))
})
output$TBL1 <- renderDataTable(
rv$df,selection = "single"
)
}
)