I want to highlight all lines going to a node/marker on a map in mapview. In the example code here, the nodes represent capital cities. Upon hovering on one of the cities, I would like all 4 lines going to/from that city to become highlighted. The hover option inside mapview had no effect, when I tried it. Thanks.
library(dplyr)
library(readr)
library(janitor)
library(sp)
library(purrr)
cc = read_csv("http://techslides.com/demos/country-capitals.csv")
nodes =
cc %>%
clean_names() %>%
mutate(capital_latitude = as.numeric(capital_latitude)) %>%
select(capital_name, capital_longitude, capital_latitude) %>%
filter(capital_name %in% c("Warsaw", "El-Aaiún", "Jamestown", "Antananarivo", "Manama"))
edges =
full_join(
nodes %>% rename(from = capital_name, from_lon = capital_longitude, from_lat = capital_latitude) %>% mutate(index = 1),
nodes %>% rename(to = capital_name, to_lon = capital_longitude, to_lat = capital_latitude) %>% mutate(index = 1),
by = "index") %>%
mutate(from_to = paste(from, "_", to)) %>%
filter(from != to) %>%
select(-index) %>%
rowwise() %>%
mutate(capital_lines = pmap(list(from_lon = from_lon, from_lat = from_lat, to_lon = to_lon, to_lat = to_lat, from_to = from_to),
function(from_lon, from_lat, to_lon, to_lat, from_to) {
Line(cbind(c(from_lon, to_lon),
c(from_lat, to_lat))) %>%
Lines(., ID = from_to)}
)) %>%
mutate(capital_lines = list(SpatialLines(list(capital_lines))))
mapview(nodes, xcol = "capital_longitude", ycol = "capital_latitude") +
mapview(do.call(rbind, edges$capital_lines))
library(mapview)
mapviewOptions(fgb = FALSE)
mapview(shp, highlight = leaflet::highlightOptions(color = "red", weight = 2, sendToBack = TRUE))
This works for me.
See details in https://github.com/r-spatial/mapview/issues/392.
Related
So I'm trying to make cross tables for multi-response questions with both frequency and counts using expss. I am able to get the result I need by running the following code:
library(expss)
set.seed(1998)
expss_output_viewer()
# Example data set
x <- c("A","B","C")
area <- rep(x,each = 10)
p <- sample(c(0,1),30,replace = T)
q <- sample(c(0,1),30,replace = T)
r <- sample(c(0,1),30,replace = T)
mrdata <- data.frame(area,p,q,r)
# Creating the Table
mrdata %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(p,q,r)) %>%
tab_cells(area) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption("Table 1")
However, seeing as this is a lot of code for a single table, I wanted to wrap it into a function to be able to create the tables quickly and without much clutter. I've tried doing it like this:
mrtable <- function(input,rowvar,colvars,capt ="Table 1") {
input %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(colvars)) %>%
tab_cells(rowvar) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption(capt)
}
mrtable(input = mrdata,colvars = c(p,q,r),rowvar = area)
Running the function above returns:
Error: 'cro': all variables should be of the same length or length 1.
I can't figure out why it fails. Any help would be appreciated.
EDIT:
got it to work :
mrtable <- function(input,rowvar,...,capt ="Table 1") {
input %>%
tab_significance_options(keep = "none", sig_labels = NULL, subtable_marks = "greater", mode = "append") %>%
tab_cols(total(), mdset(...)) %>%
tab_cells(rowvar) %>%
tab_stat_cases(label = "cases") %>%
tab_stat_cpct_responses(label = "%",total_row_position = "none") %>%
tab_pivot(stat_position = "inside_columns") %>% set_caption(capt)
}
mrtable(input = mrdata,rowvar = area,p,q,r,capt = "Tab")
I am trying to use both hc_motion and hc_drilldown within a highcharter map.
I can manage to get the hc_motion working with the full map, and also a drilldown from a larger area to its smaller ones (UK Region to Local Authority in this instance).
However, after drilling-down and zooming back out again, the hc_motion is now frozen.
Why is this and is there anyway around it? Or are hc_motion and hc_drilldown not compatible?
While in this instance the drilldown is static, if it possible hc_motion within each drilldown would be ideal, although will no even bother trying if even a static can't be incorporated without affecting the hc_motion.
Anyway, example code is below, thanks!
region_lad_lookup = read_csv("https://opendata.arcgis.com/api/v3/datasets/6a41affae7e345a7b2b86602408ea8a2_0/downloads/data?format=csv&spatialRefId=4326") %>%
clean_names() %>%
select(
region_code = rgn21cd,
region_name = rgn21nm,
la_name = lad21nm,
la_code = lad21cd,
value = fid
) %>%
inner_join(
read_sf("https://opendata.arcgis.com/api/v3/datasets/21f7fb2d524b44c8ab9dd0f971c96bba_0/downloads/data?format=geojson&spatialRefId=4326") %>%
clean_names() %>%
filter(grepl("^E", lad21cd)) %>%
select(la_code = lad21cd),
by = "la_code"
)
region_map = read_sf("https://opendata.arcgis.com/api/v3/datasets/bafeb380d7e34f04a3cdf1628752d5c3_0/downloads/data?format=geojson&spatialRefId=4326") %>%
clean_names() %>%
select(
area_code = rgn18cd,
area_name = rgn18nm
) %>%
st_as_sf(crs = 27700) %>%
sf_geojson() %>%
fromJSON(simplifyVector = F)
year_vec = c(2015, 2016, 2017, 2018, 2019)
region_data = region_lad_lookup %>%
select(
area_code = region_code,
area_name = region_name
) %>%
distinct() %>%
crossing(year_vec) %>%
mutate(
value = runif(nrow(.)),
drilldown = tolower(area_name)
)
region_vec = region_data %>%
select(area_name) %>%
distinct() %>%
pull()
get_la_map = function(data, region_val){
data = data %>%
filter(region_name == region_val) %>%
select(
area_code = la_code,
area_name = la_name,
geometry
) %>%
st_as_sf(crs = 27700) %>%
sf_geojson() %>%
fromJSON(simplifyVector = F)
return(data)
}
get_la_data = function(data, region_val){
data = data %>%
filter(region_name == region_val) %>%
select(
area_name = la_name,
area_code = la_code,
value
)
return(data)
}
get_region_map_list = function(region_val){
output = list(
id = tolower(region_val),
data = list_parse(get_la_data(region_lad_lookup, region_val)),
mapData = get_la_map(region_lad_lookup, region_val),
name = region_val,
value = "value",
joinBy = "area_name"
)
return(output)
}
region_ds = region_data %>%
group_by(area_name) %>%
do(
item= list(
area_name = first(.$area_name),
sequence = .$value,
value = first(.$value),
drilldown = first(.$drilldown)
)
) %>%
.$item
highchart(type = "map") %>%
hc_add_series(
data = region_ds,
mapData = region_map,
value = "value",
joinBy = "area_name",
borderWidth = 0
) %>%
hc_colorAxis(
minColor = "lightblue",
maxColor = "red"
) %>%
hc_motion(
enabled = TRUE,
axisLabel = "year",
series = 0,
updateIterval = 200,
magnet = list(
round = "floor",
step = 0.1
)
) %>%
hc_drilldown(
allowPointDrilldown = TRUE,
series = lapply(region_vec, get_region_map_list)
)
I am mapping out zip code areas in leaflet and coloring the polygon based on the Dealer.
Dealer Zipcodes geometry
A 32505 list(list(c(.....)))
B 32505 ....
This code is used to create the colors, labels, and the map.
factpal <- colorFactor(topo.colors(5), data$Dealer)
labels <- paste0("Zip Code: ",data$Zipcodes, ", Dealer: ", data$Dealer)
leaflet(data) %>%
addTiles() %>%
addPolygons( color = ~factpal(Dealer),),
label = labels) %>%
leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright")
When the zip code (and thus the geometry) are the same between two dealers, only one label is visible, though it is clear colors are overlapping. All I want is for that label to somehow show the info for both dealers in that zip code. Please let me know if there is code missing you need, or clarification needed.
Not sure whether you could have multiple tooltips but to show all Dealers in the tooltip you could change your labels such that they include all dealer names per zip code, e.g. making use of dplyr you could do:
library(leaflet)
library(dplyr)
factpal <- colorFactor(topo.colors(5), data$Dealer)
data <- data %>%
group_by(Zipcodes) %>%
mutate(labels = paste(Dealer, collapse = ", "),
labels = paste0("Zip Code: ", Zipcodes, ", Dealer: ", labels))
leaflet(data) %>%
addTiles() %>%
addPolygons(
color = ~factpal(Dealer),
label = ~labels,
weight = 1
) %>%
# leaflet.extras::addSearchOSM(options = searchOptions(collapsed = FALSE)) %>%
addLegend(
pal = factpal, values = ~Dealer,
opacity = 0.7,
position = "bottomright"
)
DATA
nycounties <- rgdal::readOGR("https://eric.clst.org/assets/wiki/uploads/Stuff/gz_2010_us_050_00_20m.json")
nycounties_sf <- sf::st_as_sf(nycounties)
nycounties_sf_n <- nycounties_sf %>%
filter(STATE == "01") %>%
select(Zipcodes = COUNTY, geometry)
data <- list(
A = sample_n(nycounties_sf_n, 40),
B = sample_n(nycounties_sf_n, 40),
C = sample_n(nycounties_sf_n, 40),
D = sample_n(nycounties_sf_n, 40)
)
data <- purrr::imap(data, ~ mutate(.x, Dealer = .y))
data <- do.call("rbind", data)
I need to create table with same footnote being placed in both header and body of the table, I cannot figure out how to make it happen using flextable, what I can create is something as below:
library(flextable)
library(dplyr)
library(tidyr)
data(iris)
iris %>%
as_tibble %>%
gather(.,key = variable,value = value,-Species) %>%
group_by(Species,variable) %>%
summarise(value=formatC(mean(value),digits = 2,format = 'f')) %>%
ungroup %>%
spread(.,key = variable,value = value) %>%
flextable %>%
footnote(.,part = 'header',i = 1,j = c(2:5),
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
footnote(.,part = 'body',i = c(1:3),j = 1,
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE)
Currently I created two footnotes with the same statement for header and body, I wonder if I can merge the two statements into one.
Thanks!
(I did not imagine footnotes would be repeated when this function has been implemented but) by using merge_v, you can merge them if identical:
library(flextable)
library(dplyr)
library(tidyr)
data(iris)
iris %>%
as_tibble %>%
gather(.,key = variable,value = value,-Species) %>%
group_by(Species,variable) %>%
summarise(value=formatC(mean(value),digits = 2,format = 'f')) %>%
ungroup %>%
spread(.,key = variable,value = value) %>%
flextable %>%
footnote(.,part = 'header',i = 1,j = c(2:5),
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
footnote(.,part = 'body',i = c(1:3),j = 1,
value = as_paragraph(c('Rounded to two decimal places')),
ref_symbols = c('*'),
inline=FALSE) %>%
merge_v(part = "footer")
This is code for a sankey diagram made with networkd3. I've had success with Sankeys before - I'm aiming to create something like this https://susan-wilson.shinyapps.io/2016FederalElectionPreferences/ (although it will be a little more wild because of the nature of the Senate preference system), but I can't work out what my issue is. The code runs without error and then I get a blank viewer.
The Source and Target nodes are zero indexed, and they are consecutive integers. I know that I could have just imported ACT, but this is just an interim test and I plan to use the whole data set later. This code is only a toy example and doesn't plot all the preference flows either.
I'm pretty sure I'm just making a dumb mistake, but I'd be super grateful if someone could point it out to me.
library(tidyverse)
library(data.table)
library(networkD3)
rm(list = ls())
#Download the data from here: https://results.aec.gov.au/20499/Website/External/SenateDopDownload-20499.zip
files <- list.files("~whereveryousavedit/SenateDopDownload-20499", pattern = ".csv", full.names = T)
SenatePreferences <- lapply(files, fread)
SenatePreferences <- rbindlist(SenatePreferences)
ACT <- SenatePreferences %>%
filter(State == "ACT")
# one node for each politician, while they're still in.
ACT <- ACT %>%
mutate(NameNode = paste(Surname, GivenNm, Count),
Name = paste(Surname, GivenNm)) %>%
group_by(Name) %>%
mutate(Status= case_when(
Status %>% lag() == "Excluded" ~ "Excluded in a previous round",
Status %>% lag() == "Excluded in a previous round" ~ "Excluded in a previous round",
TRUE ~ Status)) %>%
ungroup() %>%
filter(Status !="Excluded in a previous round") %>%
mutate(Node = c(0:(n()-1)))
# For each count i, the source is the round i node, the target is the equivalent node in round 2.
ACT <- ACT %>%
mutate(Source = Node) %>%
group_by(Name) %>%
mutate(Target = Source %>% lead()) %>%
ungroup() %>%
filter(!is.na(Target))
ACT_Sankey <- list(Nodes = ACT %>%
select(NameNode) %>% data.frame(),
Links = ACT %>%
select(Source, Target, VoteTransferred, Name) %>% data.frame()
)
sankeyNetwork(Links = ACT_Sankey$Links , Nodes = ACT_Sankey$Nodes, Source = 'Source',
Target = 'Target', Value = 'VoteTransferred', NodeID = 'NameNode',LinkGroup = 'Name',
fontSize = 12)
here's a working version of what you seem to be trying to do with your code above, though I doubt the result is what you actually want to do...
library(tidyverse)
library(networkD3)
url <- "https://results.aec.gov.au/20499/Website/External/SenateDopDownload-20499.zip"
mytempfile <- tempfile(fileext = ".zip")
download.file(url = url, destfile = mytempfile)
mytempdir <- tempdir()
unzip(mytempfile, exdir = mytempdir)
unlink(mytempfile)
SenatePreferences <-
list.files(mytempdir, pattern = ".csv", full.names = TRUE) %>%
map_dfr(read_csv)
unlink(mytempdir, recursive = TRUE)
cleaned <-
SenatePreferences %>%
as_tibble() %>%
filter(State == "ACT") %>%
filter(!Surname %in% c("Exhausted", "Gain/Loss")) %>%
mutate(Name = paste(Surname, GivenNm)) %>%
mutate(NameNode = paste(Name, Count)) %>%
select(NameNode, Name, Ticket, round = Count, Status, VoteTransferred) %>%
group_by(Name) %>%
arrange(round) %>%
filter(row_number() <= min(which(Status == "Excluded" | row_number() == n()))) %>%
ungroup() %>%
mutate(Node = row_number() - 1)
links <-
cleaned %>%
mutate(Source = Node) %>%
group_by(Name) %>%
mutate(Target = Source %>% lead()) %>%
ungroup() %>%
filter(!is.na(Source) & !is.na(Target)) %>%
select(Source, Target, Name, VoteTransferred)
nodes <-
cleaned %>%
select(NameNode, Name, Node)
sankeyNetwork(Links = links, Nodes = nodes, Source = 'Source',
Target = 'Target', Value = 'VoteTransferred', NodeID = 'NameNode',
LinkGroup = 'Name', fontSize = 12)