การทำโมเดลและนำเสนอข้อมูล

ในหัวข้อนี้เราจะเรียนรู้:

• การใส่พวกกราฟและไดอะแกรมต่างจาก ggplo2 ใน Shiny
• การทำกราฟแบบมี interactive ด้วย Plotly
• การนำเสนอแบบ interactive ด้วย dashboards
• นำเสนอผลลัพธ์จากการทำ regression ใน Shiny

การนำเสนอแบบ Interactive: หัวใจสำคัญของ Shiny

• Shiny มีสิ่งจำเป็นสำหรับการนำเสนอต่างๆ
  • พวก Plots ต่างๆ สามารถปรับเปลี่ยนผ่าน UI inputs
  • พวกปฏิสัมพันธ์กับกราฟอย่าง การซูมเข้า/ออกก็มีให้เรียบร้อย
  • พวก Dashboards ก็ช่วยเหลือการทำความเข้าใจหรือการเปรียบได้ดี

ตัวอย่าง

• ตัวอย่าง app เกี่ยวกับเรื่อง COVID-19 ของ Edward Parker COVID-19 tracker

Exercise

ให้ทดลองเล่น app COVID-19 tracker คืดว่า app นี้เป็นตัวอย่างที่ดีหรือไม่ เพราะอะไร

COVID-19 Tracker

สถานะของ app

• ในหัวข้อนี้เราจะค่อย ๆ ปรับปรุง app ของเรากัน
• code ด้านล่างนี้คือ app ที่เรามี มันจะมีตัวอย่างการใช้ table tabs
• ทบทวน:
  • ในหัวข้อที่ 3 เราใส่ tab ที่มีคำอธิบาย app
  • ในหัวข้อที่ 4 เราเพิ่ม table tab โดยใช้ DT package
  • ในหัวข้อนี้เราจะเพิ่ม tab ที่เกี่ยวกับการวิเคราะห์ข้อมูลของ Guerry

Full code for the current app state

library(shiny)
library(htmltools)
library(bs4Dash)
library(shinyWidgets)
library(Guerry)
library(sf)
library(dplyr)
library(GGally)

# 1 Data preparation ----

## Load & clean data ----
variable_names <- list(
  Crime_pers = "Crime against persons",  
  Crime_prop =  "Crime against property",  
  Literacy = "Literacy",  
  Donations = "Donations to the poor",  
  Infants = "Illegitimate births",  
  Suicides = "Suicides",  
  Wealth = "Tax / capita",  
  Commerce = "Commerce & Industry",  
  Clergy = "Clergy",  
  Crime_parents = "Crime against parents",  
  Infanticide = "Infanticides",  
  Donation_clergy = "Donations to the clergy",  
  Lottery = "Wager on Royal Lottery",  
  Desertion = "Military desertion",  
  Instruction = "Instruction",  
  Prostitutes = "Prostitutes",  
  Distance = "Distance to paris",  
  Area = "Area",  
  Pop1831 = "Population"
)

data_guerry <- Guerry::gfrance85 %>%
  st_as_sf() %>%
  as_tibble() %>%
  st_as_sf(crs = 27572) %>%
  mutate(Region = case_match(
    Region,
    "C" ~ "Central",
    "E" ~ "East",
    "N" ~ "North",
    "S" ~ "South",
    "W" ~ "West"
  )) %>%
  select(-c("COUNT", "dept", "AVE_ID_GEO", "CODE_DEPT")) %>%
  select(Region:Department, all_of(names(variable_names)))



## Prep data (Tab: Tabulate data) ----
data_guerry_tabulate <- data_guerry %>% 
  st_drop_geometry() %>% 
  mutate(across(.cols = all_of(names(variable_names)), round, 2))


## Prep data (Tab: Map data) ----
data_guerry_region <- data_guerry %>%
  group_by(Region) %>%
  summarise(across(
    .cols = all_of(names(variable_names)),
    function(x) {
      if (cur_column() %in% c("Area", "Pop1831")) {
        sum(x)
      } else {
        mean(x)
      }
    }
  ))

## Prepare palettes ----
## Used for mapping
pals <- list(
  Sequential = RColorBrewer::brewer.pal.info %>%
    filter(category %in% "seq") %>%
    row.names(),
  Viridis = c("Magma", "Inferno", "Plasma", "Viridis",
              "Cividis", "Rocket", "Mako", "Turbo")
)

## Prepare modebar clean-up ----
## Used for modelling
plotly_buttons <- c(
  "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
  "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
)


# 3 UI ----

