链接单击以获取 Plotly R 中的地图

Linked Click for maps in Plotly R

数据:

https://www.kaggle.com/wood2174/mapkickstarter

所以我有一张地图,我正在制作闪亮且有情节的地图,我喜欢点击一个州,然后拉出该州以获取该州各县的信息。好吧,我在 plotly 中看到了其他链接的绘图示例,但我不确定如何以这种方式设置我的地图。这是我点击之前的情节。

这是我在 iv 单击某个州后的地图:

我很确定我没有使用 event_data 参数在两者之间以正确的方式传递参数。 我传递的参数将是州的名称,并且该名称将作为字符输入到我称为 CT 的函数中以调用州名称,以便我可以从单击的州找到县数据,另一个, data 和 pop 是传递给函数的另外两个数据帧。 这是 shiny server 之外的功能,它会生成交互式悬停图:

代码:

ui <- fluidPage(mainPanel(
  navbarPage(
    "Kickstarter",
    navbarMenu(
      "Maps",
      tabPanel("US Map", plotlyOutput(
        "plotMap", height = 900, width = 1200
      )),
      tabPanel("County Map",
               plotlyOutput("Smap"),
               plotlyOutput("Cmap"))
    ),
    tabPanel(
      "Interaction",
      plotlyOutput("plotInt", height = 900, width = 1200)
    ),
    navbarMenu(
      "Barplots",
      tabPanel("Citys", plotlyOutput(
        "plotBar1", height = 900, width = 1200
      )),
      tabPanel(
        "Catigories",
        plotlyOutput("plotBar2", height = 900, width = 1200)
      )
    )
  )
))


     server <- function(input, output, session) {
  #add reactive data information. Dataset = built in diamonds data
  H <- read_csv("C:/Users/clint/Documents/R/Personal work/Masters Project/MasterKickstarter.csv")
  M <- read_csv("C:/Users/clint/Documents/R/Personal work/Masters Project/data sets/Mapping.csv")
  C <- read_csv("C:/Users/clint/Documents/R/Personal work/Masters Project/data sets/County.csv")

  H <- as.data.frame(H)
  M <- as.data.frame(M)
  C <- as.data.frame(C)

  ### Plotting top twenty citys for a kick ###
  # calculate frequencies
  tab <- table(H$City)
  # sort
  tab_s <- sort(tab)
  # extract 10 most frequent nationalities
  top10 <- tail(names(tab_s), 25)
  # subset of data frame
  d_s <- subset(H, City %in% top10)
  # order factor levels
  d_s$City <- factor(d_s$City, levels = rev(top10))

  #function for capitalization
  simpleCap <- function(x) {
    s <- strsplit(x, " ")[[1]]
    paste(toupper(substring(s, 1, 1)),
          substring(s, 2),
          sep = "",
          collapse = " ")
  }



  M$code <- state.abb[match(M$State, state.name)]

  #making temp sets that fit for interactive maps
  H = H[!duplicated(H[, "City"], fromLast = T), ]
  H$State <- sapply(as.character(H$State), simpleCap)
  H$code <- state.abb[match(H$State, state.name)]

  H$City <- factor(H$City)

  #making quartiles for plotting size
  H$q <-
    with(H, cut(All_Time_Backers_city, quantile(All_Time_Backers_city)))
  levels(H$q) <-
    paste(c("1st", "2nd", "3rd", "4th", "5th"), "Quantile")
  H$q <- as.ordered(H$q)


  CT <- function(r,data,pop){

    cali <- map_data("county") %>%
      filter(region == r)

    cali_pop <- left_join(cali, pop, by = c("subregion","region"))

    cali_pop$pop_cat <- with(cali_pop,
                             (paste0(cali_pop$subregion, "<br />",
                                     round(cali_pop$MedianBackers), "Median Backers ||",round(cali_pop$MedianUSD),"MedianUSD","<br />",
                                     round(cali_pop$MeanBackers), "Mean Backers ||",round(cali_pop$MeanUSD),"MeanUSD","<br />",
                                     (cali_pop$TotalBackers), "Total Backers ||",(cali_pop$TotalUSD), "TotalUSD")))
    cali_pop[is.na(cali_pop)] <- 0
    cali_pop$pop_cat <- as.factor(cali_pop$pop_cat)

    p <- cali_pop %>%
      group_by(group) %>%
      plot_ly(x = ~long, y = ~lat, color = ~pop_cat, colors = c('#ffeda0','#f03b20')) %>%
      add_polygons(line = list(width = 0.4),showlegend = FALSE) %>%
      add_polygons(
        fillcolor = 'transparent',
        line = list(color = 'black', width = 0.5),
        showlegend = FALSE
      ) %>%
      layout(
        title = "Backers by County",
        titlefont = list(size = 10),
        xaxis = list(title = "", showgrid = FALSE,
                     zeroline = FALSE, showticklabels = FALSE),
        yaxis = list(title = "", showgrid = FALSE,
                     zeroline = FALSE, showticklabels = FALSE)
      )
    p

  }  

  output$Smap <- renderPlotly({
    M$hover <- with(M, paste(State))
    # give state boundaries a white border
    l <- list(color = toRGB("white"), width = 2)
    # specify some map projection/options
    g <- list(
      scope = 'north america',
      showland = TRUE,
      landcolor = toRGB("grey83"),
      subunitcolor = toRGB("white"),
      countrycolor = toRGB("white"),
      showlakes = TRUE,
      lakecolor = toRGB("white"),
      showsubunits = TRUE,
      showcountries = TRUE,
      resolution = 50,
      projection = list(type = 'conic conformal',
                        rotation = list(lon = -100)),
      lonaxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(-140,-55),
        dtick = 5
      ),
      lataxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(15, 70),
        dtick = 5
      )
    )

    # Plotting a US interactive map
    p <- plot_geo(source = "CCM") %>%
      add_trace(M,
        z = ~ M$`Mean Bakers`,
        text = ~ M$hover,
        x = ~M$State,
        locations = ~ M$code,
        locationmode = "USA-states"
      ) %>%
      colorbar(title = "Money") %>%
      layout(
        title = 'Kickstarter USA',
        geo = g
      )
    p
  })

  output$Cmap <- renderPlotly({
    s <- event_data("plotly_click", source = "CCM")

    if (length(s)){

      var <- s[["x"]]
      d <- setNames(M[var], "x")
      CT(d,H,C)
    }
  })

  output$plotBar1 <- renderPlotly({
    p1 <- d_s %>% count(City, status) %>%
      plot_ly(x = ~ City,
              y = ~ n,
              color = ~ status)
    p1

  })

  output$plotBar2 <- renderPlotly({
      p2 <- H %>% count(Categories, status) %>%
        plot_ly(x = ~ Categories,
                y = ~ n,
                color = ~ status)

      p2
    })

  output$plotMap <- renderPlotly({
    #preparing the hover text
    M$hover <- with(
      M,
      paste(
        State,
        '<br>',
        "Pledges_total",
        M$`Total Pledged`,
        "Backers_total",
        M$`Total Backers`,
        "<br>",
        "Mean_pledges",
        M$`Mean Campaign USD`,
        "Mean_backers",
        M$`Mean Bakers`,
        "<br>",
        "Median Goal %",
        M$`Median Percent of Goal`,
        "Number of projects",
        M$`Projects Per`
      )
    )

    g <- list(
      scope = 'north america',
      showland = TRUE,
      landcolor = toRGB("grey83"),
      subunitcolor = toRGB("white"),
      countrycolor = toRGB("white"),
      showlakes = TRUE,
      lakecolor = toRGB("white"),
      showsubunits = TRUE,
      showcountries = TRUE,
      resolution = 50,
      projection = list(type = 'conic conformal',
                        rotation = list(lon = -100)),
      lonaxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(-140,-55),
        dtick = 5
      ),
      lataxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(15, 70),
        dtick = 5
      )
    )

    #plotting an interactive map for states and cities
    p <- plot_geo(H, sizes = c(5, 250)) %>%
      add_markers(
        x = ~ H$Longitude,
        y = ~ H$Latitude,
        size = ~ H$All_Time_Backers_city,
        color = ~ q,
        text = ~ paste(H$City, "<br />",
                       H$All_Time_Backers_city, "Backers")
      ) %>%
      add_trace(M,
                z = ~ M$`Mean Campaign USD`,
                text = ~ M$hover,
                locations = ~ M$code
                ,
                locationmode = "USA-states"
      ) %>%
      layout(title = 'Backers City All Time', geo = g)
    p

  })

  output$plotInt <- renderPlotly({
    p <- H %>%
      plot_ly() %>%
      add_trace(
        type = 'parcoords',
        line = list(
          color = ~ backers_count,
          colorscale = 'Jet',
          showscale = TRUE,
          reversescale = TRUE,
          cmin = 2,
          cmax = 1500
        ),
        dimensions = list(
          list(
            range = c(0, 92),
            constrantrange = c(0, 30),
            label = 'Time',
            values = ~ Length_of_kick
          ),
          list(
            range = c(0, 2000),
            constraintrange = c(0, 1000),
            label = 'Pledge USD',
            values = ~ Pledge_per_person
          ),
          list(
            range = c(0, 8000000),
            constrantrange = c(0, 3000000),
            label = 'Population',
            values = ~ MasterKickstarter$City_Pop
          ),
          list(
            range = c(0, 1600),
            constraintrange = c(0, 500),
            label = 'Days Making',
            values = ~ Days_spent_making_campign
          ),
          list(
            tickvals = c(1, 2, 3, 4, 5),
            ticktext = c('cancled', 'failed', 'live', 'successful', 'suspended'),
            label = 'Status',
            values = ~ as.integer(as.factor(status))
          ),
          list(
            range = c(0, 1000000),
            constraintrange = c(0, 300000),
            label = 'Goal',
            values = ~ goal
          ),
          list(
            tickvals = c(1, 2, 3, 4, 5, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15),
            ticktext = c(
              'art',
              'comics',
              'crafts',
              'dance',
              'design',
              'fasion',
              'film',
              'food',
              'games',
              'journalism',
              'music',
              'photogaphy',
              'publishing',
              'technology',
              'theator'
            ),
            label = 'Catigories',
            values = ~ as.integer(as.factor(Categories))
          ),
          list(
            range = c( ~ min(Prct_goal), 1200),
            constraintrange = c(0, 500),
            label = 'Prct goal',
            values = ~ Prct_goal
          )
        )
      )
    p
  })

}

