Обновление координатного фрейма данных в Shiny - PullRequest
0 голосов
/ 26 сентября 2019

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

Я застрял с тем, как использовать кнопку action, чтобы обновить сервер, чтобы включить выбранную функцию и обновить layout dataframe`.

В конечном счете, я бы хотелбыть в состоянии сохранить базу данных layout с помощью кнопки действий.Хотя я могу подождать в этой части.

library(tidyverse)
library(ggraph)
library(graphlayouts)
library(tidygraph)
library(readxl)
library(janitor)
library(scales)
library(igraph)

rm(list = ls())

            ########################
            ### Layout Functions ###
            ########################


layout_align_x <- function(matrix, nodes, anchor) {
  matrix[nodes, 1] <- matrix[anchor, 1]
  return(matrix)
}


layout_align_y <- function(matrix, nodes, anchor) {
  matrix[nodes, 2] <- matrix[anchor, 2]
  return(matrix)
}

                  #############
                  ### Graph ###
                  #############


g <- erdos.renyi.game(25, 0.15) 

V(g)$name <- 1:vcount(g)  

tbl_g <- g %>% 
  as_tbl_graph()


node.names <- tbl_g %>% 
  activate(nodes) %>% 
  as_tibble()


ui <- fluidPage(
  titlePanel("Node Layout Saver"),
     sidebarLayout(
       sidebarPanel(
         helpText("This Shiny app helps with creating custom network layouts."),
      selectInput(
        inputId = 'graph_layout',
        label = 'Layout',
        choices = c('Stress',
                    'KK',
                    'DH'),                                        selected = 'Stress'),
      selectInput(
        inputId = 'node',
        label = 'Node(s)',
        choices = node.names,                                        selected = '', 
        multiple = T),
      selectInput(
        inputId = 'anchor',
        label = 'Anchors',
        choices = node.names,                                        selected = '', 
        multiple = T),
      selectInput(
        inputId = 'layout',
        label = 'Alignment Functions',
        choices = c('Align X', 
                    'Align Y'),                                        selected = '', 
        multiple = F), 
      wellPanel(
          h3("Save"), 
          actionButton("save", "Update coordinates")
        ) ),
      mainPanel(plotOutput("myplot"))
                )
)



server <- function(input, output, session) {
  output$myplot <- renderPlot({

    if(input$graph_layout == 'Stress'){
      set.seed(123)
      layout <- as.igraph(tbl_g) %>%
      layout_with_stress() %>%
      as_tibble() %>%
      set_names('x', 'y')
    } else if (input$graph_layout == 'KK'){
      set.seed(123)
      layout <- as.igraph(tbl_g) %>%
      layout_with_kk() %>%
      as_tibble() %>%
      set_names('x', 'y')
    } else {
      set.seed(123)
      layout <- as.igraph(tbl_g) %>%
      layout_with_dh() %>%
      as_tibble() %>%
      set_names('x', 'y')
    }

     ## Nodes ##
    tbl_g_i <- tbl_g %>% 
     activate(nodes) %>% 
      mutate(node = case_when(
        name %in% input$node ~ 'Highlight', 
        T ~ 'Other'
      ), node = case_when(
        name %in% input$anchor ~ 'Anchor', 
        T ~ node
      ))

    #####################
    ### Action Button ###
    #####################

    input$save
    layout <- layout %>%
      layout_align_x(nodes = input$node,
                     anchor = input$anchor)








    tbl_g_i %>% 
      ggraph(layout = layout)+
      geom_edge_fan(show.legend = F)+
      geom_node_point(color = 'black', 
                      size = 7)+
      geom_node_point(aes(color = node), 
                      size = 6)+
      geom_node_text(aes(label = name), 
                      size = 3.25)+
      theme_minimal()+
      scale_color_brewer(type = 'seq', 
                         palette = 'Spectral',                               direction = -1)

  })


}





shinyApp(ui, server)
Добро пожаловать на сайт PullRequest, где вы можете задавать вопросы и получать ответы от других членов сообщества.
...