ui <- dashboardPage(
  title = "The Guerry Dashboard",
  ## 3.1 Header ----
  header = dashboardHeader(
    title = tagList(
      img(src = "../workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
  ## 3.2 Sidebar ----
  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      flat = TRUE
    ),
    minified = TRUE,
    collapsed = TRUE,
    fixed = FALSE,
    skin = "light"
  ),
  ## 3.3 Body ----
  body = dashboardBody(
    tabItems(
      ### 3.1.1 Tab: Introduction ----
      tabItem(
        tabName = "tab_intro",
        jumbotron(
          title = "The Guerry Dashboard",
          lead = "A Shiny app to explore the classic Guerry dataset.",
          status = "info",
          btnName = NULL
        ),
        fluidRow(
          column(width = 1),
          column(
            width = 6,
            box(
              title = "About",
              status = "primary",
              width = 12,
              blockQuote(HTML("André-Michel Guerry was a French lawyer and
                          amateur statistician. Together with Adolphe
                          Quetelet he may be regarded as the founder of
                          moral statistics which led to the development
                          of criminology, sociology and ultimately,
                          modern social science. <br>— Wikipedia: <a href='https://en.wikipedia.org/wiki/Andr%C3%A9-Michel_Guerry'>André-Michel Guerry</a>"),
                         color = "primary"),
              p(HTML("Andre-Michel Guerry (1833) was the first to 
              systematically collect and analyze social data 
               on such things as crime, literacy and suicide 
               with the view to determining social laws and the 
               relations among these variables. The Guerry data 
               frame comprises a collection of 'moral variables' 
               (cf. <i><a href='https://en.wikipedia.org/wiki/Moral_statistics'>moral statistics</a></i>) 
               on the 86 departments of France around 1830. 
               A few additional variables have been added 
               from other sources. In total the data frame has 
               86 observations (the departments of France) on 23 variables <i>(Source: <code>?Guerry</code>)</i>. 
               In this app, we aim to explore Guerry’s data
                using spatial exploration and regression modelling.")),
              hr(),
              accordion(
                id = "accord",
                accordionItem(
                  title = "References",
                  status = "primary",
                  solidHeader = FALSE,
                  "The following sources are referenced in this app:",
                  tags$ul(
                    class = "list-style: none",
                    style = "margin-left: -30px;",
                    p("Angeville, A. (1836). Essai sur la Statistique de la Population française Paris: F. Doufour."),
                    p("Guerry, A.-M. (1833). Essai sur la statistique morale de la France Paris: Crochard. English translation: Hugh P. Whitt and Victor W. Reinking, Lewiston, N.Y. : Edwin Mellen Press, 2002."),
                    p("Parent-Duchatelet, A. (1836). De la prostitution dans la ville de Paris, 3rd ed, 1857, p. 32, 36"),
                    p("Palsky, G. (2008). Connections and exchanges in European thematic cartography. The case of 19th century choropleth maps. Belgeo 3-4, 413-426.")
                  )
                ),
                accordionItem(
                  title = "Details",
                  status = "primary",
                  solidHeader = FALSE,
                  p("This app was created as part of a Shiny workshop held in July 2023"),
                  p("Last update: June 2023"),
                  p("Further information about the data can be found",
                    a("here.", href = "https://www.datavis.ca/gallery/guerry/guerrydat.html"))
                )
              )
            )
          ),
          column(
            width = 4,
            box(
              title = "André Michel Guerry",
              status = "primary",
              width = 12,
              tags$img(src = "../guerry.jpg", width = "100%"),
              p("Source: Palsky (2008)")
            )
          )
        )
      ),
      ### 3.3.2 Tab: Tabulate data ----
      tabItem(
        tabName = "tab_tabulate",
        fluidRow(
          #### Inputs(s) ----
          pickerInput(
            "tab_tabulate_select",
            label = "Filter variables",
            choices = setNames(names(variable_names), variable_names),
            options = pickerOptions(
              actionsBox = TRUE,
              windowPadding = c(30, 0, 0, 0),
              liveSearch = TRUE,
              selectedTextFormat = "count",
              countSelectedText = "{0} variables selected",
              noneSelectedText = "No filters applied"
            ),
            inline = TRUE,
            multiple = TRUE
          )
        ),
        hr(),
        #### Output(s) (Data table) ----
        DT::dataTableOutput("tab_tabulate_table")
      )
    ) # end tabItems
  ),
  
  ## 3.4 Footer (bottom)----
  footer = dashboardFooter(
    left = span(
      "This dashboard was created by Jonas Lieth and Paul Bauer. Find the source code",
      a("here.", href = "https://github.com/paulcbauer/shiny_workshop/tree/main/shinyapps/guerry"),
      "It is based on data from the",
      a("Guerry R package.", href = "https://cran.r-project.org/web/packages/Guerry/index.html")
    )
  ),
  ## 3.5 Controlbar (top)----
  controlbar = dashboardControlbar(
    div(class = "p-3", skinSelector()),
    skin = "light"
  )  
)



# 4 Server ----

server <- function(input, output, session) {
  
  ## 4.1 Tabulate data ----
  ### Variable selection ----
  tab <- reactive({
    var <- input$tab_tabulate_select
    data_table <- data_guerry_tabulate
    
    if (!is.null(var)) {
      data_table <- data_table[, var]
    }
    
    data_table
  })
  
  
  ### Create table----
  dt <- reactive({
    tab <- tab()
    ridx <- ifelse("Department" %in% names(tab), 3, 1)
    DT::datatable(
      tab,
      class = "hover",
      extensions = c("Buttons"),
      selection = "none",
      filter = list(position = "top", clear = FALSE),
      style = "bootstrap4",
      rownames = FALSE,
      options = list(
        dom = "Brtip",
        deferRender = TRUE,
        scroller = TRUE,
        buttons = list(
          list(extend = "copy", text = "Copy to clipboard"),
          list(extend = "pdf", text = "Save as PDF"),
          list(extend = "csv", text = "Save as CSV"),
          list(extend = "excel", text = "Save as JSON", action = DT::JS("
          function (e, dt, button, config) {
            var data = dt.buttons.exportData();
  
            $.fn.dataTable.fileSave(
              new Blob([JSON.stringify(data)]),
              'Shiny dashboard.json'
            );
          }
        "))
        )
      )
    )
  })
  
  ### Render table----
  output$tab_tabulate_table <- DT::renderDataTable(dt(), server = FALSE)
  
  
  
  ## 4.2 Model data ----

  # New code goes here :)
}

shinyApp(ui, server)

แหล่งข้อมูลเพิ่มเติม

• Chapter “Graphics” Hadley Wickham’s Mastering Shiny
• “Server-side linking with shiny” หนังสือ Plotly ของ Carson Sievert

การ Plot ใน Shiny

• การใส่พวกกราฟหรือplot ก็เหมือนกับใส่องค์ประกอบตัวควบคุมอื่นใน UI
• เราต้องการเพียงคำสั่ง: plotOutput() ใน UI กับ renderPlot() ในส่วนของ server
  • plotOutput() สร้างที่บน UI สำหรับใส่กราฟ
  • renderPlot()สร้างกราฟแล้วเอาไปใส่ที่ที่เตรียมไว้บน UI

เพิ่ม section ใหม่ใน Guerry app

• เพิ่ม tab ใหม่ใน app และเรียกมันว่า “Model data”
• จุดประสงค์เพื่อดูความสัมพันธ์ของตัวแปรต่างๆ
• คำถาม: ถ้าเราจะดูเรื่องความสัมพันธ์ระหว่างตัวแปร ความจะนำเสนอในรูปแบบอะไร

ใส่ส่วนประกอบใน UI

• ลองดูที่ code ว่าเราใส่ tab เพิ่มอย่างไร:

1model <- tabItem(
    "tab_model",
2    fluidRow(
        column(
            width = 6,
        box(
                width = 12,
                title = "Pair diagram",
                status = "primary",
3                plotOutput("pairplot")
            )
        )
    )
)

1

สร้าง tab item เรียก “tab_model”

2

สร้างรูปแบบ layout เริ่มต้นที่ใช้ fluid row กับ 1 column และ 1 กล่อง box

3

ใส่ที่สำหรับกราฟ

• tab Item ที่ใส่ใหม่ชื่อ tab_model
• เรามี tabs item อยู่แล้วที่ชื่อ tab_intro กับ tab_tabulate:

dashboardPage(
  header = dashboardHeader(
    title = tagList(
      img(src = "workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
1  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      menuItem(tabName = "tab_model", text = "Model data", icon = "chart-line")
    )
  ),
2  body = dashboardBody(
    # Note: Tab contents omitted to maintain readability!
    tabItems(
      tabItem(tabName = "tab_intro"),
      tabItem(tabname = "tab_tabulate"),
      model
    )
  )
)

1

ใส่ menu items ที่ sidebar อย่าลืมใส่ชื่อให้ตรงกับ tab

2

ใส่ tab items ในตัว body ซึ่งtabItems() จะมีตัวรวบรวมtabทั้งหมด ตัว tab_model ใส่ต่อจากintroduction และชื่อของtabItem()ต้องตรงตามลำดับกับชื่อใน menuItem()

ใส่เนื้อหา

• ใส่อะไรก็ได้ที่อยากใส่
• เราใส่พวกทำ plotting ต่าง ๆที่ server
• ในที่นี้เราใช้ ggpairs จาก GGally package จริงๆ จะใช้อะไรก็ได้ที่เกี่ยวข้องกับการทำกราฟ

1output$pairplot <- renderPlot({
2    dt <- st_drop_geometry(guerry[c("Literacy", "Commerce")])
3    GGally::ggpairs(dt, axisLabels = "none")
})

1

renderPlot() จะรับชุดคำสั่งที่มีการสร้างกราฟ

2

เตรียมข้อมูลให้พร้อมสำหรับการplot

3

ggpairs() เป็นคำสั่งสำหรับสร้างกราฟอันหนึ่งจาก ggplot2

code ตัวเต็ม

Full code for basic plotting

library(shiny)
library(htmltools)
library(bs4Dash)
library(shinyWidgets)
library(Guerry)
library(sf)
library(dplyr)
library(GGally)

# 1 Data preparation ----

## Load & clean data ----
variable_names <- list(
  Crime_pers = "Crime against persons",  
  Crime_prop =  "Crime against property",  
  Literacy = "Literacy",  
  Donations = "Donations to the poor",  
  Infants = "Illegitimate births",  
  Suicides = "Suicides",  
  Wealth = "Tax / capita",  
  Commerce = "Commerce & Industry",  
  Clergy = "Clergy",  
  Crime_parents = "Crime against parents",  
  Infanticide = "Infanticides",  
  Donation_clergy = "Donations to the clergy",  
  Lottery = "Wager on Royal Lottery",  
  Desertion = "Military desertion",  
  Instruction = "Instruction",  
  Prostitutes = "Prostitutes",  
  Distance = "Distance to paris",  
  Area = "Area",  
  Pop1831 = "Population"
)

data_guerry <- Guerry::gfrance85 %>%
  st_as_sf() %>%
  as_tibble() %>%
  st_as_sf(crs = 27572) %>%
  mutate(Region = case_match(
    Region,
    "C" ~ "Central",
    "E" ~ "East",
    "N" ~ "North",
    "S" ~ "South",
    "W" ~ "West"
  )) %>%
  select(-c("COUNT", "dept", "AVE_ID_GEO", "CODE_DEPT")) %>%
  select(Region:Department, all_of(names(variable_names)))



## Prep data (Tab: Tabulate data) ----
data_guerry_tabulate <- data_guerry %>% 
  st_drop_geometry() %>% 
  mutate(across(.cols = all_of(names(variable_names)), round, 2))


## Prep data (Tab: Map data) ----
data_guerry_region <- data_guerry %>%
  group_by(Region) %>%
  summarise(across(
    .cols = all_of(names(variable_names)),
    function(x) {
      if (cur_column() %in% c("Area", "Pop1831")) {
        sum(x)
      } else {
        mean(x)
      }
    }
  ))

## Prepare palettes ----
## Used for mapping
pals <- list(
  Sequential = RColorBrewer::brewer.pal.info %>%
    filter(category %in% "seq") %>%
    row.names(),
  Viridis = c("Magma", "Inferno", "Plasma", "Viridis",
              "Cividis", "Rocket", "Mako", "Turbo")
)

## Prepare modebar clean-up ----
## Used for modelling
plotly_buttons <- c(
  "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
  "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
)


# 3 UI ----

ui <- dashboardPage(
  title = "The Guerry Dashboard",
  ## 3.1 Header ----
  header = dashboardHeader(
    title = tagList(
      img(src = "../workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
  ## 3.2 Sidebar ----
  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      menuItem(tabName = "tab_model", text = "Model data", icon = icon("chart-line")),
      flat = TRUE
    ),
    minified = TRUE,
    collapsed = TRUE,
    fixed = FALSE,
    skin = "light"
  ),
  ## 3.3 Body ----
  body = dashboardBody(
    tabItems(
      ### 3.1.1 Tab: Introduction ----
      tabItem(
        tabName = "tab_intro",
        jumbotron(
          title = "The Guerry Dashboard",
          lead = "A Shiny app to explore the classic Guerry dataset.",
          status = "info",
          btnName = NULL
        ),
        fluidRow(
          column(width = 1),
          column(
            width = 6,
            box(
              title = "About",
              status = "primary",
              width = 12,
              blockQuote(HTML("André-Michel Guerry was a French lawyer and
                          amateur statistician. Together with Adolphe
                          Quetelet he may be regarded as the founder of
                          moral statistics which led to the development
                          of criminology, sociology and ultimately,
                          modern social science. <br>— Wikipedia: <a href='https://en.wikipedia.org/wiki/Andr%C3%A9-Michel_Guerry'>André-Michel Guerry</a>"),
                         color = "primary"),
              p(HTML("Andre-Michel Guerry (1833) was the first to 
              systematically collect and analyze social data 
               on such things as crime, literacy and suicide 
               with the view to determining social laws and the 
               relations among these variables. The Guerry data 
               frame comprises a collection of 'moral variables' 
               (cf. <i><a href='https://en.wikipedia.org/wiki/Moral_statistics'>moral statistics</a></i>) 
               on the 86 departments of France around 1830. 
               A few additional variables have been added 
               from other sources. In total the data frame has 
               86 observations (the departments of France) on 23 variables <i>(Source: <code>?Guerry</code>)</i>. 
               In this app, we aim to explore Guerry’s data
                using spatial exploration and regression modelling.")),
              hr(),
              accordion(
                id = "accord",
                accordionItem(
                  title = "References",
                  status = "primary",
                  solidHeader = FALSE,
                  "The following sources are referenced in this app:",
                  tags$ul(
                    class = "list-style: none",
                    style = "margin-left: -30px;",
                    p("Angeville, A. (1836). Essai sur la Statistique de la Population française Paris: F. Doufour."),
                    p("Guerry, A.-M. (1833). Essai sur la statistique morale de la France Paris: Crochard. English translation: Hugh P. Whitt and Victor W. Reinking, Lewiston, N.Y. : Edwin Mellen Press, 2002."),
                    p("Parent-Duchatelet, A. (1836). De la prostitution dans la ville de Paris, 3rd ed, 1857, p. 32, 36"),
                    p("Palsky, G. (2008). Connections and exchanges in European thematic cartography. The case of 19th century choropleth maps. Belgeo 3-4, 413-426.")
                  )
                ),
                accordionItem(
                  title = "Details",
                  status = "primary",
                  solidHeader = FALSE,
                  p("This app was created as part of a Shiny workshop held in July 2023"),
                  p("Last update: June 2023"),
                  p("Further information about the data can be found",
                    a("here.", href = "https://www.datavis.ca/gallery/guerry/guerrydat.html"))
                )
              )
            )
          ),
          column(
            width = 4,
            box(
              title = "André Michel Guerry",
              status = "primary",
              width = 12,
              tags$img(src = "../guerry.jpg", width = "100%"),
              p("Source: Palsky (2008)")
            )
          )
        )
      ),
      ### 3.3.2 Tab: Tabulate data ----
      tabItem(
        tabName = "tab_tabulate",
        fluidRow(
          #### Inputs(s) ----
          pickerInput(
            "tab_tabulate_select",
            label = "Filter variables",
            choices = setNames(names(variable_names), variable_names),
            options = pickerOptions(
              actionsBox = TRUE,
              windowPadding = c(30, 0, 0, 0),
              liveSearch = TRUE,
              selectedTextFormat = "count",
              countSelectedText = "{0} variables selected",
              noneSelectedText = "No filters applied"
            ),
            inline = TRUE,
            multiple = TRUE
          )
        ),
        hr(),
        #### Output(s) (Data table) ----
        DT::dataTableOutput("tab_tabulate_table")
      ),
      ### 3.3.3 Tab: Model data ----
      tabItem(
        tabName = "tab_model",
        fluidRow(
          column(
            width = 6,
            ##### Box: Pair diagramm ----
            box(
              width = 12,
              title = "Pair diagram",
              status = "primary",
              plotOutput("pairplot")
            )
          )
        )
      )
    ) # end tabItems
  ),
  
  ## 3.4 Footer (bottom)----
  footer = dashboardFooter(
    left = span(
      "This dashboard was created by Jonas Lieth and Paul Bauer. Find the source code",
      a("here.", href = "https://github.com/paulcbauer/shiny_workshop/tree/main/shinyapps/guerry"),
      "It is based on data from the",
      a("Guerry R package.", href = "https://cran.r-project.org/web/packages/Guerry/index.html")
    )
  ),
  ## 3.5 Controlbar (top)----
  controlbar = dashboardControlbar(
    div(class = "p-3", skinSelector()),
    skin = "light"
  )  
)



# 4 Server ----

server <- function(input, output, session) {
  
  ## 4.1 Tabulate data ----
  ### Variable selection ----
  tab <- reactive({
    var <- input$tab_tabulate_select
    data_table <- data_guerry_tabulate
    
    if (!is.null(var)) {
      data_table <- data_table[, var]
    }
    
    data_table
  })
  
  
  ### Create table----
  dt <- reactive({
    tab <- tab()
    ridx <- ifelse("Department" %in% names(tab), 3, 1)
    DT::datatable(
      tab,
      class = "hover",
      extensions = c("Buttons"),
      selection = "none",
      filter = list(position = "top", clear = FALSE),
      style = "bootstrap4",
      rownames = FALSE,
      options = list(
        dom = "Brtip",
        deferRender = TRUE,
        scroller = TRUE,
        buttons = list(
          list(extend = "copy", text = "Copy to clipboard"),
          list(extend = "pdf", text = "Save as PDF"),
          list(extend = "csv", text = "Save as CSV"),
          list(extend = "excel", text = "Save as JSON", action = DT::JS("
          function (e, dt, button, config) {
            var data = dt.buttons.exportData();
  
            $.fn.dataTable.fileSave(
              new Blob([JSON.stringify(data)]),
              'Shiny dashboard.json'
            );
          }
        "))
        )
      )
    )
  })
  
  ### Render table----
  output$tab_tabulate_table <- DT::renderDataTable(dt(), server = FALSE)
  
  
  
  ## 4.2 Model data ----
  ### Pair diagram ----
  output$pairplot <- renderPlot({
    dt <- st_drop_geometry(data_guerry[c("Literacy", "Commerce")])
    GGally::ggpairs(dt, axisLabels = "none") 
  })
}

shinyApp(ui, server)

ข้อจำกัด

• code ที่ใช้ในการplotนี้เป็นแบบอย่างง่าย ที่ดูไม่ค่อยจะต่างจากคำสั่งplot ต่างๆที่มาด้วยกับ R
• ถ้าอยากเห็นที่มันแตกต่าง ต้องดูในคุณสมบัติทั้ง 3 นี้:
  • Reactivity ปฏิกิริยา
  • Interactivity โต้ดอบ
  • Contextuality บริบท

Reactivity ปฏิกิริยา

• Reactivity หมายถึงเพิ่มตัวที่ขึ้นกับ reactive นั้นๆ
• ในที่นี้เราพิมพ์ใส่ชื่อตัวแปรลงไป แต่ผู้ใช้ก็สามารถที่จะเลือกได้

การใส่ input ต่าง ๆ ใน UI

• ตอนนี้เราใช้ Inputsอยู่ 3 แบบ
  • selectInput() เพื่อเลือกตัวแปร x (ค่าเริ่มต้นคือ Literacy)
  • selectizeInput() เพื่อเลือกตัวแปร y (ค่าเริ่มต้นคือ Commerce)
  • checkboxInput() เพื่อเป็นทางเลือกว่าจะทำ standardize หรือไม่

Note

เราใส่ปุ่ม actionButton() เพื่อให้ผู้ใช้กดเพื่อดูผลหลังจากเหลือ Inputs ต่างๆ

model <- tabItem(
    "tab_model",
1    fluidRow(
        column(
            width = 6,
            #### Box: Select variables ----
      box(
                width = 12,
                title = "Select variables",
                status = "primary",
2                selectInput(
                    "model_x",
                    label = "Select a dependent variable",
                    choices = setNames(names(variable_names), variable_names),
                    selected = "Literacy"
                ),
3                selectizeInput(
                    "model_y",
                    label = "Select independent variables",
                    choices = setNames(names(variable_names), variable_names),
                    multiple = TRUE,
                    selected = "Commerce"
                ),
4                checkboxInput(
                    "model_std",
                    label = "Standardize variables?",
                    value = TRUE
                ),
                hr(),
5                actionButton(
                    "refresh",
                    label = "Apply changes",
                    icon = icon("refresh"),
                    flat = TRUE
                )
            )
        ),
        #### Box: Pair diagramm ----
        column(
            width = 6,
        box(
                width = 12,
                title = "Pair diagram",
                status = "primary",
                plotOutput("pairplot")
            )
        )
    )
)

1

สร้าง column กับ box ใหม่สำหรับใส่ Inputs ต่างๆ

2

สร้าง selectInput() สำหรับเลือกตัวแปร x โดยใส่รายชื่อตัวแปรที่จะเลือกทั้งหมดใน choices

3

สร้าง selectizeInput() สำหรับเลือกตัวแปร y

4

ใส่ checkboxInput() ให้ผู้ใช้เลือกว่าจะ standardize ตัวแปรหรือไม่

5

สร้างปุ่ม actionButton() เพื่อส่งให้ทำการคำนวณตามค่า Inputs ต่างๆที่เลือกไป

การเข้าถึง UI inputs ที่ใส่เข้าไปใหม่

• คำถาม: UI inputs อันไหนที่เราเพิ่งใส่เข้าไป แล้วเราจะเข้าถึงค่าของมันจากฝั่ง server ได้อย่างไร
• เราใส่ตัว reactive ใหม่สำหรับ clean ข้อมูล

Note

bindEvent เพื่อให้มั่นใจว่าจะคำนวณใหม่โดยใช้ค่า inputที่ใส่เข้ามาหลังจากกดปุ่ม actionButton() เท่านั้น ลองเอาออก แล้วดูว่าเกิดอะไรขึ้น

1dat <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(guerry)[c(x, y)]
    if (input$model_std) dt <- datawizard::standardise(dt)
    dt
}) %>%
2    bindEvent(input$refresh, ignoreNULL = FALSE)

output$pairplot <- renderPlot({
3    GGally::ggpairs(dat(), axisLabels = "none")
})

1

สร้าง reactive expression ที่คอยดูเรื่อง cleaning และจัดเก็บข้อมูลในตัวแปร reactive object ชื่อ dat

2

ซึ่ง reactive expression ที่อยู่ใน reactive จะถูกรันใหม่(หรืออัพเดทค่า dat) ก็ต่อเมื่อปุ่มrefresh ถูกกด

3

สร้าง pairs plot โดยใช้ค่าจาก dat() เช่นเดียวกันกับ dt dataframe ที่เราใช้ก่อนหน้านี้ เพียงแต่ว่า ตัวdat() จะมีการอัพเดทค่าทุกครั้งที่ค่าของ input$model_x input$model_y หรือ input$model_std มีการเปลี่ยนแปลง

• ตัวกราฟจะมีผลเปลี่ยนแปลงทันทีที่ผู้ใช้เลือกหรือเปลี่ยน Inputs

code ตัวเต็ม

Full code for reactive plotting

library(shiny)
library(htmltools)
library(bs4Dash)
library(shinyWidgets)
library(Guerry)
library(sf)
library(dplyr)
library(plotly)
library(GGally)

# 1 Data preparation ----

## Load & clean data ----
variable_names <- list(
  Crime_pers = "Crime against persons",  
  Crime_prop =  "Crime against property",  
  Literacy = "Literacy",  
  Donations = "Donations to the poor",  
  Infants = "Illegitimate births",  
  Suicides = "Suicides",  
  Wealth = "Tax / capita",  
  Commerce = "Commerce & Industry",  
  Clergy = "Clergy",  
  Crime_parents = "Crime against parents",  
  Infanticide = "Infanticides",  
  Donation_clergy = "Donations to the clergy",  
  Lottery = "Wager on Royal Lottery",  
  Desertion = "Military desertion",  
  Instruction = "Instruction",  
  Prostitutes = "Prostitutes",  
  Distance = "Distance to paris",  
  Area = "Area",  
  Pop1831 = "Population"
)

data_guerry <- Guerry::gfrance85 %>%
  st_as_sf() %>%
  as_tibble() %>%
  st_as_sf(crs = 27572) %>%
  mutate(Region = case_match(
    Region,
    "C" ~ "Central",
    "E" ~ "East",
    "N" ~ "North",
    "S" ~ "South",
    "W" ~ "West"
  )) %>%
  select(-c("COUNT", "dept", "AVE_ID_GEO", "CODE_DEPT")) %>%
  select(Region:Department, all_of(names(variable_names)))



## Prep data (Tab: Tabulate data) ----
data_guerry_tabulate <- data_guerry %>% 
  st_drop_geometry() %>% 
  mutate(across(.cols = all_of(names(variable_names)), round, 2))


## Prepare modebar clean-up ----
## Used for modelling
plotly_buttons <- c(
  "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
  "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
)



# 3 UI ----

ui <- dashboardPage(
  title = "The Guerry Dashboard",
  ## 3.1 Header ----
  header = dashboardHeader(
    title = tagList(
      img(src = "../workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
  ## 3.2 Sidebar ----
  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      menuItem(tabName = "tab_model", text = "Model data", icon = icon("chart-line")),
      flat = TRUE
    ),
    minified = TRUE,
    collapsed = TRUE,
    fixed = FALSE,
    skin = "light"
  ),
  ## 3.3 Body ----
  body = dashboardBody(
    tabItems(
      ### 3.1.1 Tab: Introduction ----
      tabItem(
        tabName = "tab_intro",
        jumbotron(
          title = "The Guerry Dashboard",
          lead = "A Shiny app to explore the classic Guerry dataset.",
          status = "info",
          btnName = NULL
        ),
        fluidRow(
          column(width = 1),
          column(
            width = 6,
            box(
              title = "About",
              status = "primary",
              width = 12,
              blockQuote(HTML("André-Michel Guerry was a French lawyer and
                          amateur statistician. Together with Adolphe
                          Quetelet he may be regarded as the founder of
                          moral statistics which led to the development
                          of criminology, sociology and ultimately,
                          modern social science. <br>— Wikipedia: <a href='https://en.wikipedia.org/wiki/Andr%C3%A9-Michel_Guerry'>André-Michel Guerry</a>"),
                         color = "primary"),
              p(HTML("Andre-Michel Guerry (1833) was the first to 
              systematically collect and analyze social data 
               on such things as crime, literacy and suicide 
               with the view to determining social laws and the 
               relations among these variables. The Guerry data 
               frame comprises a collection of 'moral variables' 
               (cf. <i><a href='https://en.wikipedia.org/wiki/Moral_statistics'>moral statistics</a></i>) 
               on the 86 departments of France around 1830. 
               A few additional variables have been added 
               from other sources. In total the data frame has 
               86 observations (the departments of France) on 23 variables <i>(Source: <code>?Guerry</code>)</i>. 
               In this app, we aim to explore Guerry’s data
                using spatial exploration and regression modelling.")),
              hr(),
              accordion(
                id = "accord",
                accordionItem(
                  title = "References",
                  status = "primary",
                  solidHeader = FALSE,
                  "The following sources are referenced in this app:",
                  tags$ul(
                    class = "list-style: none",
                    style = "margin-left: -30px;",
                    p("Angeville, A. (1836). Essai sur la Statistique de la Population française Paris: F. Doufour."),
                    p("Guerry, A.-M. (1833). Essai sur la statistique morale de la France Paris: Crochard. English translation: Hugh P. Whitt and Victor W. Reinking, Lewiston, N.Y. : Edwin Mellen Press, 2002."),
                    p("Parent-Duchatelet, A. (1836). De la prostitution dans la ville de Paris, 3rd ed, 1857, p. 32, 36"),
                    p("Palsky, G. (2008). Connections and exchanges in European thematic cartography. The case of 19th century choropleth maps. Belgeo 3-4, 413-426.")
                  )
                ),
                accordionItem(
                  title = "Details",
                  status = "primary",
                  solidHeader = FALSE,
                  p("This app was created as part of a Shiny workshop held in July 2023"),
                  p("Last update: June 2023"),
                  p("Further information about the data can be found",
                    a("here.", href = "https://www.datavis.ca/gallery/guerry/guerrydat.html"))
                )
              )
            )
          ),
          column(
            width = 4,
            box(
              title = "André Michel Guerry",
              status = "primary",
              width = 12,
              tags$img(src = "../guerry.jpg", width = "100%"),
              p("Source: Palsky (2008)")
            )
          )
        )
      ),
      ### 3.3.2 Tab: Tabulate data ----
      tabItem(
        tabName = "tab_tabulate",
        fluidRow(
          #### Inputs(s) ----
          pickerInput(
            "tab_tabulate_select",
            label = "Filter variables",
            choices = setNames(names(variable_names), variable_names),
            options = pickerOptions(
              actionsBox = TRUE,
              windowPadding = c(30, 0, 0, 0),
              liveSearch = TRUE,
              selectedTextFormat = "count",
              countSelectedText = "{0} variables selected",
              noneSelectedText = "No filters applied"
            ),
            inline = TRUE,
            multiple = TRUE
          )
        ),
        hr(),
        #### Output(s) (Data table) ----
        DT::dataTableOutput("tab_tabulate_table")
      ),
      ### 3.3.3 Tab: Model data ----
      tabItem(
        tabName = "tab_model",
        fluidRow(
          column(
            width = 6,
            #### Inputs(s) ----
            box(
              width = 12,
              title = "Select variables",
              status = "primary",
              selectInput(
                "model_x",
                label = "Select a dependent variable",
                choices = setNames(names(variable_names), variable_names),
                selected = "Literacy"
              ),
              selectizeInput(
                "model_y",
                label = "Select independent variables",
                choices = setNames(names(variable_names), variable_names),
                multiple = TRUE,
                selected = "Commerce"
              ),
              checkboxInput(
                "model_std",
                label = "Standardize variables?",
                value = TRUE
              ),
              hr(),
              actionButton(
                "refresh",
                label = "Apply changes",
                icon = icon("refresh"),
                flat = TRUE
              )
            )
          ),
          column(
            width = 6,
            ##### Box: Pair diagramm ----
            box(
              width = 12,
              title = "Pair diagram",
              status = "primary",
              plotOutput("pairplot")
            )
            # A fourth box can go here :)
          )
        )
      )
    ) # end tabItems
  ),
  
  ## 3.4 Footer (bottom)----
  footer = dashboardFooter(
    left = span(
      "This dashboard was created by Jonas Lieth and Paul Bauer. Find the source code",
      a("here.", href = "https://github.com/paulcbauer/shiny_workshop/tree/main/shinyapps/guerry"),
      "It is based on data from the",
      a("Guerry R package.", href = "https://cran.r-project.org/web/packages/Guerry/index.html")
    )
  ),
  ## 3.5 Controlbar (top)----
  controlbar = dashboardControlbar(
    div(class = "p-3", skinSelector()),
    skin = "light"
  )  
)



# 4 Server ----

server <- function(input, output, session) {
  
  ## 4.1 Tabulate data ----
  ### Variable selection ----
  tab <- reactive({
    var <- input$tab_tabulate_select
    data_table <- data_guerry_tabulate
    
    if (!is.null(var)) {
      data_table <- data_table[, var]
    }
    
    data_table
  })
  
  
  ### Create table----
  dt <- reactive({
    tab <- tab()
    ridx <- ifelse("Department" %in% names(tab), 3, 1)
    DT::datatable(
      tab,
      class = "hover",
      extensions = c("Buttons"),
      selection = "none",
      filter = list(position = "top", clear = FALSE),
      style = "bootstrap4",
      rownames = FALSE,
      options = list(
        dom = "Brtip",
        deferRender = TRUE,
        scroller = TRUE,
        buttons = list(
          list(extend = "copy", text = "Copy to clipboard"),
          list(extend = "pdf", text = "Save as PDF"),
          list(extend = "csv", text = "Save as CSV"),
          list(extend = "excel", text = "Save as JSON", action = DT::JS("
          function (e, dt, button, config) {
            var data = dt.buttons.exportData();
  
            $.fn.dataTable.fileSave(
              new Blob([JSON.stringify(data)]),
              'Shiny dashboard.json'
            );
          }
        "))
        )
      )
    )
  })
  
  ### Render table----
  output$tab_tabulate_table <- DT::renderDataTable(dt(), server = FALSE)
  
  
  
  ## 4.2 Model data ----
  ### Define & estimate model ----
  dat <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(data_guerry)[c(x, y)]
    if (input$model_std) dt <- datawizard::standardise(dt)
    
    dt
  }) %>%
    bindEvent(input$refresh, ignoreNULL = FALSE)
  
  ### Pair diagram ----
  output$pairplot <- renderPlot({
    GGally::ggpairs(dat(), axisLabels = "none")
  })
}

shinyApp(ui, server)

Interactivity โต้ตอบ

• ตอนนี้ภาพกราของเรายังเป็นแบบนิ่ง ๆ
• กราฟแบบนิ่งๆนี้ก็เหมาะกับรายงานหรือบทความทั่วไป แต่ Shiny ได้มากกว่านั้น
• คุณสมบัติของ Shiny พื้นฐานสำหรับ โต้ตอบก็มีอย่างเช่น คลิ๊ก ดับเบิ้ลคลิ๊ก วางค้างไว้ หรือ ลากคลุมเพื่อเลือก (ดูเพิ่มเติมที่ Chapter 7.1)
• ในที่นี้เราจะลองใช้กราฟที่ทำจาก Plotly

Plotly

• Plotly เป็นlibrary สำหรับสร้างกราฟที่มีการโต้ตอบกับผู้ใช้
• Plotly สามารถใช้ได้กับหลายภาษา ซึ่งรวมถึง R และ Shiny ด้วย

Code to re-produce the Plotly figure

mtcars$am[which(mtcars$am == 0)] <- 'Automatic'
mtcars$am[which(mtcars$am == 1)] <- 'Manual'
mtcars$am <- as.factor(mtcars$am)


plot_ly(
  mtcars,
  x = ~wt,
  y = ~hp,
  z = ~qsec,
  color = ~am,
  colors = c('#BF382A', '#0C4B8E')) %>%
  add_markers() %>%
  layout(scene = list(
    xaxis = list(title = 'Weight'),
    yaxis = list(title = 'Gross horsepower'),
    zaxis = list(title = '1/4 mile time')
  ))

Plotly กับ Shiny

• คำสั่งสำหรับการแสดงผลกราฟจาก Plotly ก็เหมือนกันกับก่อนหน้านี้:
  • plotlyOutput() สำหรับสร้าง UI เพื่อแสดงผล
  • renderPlotly() สำหรับสร้างกราฟเพื่อไปแสดงผลบน UI ที่เตรียมไว้

model <- tabItem(
    "tab_model",
    fluidRow(
        column(
            width = 6,
            #### Box: Select variables ----
      box(
                width = 12,
                title = "Select variables",
                status = "primary",
                selectInput(
                    "model_x",
                    label = "Select a dependent variable",
                    choices = setNames(names(variable_names), variable_names),
                    selected = "Literacy"
                ),
                selectizeInput(
                    "model_y",
                    label = "Select independent variables",
                    choices = setNames(names(variable_names), variable_names),
                    multiple = TRUE,
                    selected = "Commerce"
                ),
                checkboxInput(
                    "model_std",
                    label = "Standardize variables?",
                    value = TRUE
                ),
                hr(),
                actionButton(
                    "refresh",
                    label = "Apply changes",
                    icon = icon("refresh"),
                    flat = TRUE
                )
            )
        ),
        #### Box: Pair diagramm ----
        column(
            width = 6,
        box(
                width = 12,
                title = "Pair diagram",
                status = "primary",
1                plotly::plotlyOutput("pairplot")
            )
        )
    )
)

1

สิ่งที่เปลี่ยนเข้าไปคือการใช้ Plotly ซึ่งต้องการ Ouput เฉพาะของตัวเอง (plotlyOutput)

ggplotly ในฝั่งของ server

• Plotly มีระบบการplotหรือสร้างกราฟต่างๆของตัวเองที่ดีมาก plot_ly()
• ซึ่งก็เป็นโชคของเราที่เราเพียงเรียกใช้ ggplotly() กับตัวกราฟที่สร้างจาก ggplot มันก็จะถูกเปลี่ยนเป็นไปใช้ plotly แทน

dat <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(guerry)[c(x, y)]
    if (input$model_std) dt <- datawizard::standardise(dt)
    dt
}) %>%
    bindEvent(input$refresh, ignoreNULL = FALSE)

1output$pairplot <- plotly::renderPlotly({
    p <- GGally::ggpairs(dat(), axisLabels = "none")
2    plotly::ggplotly(p)
})

1

ตัวplot จาก Plotly ไม่ใช่แบบกราฟนิ่งๆแล้ว เราก็ต้องการสร้างกราฟเฉพาะคือ plotly::renderPlotly()

2

ในขณะเดียวกันเราก็ต้องเปลี่ยนกราฟของเราจาก ggplot ให้เป็นแบบ plotly ด้วย plotly::ggplotly()

ขยายการใช้งาน Plotly

• ตอนนี้เราสามารถเป็นกราฟจาก ggplot ให้เป็น plotly ได้ด้วยคำสั่งเดียว
• แต่หลายๆส่วนของ plot ก็ยังใช้ไม่ได้เพราะเราไม่ได้สร้างกราฟจากคำสั่ง plot_ly() โดยตรง

การแก้ไขปรับแต่ง Plotly

• เราสามารถปรับแต่งกราฟจาก Plotly ได้โดยอาศัย 3 คำสั่งนี้:
  • layout() สำหรับปรับเปลี่ยนหน้าตาของกราฟ อย่างเช่น สี ฟ้อนท์ ขนาด ตำแหน่ง สัดส่วน และอื่นๆ (เช่นเดียวกันกับ ggplot2::theme())
    • updatemenus ใส่ปุ่มหรือเมนูสำหรับเปลี่ยน layout ( ดูที่นี่ สำหรับตัวอย่าง)
    • sliders ใส่ sliders (ดูที่นี่ สำหรับตัวอย่าง)
  • config() เปลี่ยนการตั้งค่าการโต้ตอบ:
    • modeBarButtons กับ displaylogo ควบคุมปุ่มใน mode bar
    • toImageButtonOptions ควบคุมรูปแบบ downloads
    • scrollZoom ควบคุมว่าให้มีการซูมด้วยการ scroll หรือไม่
  • style() เปลี่ยนพวกสไตล์ (คล้ายๆกับ ggplot2::scale_) เช่น:
    • hoverinfo ควบคุมว่าจะให้โชว์ tooptip หรือไม่เวลาวางลูกศรชี้ไว้
    • mode ความคุมว่าจให้โชว์ จุด เส้น หรือ ข้อความใน scatter plot หรือไม่
    • hovertext แก้ไขข้อความใน tooltips

Schema ผังการปรับแต่ง

• options มันเยอะมาก
• ถ้าอยากดูทั้งหมด ลองพิมพ์เรียก plotly::schema()

plotly::schema()

ตัวอย่าง

• เราสามารถปรับเปลี่ยนในส่วน mode bar กับ การ download ได้

ggplotly(p) %>%
  config(
1    modeBarButtonsToRemove = c(
        "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
            "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
        ),
2    displaylogo = FALSE,
3        toImageButtonOptions = list(
            format = "svg",
            filename = "guerry_plot",
            height = NULL,
            width = NULL
        ),
4        scrollZoom = TRUE
    )

1

เลือกเอาปุ่มออกจาก modebar

2

เอา logo ออก

3

เซ็ตค่า height กับ width เป็น NULL เพื่อที่จะให้สัดส่นของกราฟหรือภาพเป็นตามที่โชว์ในapp

4

ให้ใช้ zooming ได้

Full ตัวเต็ม

Full code for interactive visualization

library(shiny)
library(htmltools)
library(bs4Dash)
library(shinyWidgets)
library(Guerry)
library(sf)
library(dplyr)
library(plotly)
library(GGally)
library(datawizard)

# 1 Data preparation ----

## Load & clean data ----
variable_names <- list(
  Crime_pers = "Crime against persons",  
  Crime_prop =  "Crime against property",  
  Literacy = "Literacy",  
  Donations = "Donations to the poor",  
  Infants = "Illegitimate births",  
  Suicides = "Suicides",  
  Wealth = "Tax / capita",  
  Commerce = "Commerce & Industry",  
  Clergy = "Clergy",  
  Crime_parents = "Crime against parents",  
  Infanticide = "Infanticides",  
  Donation_clergy = "Donations to the clergy",  
  Lottery = "Wager on Royal Lottery",  
  Desertion = "Military desertion",  
  Instruction = "Instruction",  
  Prostitutes = "Prostitutes",  
  Distance = "Distance to paris",  
  Area = "Area",  
  Pop1831 = "Population"
)

data_guerry <- Guerry::gfrance85 %>%
  st_as_sf() %>%
  as_tibble() %>%
  st_as_sf(crs = 27572) %>%
  mutate(Region = case_match(
    Region,
    "C" ~ "Central",
    "E" ~ "East",
    "N" ~ "North",
    "S" ~ "South",
    "W" ~ "West"
  )) %>%
  select(-c("COUNT", "dept", "AVE_ID_GEO", "CODE_DEPT")) %>%
  select(Region:Department, all_of(names(variable_names)))



## Prep data (Tab: Tabulate data) ----
data_guerry_tabulate <- data_guerry %>% 
  st_drop_geometry() %>% 
  mutate(across(.cols = all_of(names(variable_names)), round, 2))


## Prepare modebar clean-up ----
## Used for modelling
plotly_buttons <- c(
  "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
  "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
)



# 3 UI ----

ui <- dashboardPage(
  title = "The Guerry Dashboard",
  ## 3.1 Header ----
  header = dashboardHeader(
    title = tagList(
      img(src = "../workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
  ## 3.2 Sidebar ----
  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      menuItem(tabName = "tab_model", text = "Model data", icon = icon("chart-line")),
      flat = TRUE
    ),
    minified = TRUE,
    collapsed = TRUE,
    fixed = FALSE,
    skin = "light"
  ),
  ## 3.3 Body ----
  body = dashboardBody(
    tabItems(
      ### 3.1.1 Tab: Introduction ----
      tabItem(
        tabName = "tab_intro",
        jumbotron(
          title = "The Guerry Dashboard",
          lead = "A Shiny app to explore the classic Guerry dataset.",
          status = "info",
          btnName = NULL
        ),
        fluidRow(
          column(width = 1),
          column(
            width = 6,
            box(
              title = "About",
              status = "primary",
              width = 12,
              blockQuote(HTML("André-Michel Guerry was a French lawyer and
                          amateur statistician. Together with Adolphe
                          Quetelet he may be regarded as the founder of
                          moral statistics which led to the development
                          of criminology, sociology and ultimately,
                          modern social science. <br>— Wikipedia: <a href='https://en.wikipedia.org/wiki/Andr%C3%A9-Michel_Guerry'>André-Michel Guerry</a>"),
                         color = "primary"),
              p(HTML("Andre-Michel Guerry (1833) was the first to 
              systematically collect and analyze social data 
               on such things as crime, literacy and suicide 
               with the view to determining social laws and the 
               relations among these variables. The Guerry data 
               frame comprises a collection of 'moral variables' 
               (cf. <i><a href='https://en.wikipedia.org/wiki/Moral_statistics'>moral statistics</a></i>) 
               on the 86 departments of France around 1830. 
               A few additional variables have been added 
               from other sources. In total the data frame has 
               86 observations (the departments of France) on 23 variables <i>(Source: <code>?Guerry</code>)</i>. 
               In this app, we aim to explore Guerry’s data
                using spatial exploration and regression modelling.")),
              hr(),
              accordion(
                id = "accord",
                accordionItem(
                  title = "References",
                  status = "primary",
                  solidHeader = FALSE,
                  "The following sources are referenced in this app:",
                  tags$ul(
                    class = "list-style: none",
                    style = "margin-left: -30px;",
                    p("Angeville, A. (1836). Essai sur la Statistique de la Population française Paris: F. Doufour."),
                    p("Guerry, A.-M. (1833). Essai sur la statistique morale de la France Paris: Crochard. English translation: Hugh P. Whitt and Victor W. Reinking, Lewiston, N.Y. : Edwin Mellen Press, 2002."),
                    p("Parent-Duchatelet, A. (1836). De la prostitution dans la ville de Paris, 3rd ed, 1857, p. 32, 36"),
                    p("Palsky, G. (2008). Connections and exchanges in European thematic cartography. The case of 19th century choropleth maps. Belgeo 3-4, 413-426.")
                  )
                ),
                accordionItem(
                  title = "Details",
                  status = "primary",
                  solidHeader = FALSE,
                  p("This app was created as part of a Shiny workshop held in July 2023"),
                  p("Last update: June 2023"),
                  p("Further information about the data can be found",
                    a("here.", href = "https://www.datavis.ca/gallery/guerry/guerrydat.html"))
                )
              )
            )
          ),
          column(
            width = 4,
            box(
              title = "André Michel Guerry",
              status = "primary",
              width = 12,
              tags$img(src = "../guerry.jpg", width = "100%"),
              p("Source: Palsky (2008)")
            )
          )
        )
      ),
      ### 3.3.2 Tab: Tabulate data ----
      tabItem(
        tabName = "tab_tabulate",
        fluidRow(
          #### Inputs(s) ----
          pickerInput(
            "tab_tabulate_select",
            label = "Filter variables",
            choices = setNames(names(variable_names), variable_names),
            options = pickerOptions(
              actionsBox = TRUE,
              windowPadding = c(30, 0, 0, 0),
              liveSearch = TRUE,
              selectedTextFormat = "count",
              countSelectedText = "{0} variables selected",
              noneSelectedText = "No filters applied"
            ),
            inline = TRUE,
            multiple = TRUE
          )
        ),
        hr(),
        #### Output(s) (Data table) ----
        DT::dataTableOutput("tab_tabulate_table")
      ),
      ### 3.3.3 Tab: Model data ----
      tabItem(
        tabName = "tab_model",
        fluidRow(
          column(
            width = 6,
            #### Inputs(s) ----
            box(
              width = 12,
              title = "Select variables",
              status = "primary",
              selectInput(
                "model_x",
                label = "Select a dependent variable",
                choices = setNames(names(variable_names), variable_names),
                selected = "Literacy"
              ),
              selectizeInput(
                "model_y",
                label = "Select independent variables",
                choices = setNames(names(variable_names), variable_names),
                multiple = TRUE,
                selected = "Commerce"
              ),
              checkboxInput(
                "model_std",
                label = "Standardize variables?",
                value = TRUE
              ),
              hr(),
              actionButton(
                "refresh",
                label = "Apply changes",
                icon = icon("refresh"),
                flat = TRUE
              )
            )
          ),
          column(
            width = 6,
            ##### Box: Pair diagramm ----
            box(
              width = 12,
              title = "Pair diagram",
              status = "primary",
              plotly::plotlyOutput("pairplot")
            )
            # A fourth box can go here :)
          )
        )
      )
    ) # end tabItems
  ),
  
  ## 3.4 Footer (bottom)----
  footer = dashboardFooter(
    left = span(
      "This dashboard was created by Jonas Lieth and Paul Bauer. Find the source code",
      a("here.", href = "https://github.com/paulcbauer/shiny_workshop/tree/main/shinyapps/guerry"),
      "It is based on data from the",
      a("Guerry R package.", href = "https://cran.r-project.org/web/packages/Guerry/index.html")
    )
  ),
  ## 3.5 Controlbar (top)----
  controlbar = dashboardControlbar(
    div(class = "p-3", skinSelector()),
    skin = "light"
  )  
)



# 4 Server ----

server <- function(input, output, session) {
  
  ## 4.1 Tabulate data ----
  ### Variable selection ----
  tab <- reactive({
    var <- input$tab_tabulate_select
    data_table <- data_guerry_tabulate
    
    if (!is.null(var)) {
      data_table <- data_table[, var]
    }
    
    data_table
  })
  
  
  ### Create table----
  dt <- reactive({
    tab <- tab()
    ridx <- ifelse("Department" %in% names(tab), 3, 1)
    DT::datatable(
      tab,
      class = "hover",
      extensions = c("Buttons"),
      selection = "none",
      filter = list(position = "top", clear = FALSE),
      style = "bootstrap4",
      rownames = FALSE,
      options = list(
        dom = "Brtip",
        deferRender = TRUE,
        scroller = TRUE,
        buttons = list(
          list(extend = "copy", text = "Copy to clipboard"),
          list(extend = "pdf", text = "Save as PDF"),
          list(extend = "csv", text = "Save as CSV"),
          list(extend = "excel", text = "Save as JSON", action = DT::JS("
          function (e, dt, button, config) {
            var data = dt.buttons.exportData();
  
            $.fn.dataTable.fileSave(
              new Blob([JSON.stringify(data)]),
              'Shiny dashboard.json'
            );
          }
        "))
        )
      )
    )
  })
  
  ### Render table----
  output$tab_tabulate_table <- DT::renderDataTable(dt(), server = FALSE)
  
  
  
  ## 4.2 Model data ----
  ### Define & estimate model ----
  dat <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(data_guerry)[c(x, y)]
    if (input$model_std) dt <- datawizard::standardise(dt)
    
    dt
  }) %>%
    bindEvent(input$refresh, ignoreNULL = FALSE)
  
  ### Pair diagram ----
  output$pairplot <- plotly::renderPlotly({
    p <- GGally::ggpairs(dat(), axisLabels = "none")
    
    ggplotly(p) %>%
      config(
        modeBarButtonsToRemove = plotly_buttons,
        displaylogo = FALSE,
        toImageButtonOptions = list(
          format = "svg",
          filename = "guerry_plot",
          height = NULL,
          width = NULL
        ),
        scrollZoom = TRUE
      )
  })
}

shinyApp(ui, server)

Contextuality บริบท

• ด้วยความเป็นบริบท (contextuality), เราเข้าใจโดยคร่าวว่าเรารับรู้แผนภูมิในบริบท
• การแสดงแกราฟอย่างง่าย ๆ อาจเป็นสิ่งที่เพียงพอในการสื่อข้อความ
• แต่ในหลาย ๆ กรณี, เราต้องการภาพรวมมากกว่าหนึ่งเพื่อนำเสนอเรื่องราวหรือเน้นเรื่อง
• หลายครั้ง การมองภาพรวมอยู่ข้าง ๆ กันช่วยให้เราเข้าใจมากขึ้น
• การพล็อตแบบปกติ: สามารถมีการโต้ตอบและตอบสนองได้ แต่ ไม่มีความเป็นบริบท
• การพล็อตแบบฝัง: มีความเป็นบริบท แต่การโต้ตอบและตอบสนองนั้นเป็นไปได้ยาก (เช่น ในรายงานหรือบทความวิชาการ)

แนวปฏิบัติที่ดี

• ตัวติดตามรังผึ้งของ US จาก Appsilon ให้ความสะดวกในการเปรียบเทียบตัวเลขที่รวมกัน ระหว่างรัฐและภายในรัฐด้วยกัน
• ด้วยความคิดสร้างสรรค์เล็ก ๆ น้อย ๆ, Shiny สามารถเป็นผู้บรรยายเรื่องราวที่มีความสามารถอย่างมาก (สำหรับตัวอย่างที่น่าประทับใจ, ลองดูที่แอป Shiny ของ John Coene Freedom of Press Shiny app)

การขยายรูปแบบการแสดงผล

• เราจะขยายการแสดงผลที่เรามีอยู่ด้วยการวิเคราะห์การถดถอยเพื่ออธิบายเกี่ยวกับการเชื่อมโยงของตัวแปรตัวบ่งชี้ของ Guerry
• เราเพิ่มสามแบบของการแสดงผลภาพ: แผนภูมิแสดงค่าสัมประสิทธิ์, แผนภูมิกระจาย และตารางการถดถอย
• ทั้งสามแบบของการแสดงผลถูกใส่ไว้ใน tabBox bs4Dash::box ซึ่งรองรับ tab panels

model <- tabItem(
    "tab_model",
    fluidRow(
        column(
            width = 6,
            #### Box: Select variables ----
      box(
                width = 12,
                title = "Select variables",
                status = "primary",
                selectInput(
                    "model_x",
                    label = "Select a dependent variable",
                    choices = setNames(names(variable_names), variable_names),
                    selected = "Literacy"
                ),
                selectizeInput(
                    "model_y",
                    label = "Select independent variables",
                    choices = setNames(names(variable_names), variable_names),
                    multiple = TRUE,
                    selected = "Commerce"
                ),
                checkboxInput(
                    "model_std",
                    label = "Standardize variables?",
                    value = TRUE
                ),
                hr(),
                actionButton(
                    "refresh",
                    label = "Apply changes",
                    icon = icon("refresh"),
                    flat = TRUE
                )
            ),
      #### Box: Coefficient/Scatterplot ----
1            tabBox(
              status = "primary",
              width = 12,
2              type = "tabs",
              ##### Tab: Coefficient plot ----
3              tabPanel(
                title = "Plot: Coefficients",
                plotly::plotlyOutput("coefficientplot")
              ),
              ##### Tab: Scatterplot ----
4              tabPanel(
                title = "Plot: Scatterplot",
                plotly::plotlyOutput("scatterplot")
              ),
              ##### Tab: Table: Regression ----
5              tabPanel(
                title = "Table: Model",
                htmlOutput("tableregression")
              )
            )
        ),
        #### Box: Pair diagramm ----
        column(
            width = 6,
        box(
                width = 12,
                title = "Pair diagram",
                status = "primary",
                plotly::plotlyOutput("pairplot")
            )
        )
    )
)

1

เพิ่ม tabBox() ใหม่ซึ่งสามารถรองรับ tabPanel() หลายๆแท็บ

2

ระบุลักษณะการแสดงผลของแท็บ pills จะเติมสีให้กับทั้งหมดของแท็บแผงตามสถานะ ในขณะที่ tabs มีการเติมสีอย่างอ่อนโยนมากขึ้น

3

เพิ่มแท็บที่มีแผนภูมิแสดงค่าสัมประสิทธิ์จาก Plotly

4

เพิ่มแท็บที่มีแผนภูมิกระจายจาก Plotly

5

เพิ่มแท็บที่มีตารางการถดถอยแบบ HTML

การทำความเข้าใจรูปแบบใหม่

• คำถาม: เราได้เพิ่มอะไรบ้างในที่นี่ ผลลัพธ์ใดที่ต้องการเนื้อหาเพื่อแสดงผล
• ที่ฝั่งของserver เราขยาย reactive object ด้วยโมเดลการถดถอยแบบเชิงเส้น

1mparams <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(guerry)[c(x, y)]
    if (input$model_std) dt <- datawizard::standardise(dt)
2    form <- as.formula(paste(x, "~", paste(y, collapse = " + ")))
    mod <- lm(form, data = dt)

3    list(x = x, y = y, data = dt,   model = mod)
}) %>%
    bindEvent(input$refresh, ignoreNULL = FALSE)

1

เราเปลี่ยนชื่อ dat() เป็น mparams() เนื่องจากตอนนี้มันเก็บอาร์กิวเมนต์หลายตัว แทนที่จะเป็น dataframe เดียว

2

สร้างสูตรและสร้างผลลัพธ์จาก linear regression

3

ส่งคืนlistของอาร์กิวเมนต์เพื่อใช้สำหรับoutput

การสร้างผลลัพธ์ output

• ากขั้นตอนนี้เราสามารถนำmparamsซึ่งเป็น reactive object เข้าไปในฟังก์ชันการแสดงผลทั้งหมด

### Pair diagram ----
1output$pairplot <- renderPlotly({
    p <- GGally::ggpairs(mparams()$data, axisLabels = "none")
    ggplotly(p)
})

### Plot: Coefficientplot ----
2output$coefficientplot <- renderPlotly({
    params <- mparams()
    dt <- params$data
    x <- params$x
    y <- params$y

    p <- plot(parameters::model_parameters(params$model))

    ggplotly(p)
})

### Plot: Scatterplot ----
3output$scatterplot <- renderPlotly({
    params <- mparams()
    dt <- params$data
    dt_labels <- params$data_labels
    x <- params$x
    y <- params$y


    if (length(y) == 1) {
      p <- ggplot(params$data,
                  aes(x = .data[[params$x]],
                      y = .data[[params$y]])) +
        geom_point() +
        geom_smooth() +
        theme_light()
    } else {
      p <- ggplot() +
        theme_void() +
        annotate("text",
                 label = "Cannot create scatterplot.\nMore than two variables selected.",
                 x = 0, y = 0,
                 size = 5,
                 colour = "red",
                 hjust = 0.5,
                 vjust = 0.5) +
      xlab(NULL)

    }

    ggplotly(p)
})

### Table: Regression ----
4output$tableregression <- renderUI({
    params <- mparams()
    HTML(modelsummary(
        dvnames(list(params$model)),
      gof_omit = "AIC|BIC|Log|Adj|RMSE"
    ))
})

1

เราต้องเปลี่ยน input สำหรับ ggpairs() เนื่องจากชื่อและโครงสร้างของreactive objectมีการเปลี่ยนแปลง

2

สร้างแผนภูมิแสดงค่าสัมประสิทธิ์ของ Plotly โดยใช้แพ็คเกจ parameters

3

สร้างแผนภูมิกระจายของ Plotly สำหรับการถดถอยแบบสองตัวแปร หากเลือกตัวแปร y มากกว่าหนึ่งตัว จะสร้างแผนภูมิที่ว่างเปล่าและแสดงข้อความเตือน

4

สร้างตารางของโมเดลโดยใช้แพ็คเกจ modelsummary และเตรียมสำหรับการแสดงผลแบบ HTML

code ตัวเต็ม

Full code for contextual visualization

library(shiny)
library(htmltools)
library(bs4Dash)
library(shinyWidgets)
library(Guerry)
library(sf)
library(dplyr)
library(plotly)
library(ggplot2)
library(GGally)
library(datawizard)
library(parameters)
library(performance)
library(modelsummary)

# 1 Data preparation ----

## Load & clean data ----
variable_names <- list(
  Crime_pers = "Crime against persons",  
  Crime_prop =  "Crime against property",  
  Literacy = "Literacy",  
  Donations = "Donations to the poor",  
  Infants = "Illegitimate births",  
  Suicides = "Suicides",  
  Wealth = "Tax / capita",  
  Commerce = "Commerce & Industry",  
  Clergy = "Clergy",  
  Crime_parents = "Crime against parents",  
  Infanticide = "Infanticides",  
  Donation_clergy = "Donations to the clergy",  
  Lottery = "Wager on Royal Lottery",  
  Desertion = "Military desertion",  
  Instruction = "Instruction",  
  Prostitutes = "Prostitutes",  
  Distance = "Distance to paris",  
  Area = "Area",  
  Pop1831 = "Population"
)

data_guerry <- Guerry::gfrance85 %>%
  st_as_sf() %>%
  as_tibble() %>%
  st_as_sf(crs = 27572) %>%
  mutate(Region = case_match(
    Region,
    "C" ~ "Central",
    "E" ~ "East",
    "N" ~ "North",
    "S" ~ "South",
    "W" ~ "West"
  )) %>%
  select(-c("COUNT", "dept", "AVE_ID_GEO", "CODE_DEPT")) %>%
  select(Region:Department, all_of(names(variable_names)))



## Prep data (Tab: Tabulate data) ----
data_guerry_tabulate <- data_guerry %>% 
  st_drop_geometry() %>% 
  mutate(across(.cols = all_of(names(variable_names)), round, 2))


## Prepare modebar clean-up ----
## Used for modelling
plotly_buttons <- c(
  "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d",
  "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d"
)


# 3 UI ----

ui <- dashboardPage(
  title = "The Guerry Dashboard",
  ## 3.1 Header ----
  header = dashboardHeader(
    title = tagList(
      img(src = "../workshop-logo.png", width = 35, height = 35),
      span("The Guerry Dashboard", class = "brand-text")
    )
  ),
  ## 3.2 Sidebar ----
  sidebar = dashboardSidebar(
    id = "sidebar",
    sidebarMenu(
      id = "sidebarMenu",
      menuItem(tabName = "tab_intro", text = "Introduction", icon = icon("home")),
      menuItem(tabName = "tab_tabulate", text = "Tabulate data", icon = icon("table")),
      menuItem(tabName = "tab_model", text = "Model data", icon = icon("chart-line")),
      flat = TRUE
    ),
    minified = TRUE,
    collapsed = TRUE,
    fixed = FALSE,
    skin = "light"
  ),
  ## 3.3 Body ----
  body = dashboardBody(
    tabItems(
      ### 3.1.1 Tab: Introduction ----
      tabItem(
        tabName = "tab_intro",
        jumbotron(
          title = "The Guerry Dashboard",
          lead = "A Shiny app to explore the classic Guerry dataset.",
          status = "info",
          btnName = NULL
        ),
        fluidRow(
          column(width = 1),
          column(
            width = 6,
            box(
              title = "About",
              status = "primary",
              width = 12,
              blockQuote(HTML("André-Michel Guerry was a French lawyer and
                          amateur statistician. Together with Adolphe
                          Quetelet he may be regarded as the founder of
                          moral statistics which led to the development
                          of criminology, sociology and ultimately,
                          modern social science. <br>— Wikipedia: <a href='https://en.wikipedia.org/wiki/Andr%C3%A9-Michel_Guerry'>André-Michel Guerry</a>"),
                         color = "primary"),
              p(HTML("Andre-Michel Guerry (1833) was the first to 
              systematically collect and analyze social data 
               on such things as crime, literacy and suicide 
               with the view to determining social laws and the 
               relations among these variables. The Guerry data 
               frame comprises a collection of 'moral variables' 
               (cf. <i><a href='https://en.wikipedia.org/wiki/Moral_statistics'>moral statistics</a></i>) 
               on the 86 departments of France around 1830. 
               A few additional variables have been added 
               from other sources. In total the data frame has 
               86 observations (the departments of France) on 23 variables <i>(Source: <code>?Guerry</code>)</i>. 
               In this app, we aim to explore Guerry’s data
                using spatial exploration and regression modelling.")),
              hr(),
              accordion(
                id = "accord",
                accordionItem(
                  title = "References",
                  status = "primary",
                  solidHeader = FALSE,
                  "The following sources are referenced in this app:",
                  tags$ul(
                    class = "list-style: none",
                    style = "margin-left: -30px;",
                    p("Angeville, A. (1836). Essai sur la Statistique de la Population française Paris: F. Doufour."),
                    p("Guerry, A.-M. (1833). Essai sur la statistique morale de la France Paris: Crochard. English translation: Hugh P. Whitt and Victor W. Reinking, Lewiston, N.Y. : Edwin Mellen Press, 2002."),
                    p("Parent-Duchatelet, A. (1836). De la prostitution dans la ville de Paris, 3rd ed, 1857, p. 32, 36"),
                    p("Palsky, G. (2008). Connections and exchanges in European thematic cartography. The case of 19th century choropleth maps. Belgeo 3-4, 413-426.")
                  )
                ),
                accordionItem(
                  title = "Details",
                  status = "primary",
                  solidHeader = FALSE,
                  p("This app was created as part of a Shiny workshop held in July 2023"),
                  p("Last update: June 2023"),
                  p("Further information about the data can be found",
                    a("here.", href = "https://www.datavis.ca/gallery/guerry/guerrydat.html"))
                )
              )
            )
          ),
          column(
            width = 4,
            box(
              title = "André Michel Guerry",
              status = "primary",
              width = 12,
              tags$img(src = "../guerry.jpg", width = "100%"),
              p("Source: Palsky (2008)")
            )
          )
        )
      ),
      ### 3.3.2 Tab: Tabulate data ----
      tabItem(
        tabName = "tab_tabulate",
        fluidRow(
          #### Inputs(s) ----
          pickerInput(
            "tab_tabulate_select",
            label = "Filter variables",
            choices = setNames(names(variable_names), variable_names),
            options = pickerOptions(
              actionsBox = TRUE,
              windowPadding = c(30, 0, 0, 0),
              liveSearch = TRUE,
              selectedTextFormat = "count",
              countSelectedText = "{0} variables selected",
              noneSelectedText = "No filters applied"
            ),
            inline = TRUE,
            multiple = TRUE
          )
        ),
        hr(),
        #### Output(s) (Data table) ----
        DT::dataTableOutput("tab_tabulate_table")
      ),
      ### 3.3.3 Tab: Model data ----
      tabItem(
        tabName = "tab_model",
        fluidRow(
          column(
            width = 6,
            #### Inputs(s) ----
            box(
              width = 12,
              title = "Select variables",
              status = "primary",
              selectInput(
                "model_x",
                label = "Select a dependent variable",
                choices = setNames(names(variable_names), variable_names),
                selected = "Literacy"
              ),
              selectizeInput(
                "model_y",
                label = "Select independent variables",
                choices = setNames(names(variable_names), variable_names),
                multiple = TRUE,
                selected = "Commerce"
              ),
              checkboxInput(
                "model_std",
                label = "Standardize variables?",
                value = TRUE
              ),
              hr(),
              actionButton(
                "refresh",
                label = "Apply changes",
                icon = icon("refresh"),
                flat = TRUE
              )
            ),
            #### Outputs(s) ----
            tabBox(
              status = "primary",
              type = "tabs",
              title = "Model analysis",
              side = "right",
              width = 12,
              ##### Tabpanel: Coefficient plot ----
              tabPanel(
                title = "Plot: Coefficients",
                plotly::plotlyOutput("coefficientplot")
              ),
              ##### Tabpanel: Scatterplot ----
              tabPanel(
                title = "Plot: Scatterplot",
                plotly::plotlyOutput("scatterplot")
              ),
              ##### Tabpanel: Table: Regression ----
              tabPanel(
                title = "Table: Model",
                htmlOutput("tableregression")
              )
            )
          ),
          column(
            width = 6,
            ##### Box: Pair diagramm ----
            box(
              width = 12,
              title = "Pair diagram",
              status = "primary",
              plotly::plotlyOutput("pairplot")
            )
            # A fourth box can go here :)
          )
        )
      )
    ) # end tabItems
  ),
  
  ## 3.4 Footer (bottom)----
  footer = dashboardFooter(
    left = span(
      "This dashboard was created by Jonas Lieth and Paul Bauer. Find the source code",
      a("here.", href = "https://github.com/paulcbauer/shiny_workshop/tree/main/shinyapps/guerry"),
      "It is based on data from the",
      a("Guerry R package.", href = "https://cran.r-project.org/web/packages/Guerry/index.html")
    )
  ),
  ## 3.5 Controlbar (top)----
  controlbar = dashboardControlbar(
    div(class = "p-3", skinSelector()),
    skin = "light"
  )  
)



# 4 Server ----

server <- function(input, output, session) {
  
  ## 4.1 Tabulate data ----
  ### Variable selection ----
  tab <- reactive({
    var <- input$tab_tabulate_select
    data_table <- data_guerry_tabulate
    
    if (!is.null(var)) {
      data_table <- data_table[, var]
    }
    
    data_table
  })
  
  
  ### Create table----
  dt <- reactive({
    tab <- tab()
    ridx <- ifelse("Department" %in% names(tab), 3, 1)
    DT::datatable(
      tab,
      class = "hover",
      extensions = c("Buttons"),
      selection = "none",
      filter = list(position = "top", clear = FALSE),
      style = "bootstrap4",
      rownames = FALSE,
      options = list(
        dom = "Brtip",
        deferRender = TRUE,
        scroller = TRUE,
        buttons = list(
          list(extend = "copy", text = "Copy to clipboard"),
          list(extend = "pdf", text = "Save as PDF"),
          list(extend = "csv", text = "Save as CSV"),
          list(extend = "excel", text = "Save as JSON", action = DT::JS("
          function (e, dt, button, config) {
            var data = dt.buttons.exportData();
  
            $.fn.dataTable.fileSave(
              new Blob([JSON.stringify(data)]),
              'Shiny dashboard.json'
            );
          }
        "))
        )
      )
    )
  })
  
  ### Render table----
  output$tab_tabulate_table <- DT::renderDataTable(dt(), server = FALSE)
  
  
  
  ## 4.2 Model data ----
  ### Define & estimate model ----
  mparams <- reactive({
    x <- input$model_x
    y <- input$model_y
    dt <- sf::st_drop_geometry(data_guerry)[c(x, y)]
    dt_labels <- sf::st_drop_geometry(data_guerry)[c("Department", "Region")]
    if (input$model_std) dt <- datawizard::standardise(dt)
    form <- as.formula(paste(x, "~", paste(y, collapse = " + ")))
    mod <- lm(form, data = dt)
    
    list(
      x = x,
      y = y,
      data = dt,
      data_labels = dt_labels,
      model = mod
    )
  }) %>%
    bindEvent(input$refresh, ignoreNULL = FALSE)
  
  ### Pair diagram ----
  output$pairplot <- plotly::renderPlotly({
    params <- mparams()
    dt <- params$data
    dt_labels <- params$data_labels
    p <- GGally::ggpairs(params$data, axisLabels = "none")

    ggplotly(p) %>%
      config(modeBarButtonsToRemove = plotly_buttons,
             displaylogo = FALSE)
  })
  
  ### Plot: Coefficientplot ----
  output$coefficientplot <- renderPlotly({
    params <- mparams()
    dt <- params$data
    x <- params$x
    y <- params$y
    
    p <- plot(parameters::model_parameters(params$model))
    
    ggplotly(p) %>%
      config(modeBarButtonsToRemove = plotly_buttons,
             displaylogo = FALSE)
  })
  
  ### Plot: Scatterplot ----
  output$scatterplot <- renderPlotly({
    params <- mparams()
    dt <- params$data
    dt_labels <- params$data_labels
    x <- params$x 
    y <- params$y
    
    
    if (length(y) == 1) {
      p <- ggplot(params$data, 
                  aes(x = .data[[params$x]], 
                      y = .data[[params$y]])) +
        geom_point(aes(text = paste0("Department: ", 
                                     dt_labels[["Department"]],
                                     "<br>Region: ", 
                                     dt_labels[["Region"]])),
                   color = "black") +
        geom_smooth() + 
        geom_smooth(method = "lm") +
        theme_light()
    } else {
      p <- ggplot() +
        theme_void() +
        annotate("text", 
                 label = "Cannot create scatterplot.\nMore than two variables selected.", 
                 x = 0, y = 0, 
                 size = 5, 
                 colour = "red",
                 hjust = 0.5,
                 vjust = 0.5) +
        xlab(NULL)
      
    }
    
    ggplotly(p) %>%
      config(modeBarButtonsToRemove = plotly_buttons,
             displaylogo = FALSE)
  })
  
  ### Table: Regression ----
  output$tableregression <- renderUI({
    params <- mparams()
    HTML(modelsummary(
      dvnames(list(params$model)),
      gof_omit = "AIC|BIC|Log|Adj|RMSE"
    ))
  })
}

shinyApp(ui, server)

Exercises

แบบฝึกหัด 1

เมื่อคิดกลับไปยังโครงสร้างการแสดงผลเริ่มต้นของเรา (การเลือกข้อมูล, การสำรวจข้อมูล, การสร้างโมเดลข้อมูล, และอื่นๆ) ขั้นตอนสุดท้ายที่ดีควรจะเป็นอย่างไร แบบของการแสดงผลใดที่ช่วยให้เข้าใจเกี่ยวกับความสัมพันธ์ของตัวแปร Guerry โปรดเขียนความคิดเห็นของคุณพร้อมกับประเภทของการแสดงผลที่เป็นไปได้

Tip

ดู R graph gallery หรือ R Plotly gallery

แบบฝึกหัด 2

เพิ่มช่องที่สี่ในรูปแบบ dashboard และเพิ่มกล่องที่จะรองรับเนื้อหาด้วย.

Tip

อย่าลืมเกี่ยวกับการใช้ fluidRow() และ column() ช่องใหม่นี้จะต้องอยู่ด้านล่างของแผนภูมิคู่ในคอลัมน์ที่สอง:

fluidRow(
    column(
        width = 6,
        box(width = 12), # quadrant 1
        box(width = 12) # quadrant 3
    ),
    column(
        width = 6,
        box(width = 12), # quadrant 2
        box(width = 12) # quadrant 4
    )
)

คำตอบ

ช่องที่สี่คือแถวที่สองของคอลัมน์ที่สอง นั่นคือ:

fluidRow(
    column(
        width = 6,
        box(width = 12), # quadrant 1
        box(width = 12) # quadrant 3
    ),
    column(
        width = 6,
        box(width = 12), # quadrant 2
        box(width = 12, status = "primary", plotOutput("new_plot")) # quadrant 4
    )
)

แบบฝึกหัด 3

เพิ่ม UI สำหรับแสดงผลและฟังก์ชันการแสดงผลที่ว่างเปล่า

Tip

ฟังก์ชันของ Plotly ที่เกี่ยวข้องคือplotly::plotlyOutput() and plotly::renderPlotly()

แบบฝึกหัด 4

นำเสนอการแสดงผลจากแบบฝึกหัดที่ 1 ภายในกล่องใหม่จากแบบฝึกหัดที่ 2 สร้างแผนภูมิของคุณโดยใช้ ggplot2 และแปลงมันเป็นแผนภูมิ plotly โดยใช้ ggplotly()

แบแฝึกหัด 5

ลบปุ่มทั้งหมดในแถบโหมดยกเว้น “Zoom in” และ “Zoom out” ออกจากการแสดงผลใหม่ในแบบฝึกหัดที่ 4

Tip

คำสั่งที่เกี่ยวข้อง plotly::config()

A list of modebar buttons is provided on Plotly’s GitHub repository or under object -> layout -> layoutAttributes -> modebar -> remove

เรียกใช้ schema() และสำรวจใน object -> config เพื่อหาวิธีการลบปุ่มบนแถบโหมด

รายการของปุ่ม modebar มีให้ดูที่ GitHub repository ของ Plotly หรือภายใต้ object -> layout -> layoutAttributes -> modebar -> remove

Solution

เพื่อลบปุ่มบนแถบโหมด, เราต้องเปลี่ยน plotly::config() ของผลลัพธ์การแสดงผลที่ได้จากการสร้างแผนภูมิ:

ggplotly(p) %>%
  config(modeBarButtonsToRemove = c(
    "sendDataToCloud", "zoom2d", "select2d", "lasso2d", "autoScale2d", "toimage",
    "hoverClosestCartesian", "hoverCompareCartesian", "resetScale2d", "pan"
))

แบบฝึกหัด 6

เปลี่ยนความกว้างของแกนของแผนภูมิใหม่จากแบบฝึกหัดที่ 4 เป็น 5 พิกเซลและเปลี่ยนสีเป็น #000

Note

ฟังก์ชันที่เกี่ยวข้องคือ plotly::layout()

เรียกใช้ schema() และสำรวจใน object -> layout -> layoutAttributes เพื่อหาวิธีการเปลี่ยนแปลงการวางแกน

Solution

เพื่อเปลี่ยนความกว้างของแกน เราต้องเปลี่ยน plotly::layout() การกำหนดว่าตัวเลือกไหนควบคุมการวางแกนเป็นคำถามที่ยาก เพื่อทำเช่นนั้น, เราสามารถสำรวจ plotly::schema() ในกรณีนี้ ตัวเลือกที่เกี่ยวข้องจะพบได้ภายใต้ object -> layout -> layoutAttributes -> xaxis/yaxis -> linewidth/linecolor หลังจากนั้น, เพียงเพิ่ม layout ในวัตถุ plot และเปลี่ยนตัวเลือกที่เกี่ยวข้อง:

ggplotly(p) %>%
    layout(
      xaxis = list(linewidth = 5, linecolor = "#000"),
      yaxis = list(linewidth = 5, linecolor = "#000")
    )

แบบฝึกหัด 7

ตอนนี้รามีตัวinputsสามตัวที่มีผลกับการเปลี่ยนแปลงการแสดงผล: model_x model_y และ model_std การเพิ่มinputอีกตัวหนึ่งเพื่อให้ผู้ใช้สามารถจัดการข้อมูล ผลลัพธ์ หรือการแสดงผลของแผนภูมิได้

Tip

inputs ใหม่ควรจะเปลี่ยนแปลงแผนภูมิทั้งหมดหรือเพียงบางส่วนของแผนภูมิ ตัวinputใหม่ควรจะควบคุมวิธีที่ข้อมูลถูกclean (เช่น การทำnormalise) หรือวิเคราะห์ (เช่น วิธีการสร้างแบบจำลองที่แตกต่างกัน) หรือการแสดงผล (เช่น ธีมการแสดงผลแผนภูมิ) หรือไม่