shinyApp(ui, server)

所以我有一种蛮力方法来解决这个问题。我在下面发布了使这项工作有效的三个更新功能。我发现在制作等值线时,每个州都分配了一个点号而不是名称,所以我使用 if 循环为每个点号分配适当的名称。然后该名称能够传递给函数,现在给我所需的输出。

这是我点击纽约的时候,这适用于点击的任何州。

修改三个函数代码:

   CT <- function(r,data,pop){

    cali <- map_data("county") %>%
      filter(region == r)

    cali_pop <- left_join(cali, pop, by = c("subregion","region"))

    cali_pop$pop_cat <- with(cali_pop,
                             (paste0(cali_pop$subregion, "<br />",
                                     round(cali_pop$MedianBackers), "Median Backers ||",round(cali_pop$MedianUSD),"MedianUSD","<br />",
                                     round(cali_pop$MeanBackers), "Mean Backers ||",round(cali_pop$MeanUSD),"MeanUSD","<br />",
                                     (cali_pop$TotalBackers), "Total Backers ||",(cali_pop$TotalUSD), "TotalUSD")))
    cali_pop[is.na(cali_pop)] <- 0
    cali_pop$pop_cat <- as.factor(cali_pop$pop_cat)



    p <- cali_pop %>%
      group_by(group) %>%
      plot_ly(x = ~long, y = ~lat, color = ~as.factor(TotalUSD), colors = c('#ffeda0','#f03b20'), text = ~pop_cat) %>%
      add_polygons(line = list(width = 0.4),showlegend = FALSE) %>%
      add_polygons(
        fillcolor = 'transparent',
        line = list(color = 'black', width = 0.5),
        showlegend = FALSE
      ) %>%
      layout(
        title = "Backers by County",
        titlefont = list(size = 10),
        xaxis = list(title = "", showgrid = FALSE,
                     zeroline = FALSE, showticklabels = FALSE),
        yaxis = list(title = "", showgrid = FALSE,
                     zeroline = FALSE, showticklabels = FALSE)
      )
    p

  }  

  output$Smap <- renderPlotly({
    M$hover <- with(M, paste("State:",State))
    # give state boundaries a white border
    l <- list(color = toRGB("white"), width = 2)
    # specify some map projection/options
    g <- list(
      scope = 'usa',
      showland = TRUE,
      landcolor = toRGB("grey83"),
      subunitcolor = toRGB("white"),
      countrycolor = toRGB("white"),
      showlakes = TRUE,
      lakecolor = toRGB("white"),
      showsubunits = TRUE,
      showcountries = TRUE,
      resolution = 50,
      projection = list(type = 'albers usa',
                        rotation = list(lon = -100)),
      lonaxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(-140,-55),
        dtick = 5
      ),
      lataxis = list(
        showgrid = TRUE,
        gridwidth = 0.5,
        range = c(15, 70),
        dtick = 5
      )
    )

    # Plotting a US interactive map
    p <- plot_ly(M,source = "CCM",
        z = ~ M$`Mean Bakers`,
        text = ~ M$hover,
        type = 'choropleth',
        locations = ~ M$code,
        locationmode = "USA-states"
      ) %>%
      colorbar(title = "Money") %>%
      layout(
        title = 'Kickstarter USA',
        geo = g
      )
    p
  })

  output$Cmap <- renderPlotly({
    s <- event_data("plotly_click", source = "CCM")

    if(s$pointNumber == 4) {
      d = "colorado"
    }
    if(s$pointNumber == 3) {
      d = "california"
    }
    if(s$pointNumber == 43) {
      d = "utah"
    }
    if(s$pointNumber == 26) {
      d = "nevada"
    }
    if(s$pointNumber == 43) {
      d = "utah"
    }
    if(s$pointNumber == 1) {
      d = "arizona"
    }
    if(s$pointNumber == 36) {
      d = "oregon"
    }
    if(s$pointNumber == 46) {
      d = "washington"
    }
    if(s$pointNumber == 10) {
      d = "idaho"
    }
    if(s$pointNumber == 24) {
      d = "montana"
    }
    if(s$pointNumber == 49) {
      d = "wyoming"
    }
    if(s$pointNumber == 29) {
      d = "new mexico"
    }
    if(s$pointNumber == 42) {
      d = "texas"
    }
    if(s$pointNumber == 35) {
      d = "oklahoma"
    }
    if(s$pointNumber == 14) {
      d = "kansas"
    }
    if(s$pointNumber == 25) {
      d = "nebraska"
    }
    if(s$pointNumber == 40) {
      d = "south dakota"
    }
    if(s$pointNumber == 33) {
      d = "north dakota"
    }
    if(s$pointNumber == 21) {
      d = "minnestota"
    }
    if(s$pointNumber == 13) {
      d = "iowa"
    }
    if(s$pointNumber == 23) {
      d = "missouri"
    }
    if(s$pointNumber == 2) {
      d = "arkansas"
    }
    if(s$pointNumber == 16) {
      d = "louisiana"
    }
    if(s$pointNumber == 48) {
      d = "wisconsin"
    }
    if(s$pointNumber == 11) {
      d = "illinois"
    }
    if(s$pointNumber == 12) {
      d = "indiana"
    }
    if(s$pointNumber == 20) {
      d = "michigan"
    }
    if(s$pointNumber == 34) {
      d = "ohio"
    }
    if(s$pointNumber == 37) {
      d = "pennsylvania"
    }
    if(s$pointNumber == 30) {
      d = "new york"
    }
    if(s$pointNumber == 44) {
      d = "vermont"
    }
    if(s$pointNumber == 27) {
      d = "new hampshire"
    }
    if(s$pointNumber == 17) {
      d = "maine"
    }
    if(s$pointNumber == 19) {
      d = "massachusetts"
    }
    if(s$pointNumber == 38) {
      d = "road island"
    }
    if(s$pointNumber == 5) {
      d = "connecticut"
    }
    if(s$pointNumber == 28) {
      d = "new jersey"
    }
    if(s$pointNumber == 6) {
      d = "delaware"
    }
    if(s$pointNumber == 18) {
      d = "maryland"
    }
    if(s$pointNumber == 47) {
      d = "west virginia"
    }
    if(s$pointNumber == 45) {
      d = "virginia"
    }
    if(s$pointNumber == 15) {
      d = "kentucky"
    }
    if(s$pointNumber == 41) {
      d = "tennessee"
    }
    if(s$pointNumber == 32) {
      d = "north carolina"
    }
    if(s$pointNumber == 39) {
      d = "south carolina"
    }
    if(s$pointNumber == 9) {
      d = "georgia"
    }
    if(s$pointNumber == 8) {
      d = "florida"
    }
    if(s$pointNumber == 0) {
      d = "alabama"
    }
    if(s$pointNumber == 22) {
      d = "mississippi"
    }
    else {
      plotly_empty()
    }

    CT(d,H,C)

  })