我一直在努力在R中创建仪表板，以显示反应性表输出和要显示的网络图。我的数据有5列DT_TRX（日期），DS_CUSTOMERNAME，BENEFICIARY，AMOUNT，MODE。网络图应显示DS_CUSTOMERNAME向BENEFICIARY汇款的链接。
过滤器为DS_CUSTOMERNAME和DT_TRX。我已经能够获得表的输出，但是我无法根据所选的DS_CUSTOMERNAME和DT_TRX添加反应性网络图。
到目前为止，我的代码如下所示：
#link_data <- readRDS("~/E/Link Analysis/link_data.rds")
str(link_data)
link_data$DT_REQUEST = ymd(link_data$DT_REQUEST)
link_data$STATUS [link_data$STATUS == 1]<- "EFTS"
link_data$STATUS [link_data$STATUS == 2]<- "Cheque"
link_data$STATUS [link_data$STATUS == 3]<- "RTGS"
link_data$STATUS = factor(link_data$STATUS)
colnames(link_data) = c("DT_TRX", "BENEFICIARY",
"AMOUNT", "DS_CUSTOMERNAME", "DS_DEPARTMENT", "MODE")
link_data$BENEFICIARY = as.character(link_data$BENEFICIARY)
link_data$DS_CUSTOMERNAME = as.character(link_data$DS_CUSTOMERNAME)
link_data = na.omit(link_data)
link_data$DT_TRX = factor(link_data$DT_TRX)
#App
ui = dashboardPage(skin = "blue",
dashboardHeader(title = "LINK ANALYSIS"),
#SideBar
dashboardSidebar(
sidebarMenu (
menuItem ( "MY DASHBOARD" , tabName = "DASHBOARD" ,
icon = icon ( "dashboard" )),
width = 200,
selectInput("DS_DEPARTMENT",
label = em("SELECT DEPARTMENT",
style = "text-align:center;
color:#FFA319; font-size:100%"),
unique(link_data$DS_DEPARTMENT),
selected = 'CORPORATE BANKING'),
selectInput('DS_CUSTOMERNAME',
em('CHOOSE A CUSTOMER NAME'
,style = "text-align:center;
color:#FFA319; font-size:100%"),"",
selectize = FALSE, selected = ''),
dateRangeInput('DT_TRX',
label = em('DATE RANGE INPUT: dd/mm/yyyy'
, style = "text-align:center;
color:#FFA319; font-size:100%"),
start = Sys.Date() -365,
end = Sys.Date() -1,
format = "dd/mm/yyyy")
)
),
#Body
dashboardBody (
column(width = 12,
h5(strong("LINK ANALYSIS DATA"
,style = "text-align:right;color
:darkblue; font-size:100%")),
div(tableOutput("table1")
, style = "font-size:80%",collapsible = TRUE)),
fluidPage(
visNetworkOutput("network"),
verbatimTextOutput("shiny_return"))
)
)
server = function(input, output, session){
DS_DEPARTMENT = reactive({ input$DS_DEPARTMENT })
DS_CUSTOMERNAME = reactive({input$DS_CUSTOMERNAME })
MODE = reactive({input$MODE})
outvar = reactive({
mm = link_data$DS_CUSTOMERNAME[link_data$DS_DEPARTMENT
== DS_DEPARTMENT ()] unique (mm) })
output$DT_TRXText = renderText({
paste( "input$DT_TRX is",
paste(as.character(input$DT_TRX), collapse = "to")) })
observe({
updateSelectInput(session, "DS_CUSTOMERNAME",
choices = outvar()) })
observe({ updateDateRangeInput(
session, inputId = "DT_TRX") })
best = reactive({
filter(link_data, DS_DEPARTMENT == DS_DEPARTMENT (),
DS_CUSTOMERNAME == DS_CUSTOMERNAME (),
as.Date(link_data$DT_TRX) >= input$DT_TRX [1]
& as.Date(link_data$DT_TRX) <= input$DT_TRX [2]) })
output$table1 <- renderTable(best(), include.rownames = FALSE)
color = c('#75a3a3','#999966','#79a6d2','#c68c53')
observeEvent(input$createNetwork,{ #Nodes sources <- best() %>%
distinct(DS_CUSTOMERNAME) %>%
rename(label = DS_CUSTOMERNAME) destinations <- best() %>%
distinct(BENEFICIARY) %>%
rename(label = BENEFICIARY) nodes <- full_join(sources,
destinations, by = "label") #Edges
per_route <- best() %>%
group_by(DS_CUSTOMERNAME, BENEFICIARY) %>%
summarise(weight = n()) %>%
ungroup() per_route edges <- per_route %>%
left_join(nodes, by = c("DS_CUSTOMERNAME" = "label")) %>%
rename(from = id) edges <- edges %>% left_join(nodes,
by = c("BENEFICIARY" = "label")) %>%
rename(to = id) edges <- select(edges, from, to, weight) }) }
shinyApp (ui = ui, server = server)
我想要一个反应式表输出和一个反应式网络图，该图与一个人选择的DT_TRX和DS_CUSTOMERNAME一致
答案 0 :(得分：0)
#App
ui = dashboardPage(skin = "red",
dashboardHeader(title = "LINK ANALYSIS"),
#SideBar
dashboardSidebar(
sidebarMenu (
menuItem ( "MY DASHBOARD" ,
tabName = "DASHBOARD" ,
icon = icon ( "dashboard" )),
width = 200,
selectInput("DS_DEPARTMENT",
label = em("SELECT DEPARTMENT",
style = "text-align:center; color:#FFA319; font-size:100%"),
unique(link_data$DS_DEPARTMENT),
selected = 'CORPORATE BANKING'),
selectInput('DS_CUSTOMERNAME',
em('CHOOSE A CUSTOMER NAME',
style = "text-align:center; color:#FFA319; font-size:100%"),
"",
selectize = FALSE,
selected = ''),
dateRangeInput('DT_TRX',
label = em('DATE RANGE INPUT: dd/mm/yyyy',
style = "text-align:center; color:#FFA319; font-size:100%"),
start = Sys.Date() %m-% months(6),
end = Sys.Date() -1,
format = "dd/mm/yyyy")
)
),
#Body
dashboardBody (
column(width = 12,
h5(strong("LINK ANALYSIS DATA",
style = "text-align:right;color:darkblue; font-size:100%")),
div(tableOutput("table1"),
style = "font-size:80%",collapsible = TRUE)),
fluidPage(
theme = shinytheme("cerulean"),
titlePanel("Network Visualization App"),
sidebarLayout(
sidebarPanel(
),
mainPanel(
h3("Network Visualization"),
visNetworkOutput("plot2"),
dataTableOutput("nodes_data_from_shiny"),
uiOutput('dt_UI'))))
)
)
server = function(input, output, session){
DS_DEPARTMENT = reactive({
input$DS_DEPARTMENT
})
DS_CUSTOMERNAME = reactive({
input$DS_CUSTOMERNAME
})
MODE = reactive({
input$MODE
})
outvar = reactive({
mm = link_data$DS_CUSTOMERNAME[link_data$DS_DEPARTMENT == DS_DEPARTMENT ()]
unique (mm)
})
output$DT_TRXText = renderText({
paste( "input$DT_TRX is",
paste(as.character(input$DT_TRX), collapse = "to"))
})
observe({
updateSelectInput(session, "DS_CUSTOMERNAME",
choices = outvar())
})
observe({
updateDateRangeInput(
session, inputId = "DT_TRX")
})
best = reactive({
filter(link_data, DS_DEPARTMENT == DS_DEPARTMENT (), DS_CUSTOMERNAME == DS_CUSTOMERNAME (),
as.Date(link_data$DT_TRX) >= input$DT_TRX [1] & as.Date(link_data$DT_TRX) <= input$DT_TRX [2])
})
output$table1 <- renderTable(best(), include.rownames = FALSE)
color = c('#75a3a3','#999966','#79a6d2','#c68c53')
output$plot2 <- renderVisNetwork ({
my_df = best()
#Nodes
sources <- my_df %>%
distinct(DS_CUSTOMERNAME) %>%
rename(label = DS_CUSTOMERNAME)
destinations <- my_df %>%
distinct(BENEFICIARY) %>%
rename(label = BENEFICIARY)
nodes <- full_join(sources, destinations, by = "label")
nodes <- nodes %>% rowid_to_column("id")
#--------------------------edges------------------------
per_route <- my_df %>%
group_by(DS_CUSTOMERNAME, BENEFICIARY) %>%
summarise(weight = n()) %>%
ungroup()
per_route
edges <- per_route %>%
left_join(nodes, by = c("DS_CUSTOMERNAME" = "label")) %>%
rename(from = id)
edges <- edges %>%
left_join(nodes, by = c("BENEFICIARY" = "label")) %>%
rename(to = id)
visNetwork (nodes,edges) %>%
visEvents (select = "function(nodes) {
Shiny.onInputChange('current_node_id', nodes.nodes);
;}") %>%
visOptions(highlightNearest = T, nodesIdSelection = T) %>%
# Specify that hover interaction and on-screen button navigations are active
visInteraction(hover = T, navigationButtons = T) %>%
visIgraphLayout()
})
myNode <- reactiveValues(selected = '')
observeEvent(input$current_node_id, {
myNode$selected <<- input$current_node_id
})
output$table <- renderDataTable({
edges [which (myNode$selected == edge$from),]
})
output$dt_UI <- renderUI ({
if(nrow (edges [which(myNode$selected == edges$from),]) !=0){
dataTableOutput('table')
} else{}
})
}
shinyApp (ui = ui, server = server)