This was from a tutorial on html widgets using visNetwork on linkedin.com/learning.
library("tidyverse")## -- Attaching packages ------------------------------------------------------------- tidyverse 1.3.0 --## <U+2713> ggplot2 3.2.1 <U+2713> purrr 0.3.3
## <U+2713> tibble 2.1.3 <U+2713> dplyr 0.8.3
## <U+2713> tidyr 1.0.0 <U+2713> stringr 1.4.0
## <U+2713> readr 1.3.1 <U+2713> forcats 0.4.0## -- Conflicts ---------------------------------------------------------------- tidyverse_conflicts() --
## x dplyr::filter() masks stats::filter()
## x dplyr::lag() masks stats::lag()library('visNetwork')## Warning: package 'visNetwork' was built under R version 3.6.3transport_data <- read_csv("transport_data.csv")## Parsed with column specification:
## cols(
## sender.country = col_character(),
## sender.city = col_character(),
## sender.state = col_character(),
## sender.latitude = col_double(),
## sender.longitude = col_double(),
## receiver.country = col_character(),
## receiver.city = col_character(),
## receiver.state = col_character(),
## receiver.latitude = col_double(),
## receiver.longitude = col_double(),
## date = col_date(format = ""),
## number.of.items = col_double(),
## percent.of.all.items = col_double()
## )colnames(transport_data)## [1] "sender.country" "sender.city" "sender.state"
## [4] "sender.latitude" "sender.longitude" "receiver.country"
## [7] "receiver.city" "receiver.state" "receiver.latitude"
## [10] "receiver.longitude" "date" "number.of.items"
## [13] "percent.of.all.items"dim(transport_data)## [1] 399 13Create the nodes data table.Two columns created for send location and receive location of the country, city, and state pasted together as one value. The data and number of items columns are removed, and the unique observations returned.
nodes_intermediate <- transport_data %>%
mutate(send.location = paste(sender.country, sender.city, sender.state)) %>%
mutate(receive.location = paste(receiver.country, receiver.city, receiver.state)) %>%
select(-date,-number.of.items) %>%
unique()
colnames(nodes_intermediate)## [1] "sender.country" "sender.city" "sender.state"
## [4] "sender.latitude" "sender.longitude" "receiver.country"
## [7] "receiver.city" "receiver.state" "receiver.latitude"
## [10] "receiver.longitude" "percent.of.all.items" "send.location"
## [13] "receive.location"dim(nodes_intermediate)## [1] 392 13There are seven less observations in the nodes data table than the transport data table.
These are the nodes for the send location. This separate table extracts only the send columns of the intermediary table.
send_nodes <- nodes_intermediate %>%
select(contains("send"))
colnames(send_nodes) <-
c("country", "city", "state", "latitude", "longitude", "location")
dim(send_nodes)## [1] 392 6head(send_nodes)## # A tibble: 6 x 6
## country city state latitude longitude location
## <chr> <chr> <chr> <dbl> <dbl> <chr>
## 1 USA Orange NJ 33.8 -118. USA Orange NJ
## 2 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OH
## 3 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OH
## 4 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OH
## 5 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OH
## 6 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OHThis table is the receive table of nodes for the receive columns in the intermediary table.
receive_nodes <- nodes_intermediate %>%
select(contains("receive"))
colnames(receive_nodes) <-
c("country", "city", "state", "latitude", "longitude", "location")
dim(receive_nodes)## [1] 392 6head(receive_nodes)## # A tibble: 6 x 6
## country city state latitude longitude location
## <chr> <chr> <chr> <dbl> <dbl> <chr>
## 1 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburg
## 2 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburg
## 3 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburg
## 4 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburg
## 5 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburg
## 6 DEU Ribnitz Mecklenburg 54.3 12.4 DEU Ribnitz Mecklenburgnodes <- full_join(send_nodes, receive_nodes) %>%
unique()## Joining, by = c("country", "city", "state", "latitude", "longitude", "location")dim(nodes)## [1] 85 6head(nodes)## # A tibble: 6 x 6
## country city state latitude longitude location
## <chr> <chr> <chr> <dbl> <dbl> <chr>
## 1 USA Orange NJ 33.8 -118. USA Orange NJ
## 2 USA Cincinnati OH 39.1 -84.5 USA Cincinnati OH
## 3 USA Newport KY 39.1 -84.5 USA Newport KY
## 4 USA Oskaloosa IA 41.3 -92.6 USA Oskaloosa IA
## 5 USA Warsaw IL 40.4 -91.4 USA Warsaw IL
## 6 USA Koekuk IA? 40.4 -91.4 USA Koekuk IA?write_csv(nodes, "nodes.csv")The next data table is the edges data table.
edges <- transport_data %>%
mutate(send.location = paste(sender.country, sender.city, sender.state)) %>%
mutate(receive.location = paste(receiver.country, receiver.city, receiver.state)) %>%
select(send.location, receive.location, date, number.of.items)
dim(edges)## [1] 399 4head(edges)## # A tibble: 6 x 4
## send.location receive.location date number.of.items
## <chr> <chr> <date> <dbl>
## 1 USA Orange NJ DEU Ribnitz Mecklenburg 1884-07-12 352
## 2 USA Cincinnati OH DEU Ribnitz Mecklenburg 1862-12-24 308
## 3 USA Cincinnati OH DEU Ribnitz Mecklenburg 1869-12-15 365
## 4 USA Cincinnati OH DEU Ribnitz Mecklenburg 1862-12-24 542
## 5 USA Cincinnati OH DEU Ribnitz Mecklenburg 1864-11-13 452
## 6 USA Cincinnati OH DEU Ribnitz Mecklenburg 1869-12-15 512This counts all the counts of receive and send locations. It groups the send and receive locations together, then counts the number of repeats as weight and the total items in each count summing up to the value in total.items. Then those columns selected, the send and receive location are then ungrouped, and unique observations are kept for the table of edges.
edges <- edges %>%
group_by(send.location, receive.location) %>%
mutate(total.items = sum(number.of.items)) %>%
mutate(weight = n()) %>%
select(total.items, weight) %>%
ungroup() %>%
unique()## Adding missing grouping variables: `send.location`, `receive.location`dim(edges)## [1] 77 4head(edges)## # A tibble: 6 x 4
## send.location receive.location total.items weight
## <chr> <chr> <dbl> <int>
## 1 USA Orange NJ DEU Ribnitz Mecklenburg 352 1
## 2 USA Cincinnati OH DEU Ribnitz Mecklenburg 4916 12
## 3 USA Newport KY DEU Ribnitz Mecklenburg 2695 6
## 4 USA Oskaloosa IA DEU Ribnitz Mecklenburg 12925 32
## 5 USA Warsaw IL DEU Ribnitz Mecklenburg 2985 7
## 6 USA Koekuk IA? DEU Ribnitz Mecklenburg 814 2write_csv(edges, "edges.csv")nodes1 <- nodes %>%
mutate(id=as.factor(row_number()), label = as.factor(location)) %>%
select(id, everything())
plyr::mapvalues(edges$send.location,
from = nodes1$label,
to = nodes1$id)## The following `from` values were not present in `x`: USA Orange NJ, USA New York NY, DEU Ribnitz Mecklenburg, DEU Nienhagen Mecklenburg, DEU Neubrunn TH, DEU Limbach SA, DEU Roda TH, DEU Apolda TH, DEU Leisnig SA, DEU Mühlhausen TH, USA Texas various places, DEU Remptendorf TH## [1] "1" "2" "3" "4" "5" "6" "7" "8" "9" "10" "11" "12" "13" "14" "15"
## [16] "16" "17" "18" "14" "19" "20" "21" "22" "23" "24" "12" "25" "26" "27" "28"
## [31] "29" "30" "31" "32" "33" "34" "35" "36" "37" "38" "39" "40" "41" "42" "43"
## [46] "44" "45" "46" "47" "48" "49" "50" "51" "52" "53" "54" "55" "56" "57" "58"
## [61] "12" "59" "60" "1" "62" "63" "64" "65" "66" "67" "68" "69" "71" "72" "73"
## [76] "74" "75"edges1 <- edges %>%
mutate(from = plyr::mapvalues(send.location,
from = nodes1$label,
to = nodes1$id)) %>%
mutate(to = plyr::mapvalues(receive.location,
from = nodes1$label,
to = nodes1$id)) %>%
select(from, to, everything())## The following `from` values were not present in `x`: USA Orange NJ, USA New York NY, DEU Ribnitz Mecklenburg, DEU Nienhagen Mecklenburg, DEU Neubrunn TH, DEU Limbach SA, DEU Roda TH, DEU Apolda TH, DEU Leisnig SA, DEU Mühlhausen TH, USA Texas various places, DEU Remptendorf TH## The following `from` values were not present in `x`: USA Orange NJ, USA Cincinnati OH, USA Newport KY, USA Oskaloosa IA, USA Warsaw IL, USA Koekuk IA?, USA Maisfeld near Oskaloosa, USA Monroe MI, USA Tonawanda NY, USA Oak Grove WI, USA Edwardsville IL, USA Williamsburg NY, USA San Francisco CA, USA Union Hill NY, USA Sonoma CA, USA Waterloo WI, USA Amherst, Portage Co. WI, USA Minneapolis MN, DEU Gräfenthal TH, USA Austin TX, USA Brenham TX, DEU Leipzig SA, USA Oliverea NY, USA Trenton NJ, DEU Erfurt TH, USA Perry OK, USA Shamrock OK, USA Midford OK, USA Wellington KS, USA Rochester NY, USA Pittsburgh PN, USA Brownfield TX, USA Plainview TX, USA Lubbock TX, USA Sweetwater TX, USA Spur TX, USA Haskell TX, USA Lamesa TX, USA Big Spring TX, USA Seymour TX, USA Guanah TX, USA Perryto TX, USA Burlington CO, USA Stratton CO, USA Ozona TX, USA Seminole TX, USA Cleveland OH, USA Covington KY, USA Ohio OH, USA O. Folly Island SC, USA Fernandina FL, USA Jacksonville FL, USA St. Augustine FL, USA Blue Ridge Summit PA, USA Chicago IL, USA Orange NJ, USA Warrensville OH, USA Ann Arbor MI, USA Homer OH, USA Wilmington Delaware, USA Columbus OH, USA Wood Ridge NJ, USA Jersey City NJ, USA Princeton NJ, USA New York NY, USA Port Cester NY, USA Rutherford NJ, DEU Sebnitz S, USA Lime Ridge WIMost of this was taken from the tutorial on visNetworks as htmlwidgets, but the settings are in the help window pane describing the attributes and functions to add onto visNetwork() for more functionality when interacting with the node network displayed.
nodes1 <- as.data.frame(nodes1)
nodes1 <- nodes1 %>% select(id,label, everything())
edges1 <- as.data.frame(edges1)
edges1$label <- as.factor(edges1$send.location)
edges1 <- edges1 %>% select(from,to,label,everything())
edges1$width <- edges1$weight/4
visNetwork(nodes=nodes1, edges=edges1, main='Transportation Data HTML widgets Tutorial Linked in Learning') %>% visEdges(arrows=c('to','from','middle')) %>%
visInteraction(navigationButtons=TRUE, dragNodes=FALSE,
dragView=TRUE, zoomView = TRUE) %>%
visOptions(nodesIdSelection = TRUE, manipulation=FALSE)