In SVA-SE/svamp: Tools for support in outbreak management and suspicion investigation
farms_RT90 <- report_data_object()$result$farms_RT90
ppn <- report_data_object()$ppn
outbreak <- farms_RT90[farms_RT90@data$Ppn %in% ppn,]
if(any(!ppn %in% farms_RT90@data$Ppn)) {
paste ("WARNING: PPNs", c(ppn[!ppn %in% farms_RT90@data$Ppn]), "have no coordinates.They will be excluded from this report. Run a separate report providing coordinates for the above mentioned PPNs")
}
if(all(!farms_RT90@data$Ppn %in% ppn)) { # copy this error message in report.R
stop ("WARNING: All provided PPNs have no coordinates. Run a separate report providing coordinates for invesitgated PPNs")
}
1. GEOGRAPHIC LOCATION
1.1 OUTBREAKS MAP with PPNs under investigation
outbreak1 <- outbreak[ , c("Ppn", "Species", "Kommun")]
outbreak1_wgs <- spTransform(outbreak1, CRS("+init=epsg:4326"))
pop_out <- paste0("<b>", "PPN: ", "</b>", outbreak1_wgs@data$Ppn, "<br>",
"<b>", "Djurslag: ","</b>", outbreak1_wgs@data$Species, "<br>",
"<b>", "Kommun: ", "</b>", outbreak1_wgs@data$Kommun)
box <- as.vector(outbreak1_wgs@bbox)
if(length(ppn) == 1) {
LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
setView(outbreak1_wgs@coords[1], outbreak1_wgs@coords[2], zoom = 9)
} else {
LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
fitBounds(box[1], box[2], box[3], box[4])
}
LeafletMap1 %>%
addCircleMarkers(data = outbreak1_wgs,
radius = 5,
stroke = TRUE,
color = "black",
weight = 2,
fillColor = "red",
fillOpacity = 1,
popup = pop_out,
group = "PPNs") %>%
addLayersControl(
baseGroups = c("OSM", "CartoDB", "Toner Lite"),
overlayGroups = "PPNs",
options = layersControlOptions(collapsed = FALSE)) %>%
addLegend("bottomright",
values = outbreak1_wgs@data$Ppn,
colors = "red",
labels = "Investigated PPNs",
opacity = 1)
1.2 ADDRESS
location <- data.frame("PPN " = as.factor(outbreak@data$Ppn),
"Lan" = toupper(outbreak@data$Lan),
"Kommun" = toupper(outbreak@data$Kommun),
"Adress" = toupper(outbreak@data$Adress),
"Postadr." = toupper(outbreak@data$Postadress),
"Postnr." = toupper(outbreak@data$Postnummer),
"Fastighetsbet." = toupper(outbreak@data$Fastighetsbeteckning))
location <- unique(location)
datatable(location, rownames = FALSE, filter='top', options = list(pageLength = 3))
2. OWNERS INFORMATION
PPN <- report_data_object()$result$PPN
outbreak_no_sp <- PPN[PPN$Ppn %in% ppn,]
owners <- length(unique(outbreak_no_sp$Namn))
The number of owners/reference persons for the PPNs under investigation is: r owners
outbreak_own <- outbreak_no_sp
outbreak_own <- outbreak_own[c("Ppn",
"Namn",
"Adress.1",
"Postadress.1",
"Telefonnummer.1",
"Mobilnummer",
"Typ.2",
"Epost")]
colnames(outbreak_own) <- c("Ppn.",
"Namn",
"Adress.",
"Postadr.",
"Telefonnum.",
"Mobilnum.",
"Typ.",
"Epost")
outbreak_own <- unique(outbreak_own[,c("Ppn.",
"Namn",
"Adress.",
"Postadr.",
"Telefonnum.",
"Mobilnum.",
"Epost",
"Typ.")])
col_names <- names(outbreak_own)
outbreak_own[, col_names] <- lapply(outbreak_own[, col_names] , factor)
datatable(outbreak_own, filter='top', rownames =FALSE,
escape = FALSE, options = list(pageLength = 3))
3. NUMBER OF HERDS AND ANIMALS (for the investigated PPN)
outb_in_PPN <- PPN[PPN$Ppn %in% outbreak@data$Ppn, ]
outb_in_PPN <- outb_in_PPN [c("Ppn",
"Species",
"Typ",
"tot_anim")]
outb_in_PPN <- outb_in_PPN[!duplicated(outb_in_PPN [c("Ppn",
"Species",
"Typ",
"tot_anim")]),]
outb_in_PPN2 <- outb_in_PPN
outb_in_PPN$Ppn <- as.factor(outb_in_PPN$Ppn)
outb_in_PPN <- split(outb_in_PPN,
factor(outb_in_PPN$Ppn,
levels=rev(levels(outb_in_PPN$Ppn))),
drop = TRUE)
plot_herds <- function(outb_in_PPN) {
counts <- table(outb_in_PPN$Typ)
# Draw the graph with herds/animals count for the outbreak
par(mfrow = c(1,2),
mar=c(5.8, 4.8, 4.1, 2.1),
mgp=c(3.8, 1, 0),
las=2)
width = ifelse(length(counts) == 1, 0.2, 0.8) #avoid big bar drawing when length=1
b1a <- barplot(counts,
main = paste0("Number of herds by species (PPN ",
unique(outb_in_PPN$Ppn),")"),
ylab = "Number of herds",
xlim = c(0, length(counts)),
ylim = c(0, max(counts * 1.4)),
width = width)
text(x = b1a, y = counts, label = counts,
pos = 3, cex = 0.8, col = "black")
if (all(is.na(outb_in_PPN$tot_anim))) {
counts2 <- 0
b1b <- barplot(counts2,
main = paste0("Number of animal by species (PPN ",
unique(outb_in_PPN$Ppn),")"),
axes = FALSE,
xaxt = "n",
xlab = "",
ylab = "",
col = "white",
border = NA,
sub = "Number of animals is NA for this PPN. See table below")
} else {
outb_in_PPN <- outb_in_PPN [!is.na(outb_in_PPN$tot_anim),]
counts2 <-tapply(outb_in_PPN$tot_anim,
INDEX = outb_in_PPN$Typ,
FUN = sum)
width = ifelse(length(counts2) == 1, 0.2, 0.8)
b1b <- barplot(counts2,
main = paste0("Number of animal by species (PPN ",
unique(outb_in_PPN$Ppn),")"),
ylab = "Number of animals",
ylim = c(0, max(counts2 * 1.4)),
xlim = c(0, length(counts2)),
width = width)
text(x = b1b, y = counts2, label = counts2,
pos = 3, cex = 0.8, col = "black")
}
}
invisible(lapply(outb_in_PPN, plot_herds))
if (any(is.na(outbreak_no_sp$tot_anim))) {
cat("<br>", "<br>", "**OBS. Some information about number of animals are missing (blank or NA).
Check the table below for complete information**", "<br>", "<br>")
}
col_names <- names(outb_in_PPN2)
outb_in_PPN2[, col_names] <- lapply(outb_in_PPN2[, col_names] , factor)
datatable(outb_in_PPN2, filter='top', rownames =FALSE,
escape = FALSE, options = list(pageLength = 3))
4. VETERINARY DISTRICTS INFORMATION
district_geo_RT90 <- report_data_object()$result$district_geo_RT90
# calculate euclidean distance from outbreak to vet disctrict
dist_vet <- sapply(1:nrow(outbreak), function(i)
spDistsN1(as.matrix(district_geo_RT90@coords),
as.matrix(outbreak@coords[i, 1:2]),
longlat=F)/1000)
dist_vet <- round(dist_vet, 0)
colnames(dist_vet) <- as.character(outbreak@data$Ppn)
dist_vet <- as.data.frame(dist_vet)
vet_list <- list()
for (i in 1:ncol(dist_vet)) {
vet_list[[i]] <- cbind(dist_vet[,i], district_geo_RT90@data[, 2:6])
names(vet_list[[i]]) <- c("Distans", names(district_geo_RT90@data[, 2:6]))
names(vet_list) <- names(dist_vet)[1:i]
}
for (i in 1:length(vet_list)) {
vet_list[[i]] <- vet_list[[i]][order(vet_list[[i]][1]),]
}
out = NULL
for (j in 1:length(vet_list)) {
g <- paste("<br>", "<br>", "**Veterinary districts most closest to PPN** ", names(vet_list[j]), "<br>", "<br>")
knit_expanded <- paste0("\n```r\n\ndatatable(vet_list[[", j, "]], rownames =FALSE, escape = FALSE, options = list(pageLength = 3))\n\n```")
out = c(out, g, knit_expanded)
}
r paste(knit(text = out), collapse = '\n')
5. RESTRICTION ZONES
buffer_size <- buffer_size[order(buffer_size, decreasing = FALSE)]
buffer <- buffer_ppn(outbreak, buffer_size)
proj4string(buffer) <- CRS("+init=epsg:3021")
buffer_sp <- hole(buffer, buffer_size)
buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:3021"))
if(all(is.na(over(farms_RT90, buffer_sp)))) {
farms_in_buffers <- outbreak1
} else {
check_in_buffers <- over(farms_RT90, buffer_sp)
farms_in_buffers <- farms_RT90[buffer_sp, c("Ppn",
"Species",
"Kommun",
"Adress",
"Postadress")]
farms_in_buffers@data$buffer <- check_in_buffers$buffer[
row.names(check_in_buffers) %in% row.names(farms_in_buffers)]
}
There is a total of r if(!identical(farms_in_buffers, outbreak)){sum(nrow(farms_in_buffers@data))}else{"0"} PPNs within the selected buffer zones. The table below reports the number of PPNs in each buffer zone.
ppn_zone_sum <- data.frame(table(farms_in_buffers@data$buffer))
colnames(ppn_zone_sum) <- c("Buffer_zone", "PPN (tot.)")
ppn_zone_sum <- ppn_zone_sum[rev(order(ppn_zone_sum$Buffer_zone)), ]
datatable(ppn_zone_sum,
rownames =FALSE,
escape = FALSE,
options = list(columnDefs = list(
list(className = 'dt-center',
targets = c(0,1)))
))
6. SUMMARY STATISTICS FOR ANIMALS WITHIN RESTICTION ZONES
#duplicated PPN records for total herds/farms/animal calculation
# if(!identical(farms_in_buffers, outbreak1)) {
n_PPN_buffers <- PPN[which(PPN$Ppn %in% farms_in_buffers@data$Ppn),]
n_PPN_buffers$buffer <- farms_in_buffers@data$buffer[
match(n_PPN_buffers$Ppn, farms_in_buffers@data$Ppn)]
#}
sum_anim <- function(n.PPN.in) {
n.anim <- n.PPN.in[,c("Antal",
"Antalslaktplatser",
"Antalsuggplatser",
"CDB.Antal",
"Maxkapacitet")]
ani_sum <- rowSums (n.anim, na.rm = T)
n.PPN.in <- cbind (n.PPN.in, ani_sum)
return (n.PPN.in)
}
# if(!identical(n_PPN_buffers, outbreak1)) {
n.PPN.in1 <- sum_anim(n_PPN_buffers)
# }
# Exclusion of duplicated values when Djurhållare == DJURINNEHAVARE (to sum properly)
# if(!identical(farms_in1_RT90,outbreak1)) {
n.PPN.in1 <- n.PPN.in1[!duplicated(n.PPN.in1[c("Ppn",
"Adress",
"Typ",
"tot_anim")]),]
# }
b <- split(n.PPN.in1,
factor(n.PPN.in1$buffer, levels=rev(levels(n.PPN.in1$buffer))),
drop = TRUE)
#if(!identical(farms_in1_RT90, outbreak1)) {
plot_graph <- function(list_df) {
counts <- table(list_df$Typ)
counts2 <-tapply(list_df$ani_sum,
INDEX = list_df$Typ,
FUN=sum)
width = ifelse(length(counts) == 1, 0.2, 0.6)
par(mfrow = c(1,2), las = 2)
b1a <- barplot(counts,
main = paste("Number of herds by species (buffer",
unique(list_df$buffer), "km)"),
cex.main = 0.9,
ylab = "Number of herds",
ylim = c(0, max(counts * 1.4)),
xlim = c(0, length(counts)),
width = width)
text(x = b1a, y = counts, label = counts,
pos = 3, cex = 0.8, col = "black")
b1b <- barplot(counts2,
main = paste("Number of animals by species (buffer",
unique(list_df$buffer), "km)"),
cex.main = 0.9,
ylab = "Number of animals",
ylim = c(0, max(counts2 * 1.4)),
xlim = c(0, length(counts2)),
width = width)
text(x = b1b, y = counts2, label = counts2,
pos = 3, cex = 0.8, col = "black")
return(NULL)
}
invisible(lapply(b, plot_graph))
# } else {
#
# cat("* **No PPNs other than the investigated PPN within the Restriction zones**")
# }
7. LIST OF PPNs WITHIN RESTICTION ZONES
#Calculate distance matrix to assign farms to outbreaks farm
if (length(ppn) > 1) {
dm_farms_in1 <- DistMatrix(farms_in_buffers, longlat = FALSE, outbreak)
dm_farms_in1 <- as.data.frame(t(dm_farms_in1))
outbreak_ppn <- as.character(outbreak@data$Ppn)
farms_ppn <- as.character(farms_in_buffers@data$Ppn)
min_dist <- apply(dm_farms_in1[, 1:length(outbreak_ppn)], 1, min)
dm_farms_in1$near_out <- NULL
for(i in 1:length(farms_ppn)) {
dm_farms_in1$near_out[i] <- outbreak_ppn[
which(dm_farms_in1[i, 1:ncol(dm_farms_in1)] == min_dist[i])]
}
farms_in_buffers2 <- farms_in_buffers@data
farms_in_buffers2 <- data.frame(farms_in_buffers2, nearest = as.factor(dm_farms_in1$near_out))
} else {
farms_in_buffers2 <- farms_in_buffers@data
farms_in_buffers2 <- data.frame(farms_in_buffers2, nearest = as.factor(ppn))
}
# farms_in_buffers <- spTransform(farms_in_buffers, CRS("+init=epsg:3021")) #??????
col_names <- names(farms_in_buffers2)
farms_in_buffers2[, col_names] <- lapply(farms_in_buffers2[, col_names] , factor)
farms <- split(farms_in_buffers2,
factor(farms_in_buffers2$buffer,
levels=rev(levels(farms_in_buffers2$buffer))),
drop = TRUE)
farms <- lapply(farms, function(x) {
x["buffer"] <- NULL; x }
)
out2 = NULL
for (k in 1:length(farms)) {
g2 <- paste0("<br>", "**7a. LIST OF PPNs WITHIN BUFFER **", names(farms[k]), "km", "<br>", "<br>")
knit_expanded2 <- paste0("\n```r\n\ndatatable(farms[[", k, "]], escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```")
out2 = c(out2, g2, knit_expanded2)
}
r paste(knit(text = out2), collapse = '\n')
PPNs WITHIN RESTRICTION ZONES MAP
# CRS transformation
buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:4326"))
farms_in_buffers <- spTransform(farms_in_buffers, CRS("+init=epsg:4326"))
outbreak2 <- spTransform(outbreak1, CRS("+init=epsg:4326"))
# Set palette and popups for Leaflet map
if(length(as.numeric(buffer_sp@data$buffer)) == 1) {
pal <- colorNumeric(
palette = c("#d7191c"),
domain = as.numeric(farms_in_buffers@data$buffer))
pal2 <- colorFactor(
palette = c("#d7191c"),
domain = as.numeric(buffer_sp@data$buffer))
}
if(length(as.numeric(buffer_sp@data$buffer)) == 2) {
pal <- colorNumeric(
palette = c("#ffffbf", "#d7191c"),
domain = as.numeric(farms_in_buffers@data$buffer))
pal2 <- colorFactor(
palette = c("#ffffbf", "#d7191c"),
domain = as.numeric(buffer_sp@data$buffer))
}
if(length(as.numeric(buffer_sp@data$buffer)) >= 3) {
pal <- colorNumeric(
palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"),
domain = as.numeric(farms_in_buffers@data$buffer))
pal2 <- colorFactor(
palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"),
domain = as.numeric(buffer_sp@data$buffer))
}
popups <- paste("Buffer", as.character(buffer_sp@data$buffer),"km")
popups2 <- popups2 <- paste(sep = "<br/>",
"<b>PPN</b>", farms_in_buffers@data$Ppn,
"<b>Adress</b>", farms_in_buffers@data$Adress,
"<b>Species</b>",farms_in_buffers@data$Species)
box2 <- as.vector(buffer_sp@bbox)
# Draw the map
LeafletMap2 <- leaflet() %>% addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
fitBounds(box2[1], box2[2], box2[3], box2[4])
LeafletMap2 %>%
addPolygons(data = buffer_sp,
fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)),
stroke = TRUE,
weight = 0.5,
color = "black",
fillOpacity = 0.3,
group = "Buffers",
popup = popups) %>%
addCircleMarkers(data = farms_in_buffers,
stroke= TRUE,
color="black",
weight=2,
radius=3,
fill = TRUE,
fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)),
fillOpacity = 1,
group = "PPNs",
popup = popups2) %>%
addCircleMarkers(data = outbreak1_wgs,
radius = 3,
stroke = TRUE,
color = "black",
weight = 2,
fillColor = "black",
fillOpacity = 1,
popup = pop_out,
group = "Outbreak") %>%
addLayersControl(
baseGroups = c("OSM", "CartoDB", "Toner Lite"),
overlayGroups = c("Buffers", "PPNs", "Outbreak"),
options = layersControlOptions(collapsed = TRUE)) %>%
addLegend("bottomright",
values = buffer_sp@data$buffer,
pal = pal2,
labels = buffer_sp@data$buffer,
labFormat = labelFormat(prefix = "Buffer ",
suffix = "km"),
opacity = 1) %>%
addLegend("bottomright",
colors = "black",
labels = "Outbreak",
opacity = 1)
8. NUMBER OF ANIMALS OF PPNs WITHIN RESTRICTION ZONES
n_anim_rz <- PPN[PPN$Ppn %in% farms_in_buffers2$Ppn, ]
farms_in_buffers3 <- farms_in_buffers2[, c("Ppn", "buffer", "nearest")]
n_anim_rz <- merge(n_anim_rz, farms_in_buffers3, by = "Ppn")
n_anim_rz <- n_anim_rz[c("Ppn", "Species", "Typ", "tot_anim", "buffer", "nearest")]
n_anim_rz <- n_anim_rz[!duplicated(n_anim_rz),]
colnames(n_anim_rz) <- c("Ppn",
"Species",
"Typ",
"Antal",
"buffer",
"near_out")
col_names <- names(n_anim_rz)[c(1, 2, 4, 5)]
n_anim_rz[, col_names] <- lapply(n_anim_rz[, col_names] , factor)
n_anim_rz <- split(n_anim_rz,
factor(n_anim_rz$buffer,
levels=rev(levels(n_anim_rz$buffer))),
drop = TRUE)
n_anim_rz <- lapply(n_anim_rz, function(x) {
x["buffer"] <- NULL; x }
)
out3 = NULL
for (l in 1:length(n_anim_rz)) {
g3 <- paste0("<br>", "**8a. PPNs' NUMBER OF ANIMALS WITHIN BUFFER **", names(n_anim_rz[l]), "km", "<br>", "<br>")
knit_expanded3 <- paste0("\n```r\n\ndatatable(n_anim_rz[[", l, "]], filter='top', escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```")
out3 = c(out3, g3, knit_expanded3)
}
r paste(knit(text = out3), collapse = '\n')
9. OWNERS OF PPNs WITHIN RESTRICTION ZONES
n_anim_own_rz <- PPN[PPN$Ppn %in% farms_in_buffers2$Ppn, ]
farms_in_buffers4 <- farms_in_buffers2[, c("Ppn", "buffer", "nearest")]
n_anim_own_rz <- merge(n_anim_own_rz, farms_in_buffers4, by = "Ppn")
n_anim_own_rz <- n_anim_own_rz[,c("Ppn","Namn","Adress.1","Telefonnummer.1",
"Mobilnummer", "Epost", "buffer", "nearest")]
n_anim_own_rz <- n_anim_own_rz[!duplicated(n_anim_own_rz),]
colnames(n_anim_own_rz) <- c("Ppn","Namn", "Adress","Telefon", "Mobil",
"Epost", "buffer", "near_out")
col_names <- names(n_anim_own_rz)
n_anim_own_rz[, col_names] <- lapply(n_anim_own_rz[, col_names] , factor)
n_anim_own_rz <- split(n_anim_own_rz,
factor(n_anim_own_rz$buffer,
levels=rev(levels(n_anim_own_rz$buffer))),
drop = TRUE)
n_anim_own_rz <- lapply(n_anim_own_rz, function(x) {
x["buffer"] <- NULL; x }
)
out4 = NULL
for (h in 1:length(n_anim_own_rz)) {
g4 <- paste0("<br>", "**9a. OWNERS OF PPNs WITHIN BUFFER** ", names(n_anim_own_rz[h]), "km", "<br>", "<br>")
knit_expanded4 <- paste0("\n```r\n\ndatatable(n_anim_own_rz[[", h, "]], escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```")
out4 = c(out4, g4, knit_expanded4)
}
r paste(knit(text = out4), collapse = '\n')
10. ANALYSIS OF CONTACTS (EpiContactTrace)
The analysis covers the last r report_data_object()$days days from the date of report generation (r Sys.Date()).
The most recent movements reported into the database are from r unique(max(report_data_object()$result$ani_move$t)).
Run your own contact analysis setting different parameters (click the link)
OBS! Animal movement data may be reported to Jordbruksverket as late as 7 days after a movement has occured
library(EpiContactTrace)
transfers <- report_data_object()$result$ani_move
days <- report_data_object()$days
outbreak <- outbreak@data$Ppn
# Perform contact tracing
temp <- tempfile()
contactTrace <- Trace(movements = transfers,
root = outbreak,
tEnd = Sys.Date(),
days = days)
show(contactTrace)
11. MISSING COORDINATES
buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:3021")) #FIX THE NAME NOT DUPLICATES!
postnum_miss <- report_data_object()$result$postnum_miss
postnum_not_miss <- report_data_object()$result$postnum_not_miss # LEAFLET MAP?
PPN_is.na <- report_data_object()$result$PPN_is.na
if (!all(is.na(over(postnum_miss, buffer_sp)))) {
intersec_km <- postnum_miss[buffer_sp, ]
intersec_km <- spTransform(intersec_km, CRS("+init=epsg:4326"))
# match postnummer with postnummer of PPN is.na
PPN_pro_km <- PPN_is.na[PPN_is.na$Postnummer %in%
intersec_km@data$POSTALCODE, ]
intersec_km_test <- exists("intersec_km")
} else {
if (!all(is.na(over(postnum_miss, buffer_sp)))) {
intersec_km_test <- exists("intersec_km")
intersec_km_NM <- postnum_not_miss[buffer_sp,]
intersec_km_NM <- spTransform(intersec_km_NM, CRS("+init=epsg:4326"))
} else {
intersec_km_test <- exists("intersec_km")
cat("Buffers don't intersect any postnummer. Check PPN coordinates (location and proj)")
}
}
# CRS transformation
buffer_sp2 <- buffer_sp
farms_in_buffers2 <- farms_in_buffers
buffer_sp2 <- spTransform(buffer_sp2, CRS("+init=epsg:4326"))
farms_in_buffers2 <- spTransform(farms_in_buffers2, CRS("+init=epsg:4326"))
# Set palette and popups for Leaflet map
if(length(buffer_sp2@data$buffer) == 1) {
pal <- colorNumeric(
palette = c("#d7191c"),
domain = as.numeric(farms_in_buffers2@data$buffer))
pal2 <- colorFactor(
palette = c("#d7191c"),
domain = as.numeric(buffer_sp2@data$buffer))
}
if(length(buffer_sp2@data$buffer) == 2) {
pal <- colorNumeric(
palette = c("#ffffbf", "#d7191c"),
domain = as.numeric(farms_in_buffers2@data$buffer))
pal2 <- colorFactor(
palette = c("#ffffbf", "#d7191c"),
domain = as.numeric(buffer_sp2@data$buffer))
}
if(length(buffer_sp2@data$buffer) >= 3) {
pal <- colorNumeric(
palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"),
domain = as.numeric(farms_in_buffers2@data$buffer))
pal2 <- colorFactor(
palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"),
domain = as.numeric(buffer_sp2@data$buffer))
}
popups <- paste("Buffer", as.character(buffer_sp2@data$buffer),"km")
popups2 <- popups2 <- paste(sep = "<br/>",
"<b>PPN</b>", farms_in_buffers2@data$Ppn,
"<b>Adress</b>", farms_in_buffers2@data$Adress,
"<b>Species</b>",farms_in_buffers2@data$Species)
if (exists("intersec_km")) {
popups3 <- paste(sep = "<br/>",
"<b>Postnummer</b>",
intersec_km@data$POSTALCODE)
}else{
popups3 <- paste(sep = "<br/>",
"<b>Postnummer</b>",
intersec_km_NM@data$POSTALCODE)
}
box3 <- as.vector(buffer_sp2@bbox)
# Draw the map
LeafletMap2 <- leaflet() %>% addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
fitBounds(box3[1], box3[2], box3[3], box3[4])
if(exists("intersec_km_NM")) {
LeafletMap2 %>%
addPolygons(data = buffer_sp2,
fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)),
stroke = TRUE,
weight = 0.5,
color = "black",
fillOpacity = 0.3,
popup = popups,
group = "Buffers") %>%
addPolygons(data = intersec_km_NM,
fillColor = "green",
stroke = TRUE,
weight = 2,
opacity = 1,
color = 'white',
dashArray = '3',
fillOpacity = 0.3,
popup = popups3,
group = "intersec_km") %>%
addCircleMarkers(data = farms_in_buffers2,
stroke= TRUE,
color="black",
weight=2,
radius=3,
fill = TRUE,
fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)),
fillOpacity = 1,
popup = popups2,
group = "PPNs") %>%
addLayersControl(
baseGroups = c("OSM", "CartoDB", "Toner Lite"),
overlayGroups = c("Buffers", "PPNs", "intersec_km", "intersec_km_NM" ),
options = layersControlOptions(collapsed = TRUE))
} else {
LeafletMap2 %>%
addPolygons(data = buffer_sp2,
fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)),
stroke = TRUE,
weight = 0.5,
color = "black",
fillOpacity = 0.3,
popup = popups,
group = "Buffers") %>%
addPolygons(data = intersec_km,
fillColor = "black",
stroke = TRUE,
weight = 2,
opacity = 1,
color = 'white',
dashArray = '3',
fillOpacity = 0.3,
popup = popups3,
group = "Postnummers") %>%
addCircleMarkers(data = farms_in_buffers2,
stroke= TRUE,
color="black",
weight=2,
radius=3,
fill = TRUE,
fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)),
fillOpacity = 1,
popup = popups2,
group = "PPNs") %>%
addLayersControl(baseGroups = c("OSM", "CartoDB", "Toner Lite"),
overlayGroups = c("Buffers", "PPNs", "Postnummers"),
options = layersControlOptions(collapsed = FALSE)) %>%
addLegend("bottomright",
values = buffer_sp2@data$buffer,
title = "Restriction zones",
pal = pal2,
labels = buffer_sp2@data$buffer,
labFormat = labelFormat(prefix = "Buffer ",
suffix = "km"),
opacity = 0.7)
}
11.1 List of PPN records with missing coordinates within postnummers
if(exists("PPN_pro_km") & nrow(PPN_pro_km) > 0) {
ppn_post <- unique(PPN_pro_km[c("Postnummer", "Ppn", "Species", "tot_anim")])
ppn_post_len <- as.data.frame(table(ppn_post$Postnummer))
ppn_post <- split(ppn_post$Ppn, ppn_post$Postnummer)
ppn_post <- unlist(lapply(ppn_post, function(x) {
paste(x, collapse = ", ")
}))
ppn_post <- data.frame(cbind(labels(ppn_post), ppn_post),
ppn_post_len[, 2])
colnames(ppn_post) <- c("Postnummer", "PPN (list)", "PPNs (n.)")
datatable(ppn_post, rownames = FALSE, filter = "top")
} else {
cat("* **Zip-codes intersecting buffers have no PPNs without missing coordinates**")
}
11.2 Table of PPN records with missing coordinates within postnummers
Duplicated PPNs are present when Djurhållare and Djurinnehavare are two different people
if(exists("PPN_pro_km") & nrow(PPN_pro_km) > 0) {
ppn_post <- PPN_pro_km[c("Postnummer",
"Ppn",
"Species",
"Namn",
"Kommun",
"Adress",
"Telefonnummer.1",
"Mobilnummer")]
ppn_post <- ppn_post[!duplicated(ppn_post),]
colnames(ppn_post) <- c("Postnr",
"Ppn",
"Species",
"Namn",
"Kommun",
"Adress",
"Telefon",
"Mobil" )
col_names <- names(ppn_post)[c(1,2,3)]
ppn_post[, col_names] <- lapply(ppn_post[, col_names] , factor)
datatable(ppn_post, filter="top", rownames = FALSE,
options = list(pageLength = 5,
columnDefs = list(
list(className = 'dt-center'))
)
)
} else {
cat("* **No PPNs with missing coordinates within postnummers** ")
}
# create a list of all PPNs to match with SVASSS, SJV and urax data
if(exists("PPN_pro_km")) {
PPN_pro_km_2 <- unique(PPN_pro_km["Ppn"])
} else {
PPN_pro_km_2 <- data.frame(Ppn = outbreak1@data$Ppn)
}
if(exists("farms_in_buffers")) {
merge_farm <- data.frame(Ppn = farms_in_buffers@data$Ppn)
} else {
merge_farm <- data.frame(Ppn = outbreak1@data$Ppn)
}
alla <- unique(rbind(PPN_pro_km_2, merge_farm))
12. SYNDROMIC SURVEILLANCE DATA (SVASSS)
Data reported in the following tables are extracted from SVASSS's alarms datasets. In details, information were derived from:
- dataset of clinical data of vet visit to farms;
- dataset of lab samples submitted to SVA;
12.1. SVASSSS DATASET OF CLINICAL RECORDS
Information reported in the table were obtained by matching PPNs inside the buffer area (or within the postnummer if PPN coordinates were missing) with PPNs present in the dataset of clinical records. Data are ordered first by Syndrome then by PPN
SVASSS.SJV.alarms.data <- report_data_object()$result$SVASSS.SJV.alarms.data
SVASSS.SJV <- SVASSS.SJV.alarms.data
SVASSS.SJV <- SVASSS.SJV[SVASSS.SJV$PPN %in% alla$Ppn, ]
if(nrow(SVASSS.SJV) != 0) {
SVASSS.SJV$DATUM <- as.Date(SVASSS.SJV$DATUM,
format = "%m/%d/%y",
origin="01/01/1970")
SVASSS.SJV2 <- SVASSS.SJV[, c("DATUM",
"prediction.Syndrome.",
"DJURSLAG",
"PPN",
"DISTRIKTNAMN")]
SVASSS.SJV2 <- unique(SVASSS.SJV2) # ??????
SVASSS.SJV2 <- SVASSS.SJV2[order(SVASSS.SJV2["prediction.Syndrome."],
SVASSS.SJV2["DJURSLAG"],
SVASSS.SJV2["DATUM"]),]
col_names <- names(SVASSS.SJV2)
SVASSS.SJV2[, col_names[2:5]] <- lapply(SVASSS.SJV2[, col_names[2:5]] , factor)
colnames(SVASSS.SJV2) <- c("Datum",
"Syndrome",
"Djurslag",
"PPN",
"Distriktnamn")
datatable(SVASSS.SJV2, filter="top", rownames = FALSE,
options = list(
columnDefs = list(
list(className = 'dt-center',
targets = c(0,2,3,4)))
))
} else {
cat("* **No SVASSS clinical data are present for the considered PPNs and time frame**")
}
12.2. JBV DATASET OF CLINICAL RECORDS
sjv.data <- report_data_object()$result$sjv.data
sjv.data <- sjv.data[sjv.data$PPN %in% alla$Ppn, ]
if(nrow(sjv.data) != 0) {
sjv.data$DATUM <- as.Date(sjv.data$DATUM,
format = "%m/%d/%y",
origin="01/01/1970")
sjv.data <- sjv.data[, c("DATUM",
"prediction.Syndrome.",
"DJURSLAG",
"PPN",
"DISTRIKTNAMN")]
sjv.data <- unique(sjv.data)
sjv.data <- sjv.data[order(sjv.data["prediction.Syndrome."],
sjv.data["DJURSLAG"],
sjv.data["DATUM"]),]
col_names <- names(sjv.data)
sjv.data[, col_names[2:5]] <- lapply(sjv.data[, col_names[2:5]] , factor)
colnames(sjv.data) <- c("Datum",
"Syndrome",
"Djurslag",
"PPN",
"Distriktnamn")
datatable(sjv.data, filter="top", rownames = FALSE,
options = list(
columnDefs = list(
list(className = 'dt-center',
targets = c(0,1,2,3,4)))
))
} else {
cat("* **No JBV clinical data are present for the considered PPNs and time frame**")
}
13. URAX DATA
urax <- result$urax
postnummer <- report_data_object()$postnummer
urax$Postnummer <- sub(" ", "", urax$Postnummer) # use regexpression
urax$Postnummer <- as.numeric(urax$Postnummer)
# match ppns with coords
urax_ppn <- urax[!is.na(urax$PPN), ]
urax_match_ppn <- urax_ppn[ urax_ppn$PPN %in% farms_in_buffers@data$Ppn, ]
# match ppns without coords
urax_ppn_nc <- urax[is.na(urax$PPN), ]
urax_match_ppn_nc <- urax_ppn_nc[PPN_pro_km_2$Ppn %in% urax_ppn_nc$PPN, ]
# match postnummer
urax_no_ppn <- urax[is.na(urax$PPN) & !is.na(urax$Postnummer), ]
urax_post2 <- postnummer[postnummer@data$POSTALCODE %in% urax_no_ppn$Postnummer, ] # lose un postalcode
urax_post2_cen <- sapply(1:nrow(urax_post2), function(x) {
urax_post2@polygons[[x]]@labpt
})
urax_post2_cen <- data.frame(t(urax_post2_cen), row.names = NULL)
urax_post2_cen$postnummer <- as.vector(urax_post2@data$POSTALCODE)
colnames(urax_post2_cen) <- c("X","Y","postnummer")
# urax no match display in a table
urax_table <- urax[is.na(urax$PPN) & is.na(urax$Postnummer), ]
# map
outbreak1_wgs <- spTransform(outbreak1, CRS("+init=epsg:4326"))
pop_out <- paste0("<b>", "PPN: ", "</b>", outbreak1_wgs@data$Ppn, "<br>",
"<b>", "Djurslag: ","</b>", outbreak1_wgs@data$Species, "<br>",
"<b>", "Kommun: ", "</b>", outbreak1_wgs@data$Kommun)
box <- as.vector(outbreak1_wgs@bbox)
LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>%
addProviderTiles("CartoDB.Positron", group = "CartoDB") %>%
addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>%
fitBounds(box[1], box[2], box[3], box[4])
LeafletMap1 %>% addCircleMarkers(data = outbreak1_wgs,
radius = 5,
stroke = TRUE,
color = "black",
weight = 2,
fillColor = "red",
fillOpacity = 1,
popup = pop_out,
group = "Outbreak") %>%
addLayersControl(
baseGroups = c("OSM", "CartoDB", "Toner Lite"),
overlayGroups = "Outbreak",
options = layersControlOptions(collapsed = FALSE)) %>%
addLegend("bottomright",
values = outbreak1_wgs@data$Ppn,
colors = "red",
labels = "Investigated PPNs",
opacity = 1)
if (nrow(urax_match_ppn) != 0) {
urax_geo <- farms_RT90[farms_RT90$Ppn %in% urax_match_ppn$PPN,]
}
if (nrow(urax_match_ppn_nc) != 0) {
urax_post <- postnummer[postnummer@data$POSTALCODE %in% urax_match_ppn_nc$Postnummer, ]
}
## continue
if(nrow(urax_match_ppn) != 0) {
urax_table <- urax_table[, c("Svalauppdragsid",
"Namn",
"Adress",
"Agens",
"Status",
"Avslutat")]
datatable(urax_table, rownames = FALSE, filter= "top")
} else {
cat("* **No URAX data within considered spatial radius and time frame**" )
}
urax <- result$urax
postnummer <- report_data_object()$postnummer
urax$Postnummer <- sub(" ", "", urax$Postnummer) # use regexpression
urax$Postnummer <- as.numeric(urax$Postnummer)
# match ppns with coords
urax_ppn <- urax[!is.na(urax$PPN), ]
urax_match_ppn <- urax_ppn[urax_ppn$PPN %in% farms_in_buffers@data$Ppn, ]
# match ppns without coords
urax_ppn_nc <- urax[is.na(urax$PPN), ]
urax_match_ppn_nc <- urax_ppn_nc[PPN_pro_km_2$Ppn %in% urax_ppn_nc$PPN, ]
urax_final <- rbind(urax_match_ppn, urax_match_ppn_nc)
## continue
if(nrow(urax_final) != 0) {
urax_table <- urax_final[, c("PPN",
"Svalauppdragsid",
"Namn",
"Adress",
"Agens",
"Status",
"Avslutat")]
cat("URAX data within considered spatial radius and time frame" )
datatable(urax_table, rownames = FALSE)
} else {
cat("* **No PPNs are present in URAX data within considered spatial radius and time frame**" )
}
SVA-SE/svamp documentation built on May 9, 2019, 11:45 a.m.
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
farms_RT90 <- report_data_object()$result$farms_RT90 ppn <- report_data_object()$ppn outbreak <- farms_RT90[farms_RT90@data$Ppn %in% ppn,] if(any(!ppn %in% farms_RT90@data$Ppn)) { paste ("WARNING: PPNs", c(ppn[!ppn %in% farms_RT90@data$Ppn]), "have no coordinates.They will be excluded from this report. Run a separate report providing coordinates for the above mentioned PPNs") } if(all(!farms_RT90@data$Ppn %in% ppn)) { # copy this error message in report.R stop ("WARNING: All provided PPNs have no coordinates. Run a separate report providing coordinates for invesitgated PPNs") }
1. GEOGRAPHIC LOCATION
1.1 OUTBREAKS MAP with PPNs under investigation
outbreak1 <- outbreak[ , c("Ppn", "Species", "Kommun")] outbreak1_wgs <- spTransform(outbreak1, CRS("+init=epsg:4326")) pop_out <- paste0("<b>", "PPN: ", "</b>", outbreak1_wgs@data$Ppn, "<br>", "<b>", "Djurslag: ","</b>", outbreak1_wgs@data$Species, "<br>", "<b>", "Kommun: ", "</b>", outbreak1_wgs@data$Kommun) box <- as.vector(outbreak1_wgs@bbox) if(length(ppn) == 1) { LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.Positron", group = "CartoDB") %>% addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>% setView(outbreak1_wgs@coords[1], outbreak1_wgs@coords[2], zoom = 9) } else { LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.Positron", group = "CartoDB") %>% addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>% fitBounds(box[1], box[2], box[3], box[4]) } LeafletMap1 %>% addCircleMarkers(data = outbreak1_wgs, radius = 5, stroke = TRUE, color = "black", weight = 2, fillColor = "red", fillOpacity = 1, popup = pop_out, group = "PPNs") %>% addLayersControl( baseGroups = c("OSM", "CartoDB", "Toner Lite"), overlayGroups = "PPNs", options = layersControlOptions(collapsed = FALSE)) %>% addLegend("bottomright", values = outbreak1_wgs@data$Ppn, colors = "red", labels = "Investigated PPNs", opacity = 1)
1.2 ADDRESS
location <- data.frame("PPN " = as.factor(outbreak@data$Ppn), "Lan" = toupper(outbreak@data$Lan), "Kommun" = toupper(outbreak@data$Kommun), "Adress" = toupper(outbreak@data$Adress), "Postadr." = toupper(outbreak@data$Postadress), "Postnr." = toupper(outbreak@data$Postnummer), "Fastighetsbet." = toupper(outbreak@data$Fastighetsbeteckning)) location <- unique(location) datatable(location, rownames = FALSE, filter='top', options = list(pageLength = 3))
2. OWNERS INFORMATION
PPN <- report_data_object()$result$PPN outbreak_no_sp <- PPN[PPN$Ppn %in% ppn,] owners <- length(unique(outbreak_no_sp$Namn))
The number of owners/reference persons for the PPNs under investigation is: r owners
outbreak_own <- outbreak_no_sp outbreak_own <- outbreak_own[c("Ppn", "Namn", "Adress.1", "Postadress.1", "Telefonnummer.1", "Mobilnummer", "Typ.2", "Epost")] colnames(outbreak_own) <- c("Ppn.", "Namn", "Adress.", "Postadr.", "Telefonnum.", "Mobilnum.", "Typ.", "Epost") outbreak_own <- unique(outbreak_own[,c("Ppn.", "Namn", "Adress.", "Postadr.", "Telefonnum.", "Mobilnum.", "Epost", "Typ.")]) col_names <- names(outbreak_own) outbreak_own[, col_names] <- lapply(outbreak_own[, col_names] , factor) datatable(outbreak_own, filter='top', rownames =FALSE, escape = FALSE, options = list(pageLength = 3))
3. NUMBER OF HERDS AND ANIMALS (for the investigated PPN)
outb_in_PPN <- PPN[PPN$Ppn %in% outbreak@data$Ppn, ] outb_in_PPN <- outb_in_PPN [c("Ppn", "Species", "Typ", "tot_anim")] outb_in_PPN <- outb_in_PPN[!duplicated(outb_in_PPN [c("Ppn", "Species", "Typ", "tot_anim")]),] outb_in_PPN2 <- outb_in_PPN outb_in_PPN$Ppn <- as.factor(outb_in_PPN$Ppn) outb_in_PPN <- split(outb_in_PPN, factor(outb_in_PPN$Ppn, levels=rev(levels(outb_in_PPN$Ppn))), drop = TRUE) plot_herds <- function(outb_in_PPN) { counts <- table(outb_in_PPN$Typ) # Draw the graph with herds/animals count for the outbreak par(mfrow = c(1,2), mar=c(5.8, 4.8, 4.1, 2.1), mgp=c(3.8, 1, 0), las=2) width = ifelse(length(counts) == 1, 0.2, 0.8) #avoid big bar drawing when length=1 b1a <- barplot(counts, main = paste0("Number of herds by species (PPN ", unique(outb_in_PPN$Ppn),")"), ylab = "Number of herds", xlim = c(0, length(counts)), ylim = c(0, max(counts * 1.4)), width = width) text(x = b1a, y = counts, label = counts, pos = 3, cex = 0.8, col = "black") if (all(is.na(outb_in_PPN$tot_anim))) { counts2 <- 0 b1b <- barplot(counts2, main = paste0("Number of animal by species (PPN ", unique(outb_in_PPN$Ppn),")"), axes = FALSE, xaxt = "n", xlab = "", ylab = "", col = "white", border = NA, sub = "Number of animals is NA for this PPN. See table below") } else { outb_in_PPN <- outb_in_PPN [!is.na(outb_in_PPN$tot_anim),] counts2 <-tapply(outb_in_PPN$tot_anim, INDEX = outb_in_PPN$Typ, FUN = sum) width = ifelse(length(counts2) == 1, 0.2, 0.8) b1b <- barplot(counts2, main = paste0("Number of animal by species (PPN ", unique(outb_in_PPN$Ppn),")"), ylab = "Number of animals", ylim = c(0, max(counts2 * 1.4)), xlim = c(0, length(counts2)), width = width) text(x = b1b, y = counts2, label = counts2, pos = 3, cex = 0.8, col = "black") } } invisible(lapply(outb_in_PPN, plot_herds))
if (any(is.na(outbreak_no_sp$tot_anim))) { cat("<br>", "<br>", "**OBS. Some information about number of animals are missing (blank or NA). Check the table below for complete information**", "<br>", "<br>") } col_names <- names(outb_in_PPN2) outb_in_PPN2[, col_names] <- lapply(outb_in_PPN2[, col_names] , factor) datatable(outb_in_PPN2, filter='top', rownames =FALSE, escape = FALSE, options = list(pageLength = 3))
4. VETERINARY DISTRICTS INFORMATION
district_geo_RT90 <- report_data_object()$result$district_geo_RT90 # calculate euclidean distance from outbreak to vet disctrict dist_vet <- sapply(1:nrow(outbreak), function(i) spDistsN1(as.matrix(district_geo_RT90@coords), as.matrix(outbreak@coords[i, 1:2]), longlat=F)/1000) dist_vet <- round(dist_vet, 0) colnames(dist_vet) <- as.character(outbreak@data$Ppn) dist_vet <- as.data.frame(dist_vet) vet_list <- list() for (i in 1:ncol(dist_vet)) { vet_list[[i]] <- cbind(dist_vet[,i], district_geo_RT90@data[, 2:6]) names(vet_list[[i]]) <- c("Distans", names(district_geo_RT90@data[, 2:6])) names(vet_list) <- names(dist_vet)[1:i] } for (i in 1:length(vet_list)) { vet_list[[i]] <- vet_list[[i]][order(vet_list[[i]][1]),] } out = NULL for (j in 1:length(vet_list)) { g <- paste("<br>", "<br>", "**Veterinary districts most closest to PPN** ", names(vet_list[j]), "<br>", "<br>") knit_expanded <- paste0("\n```r\n\ndatatable(vet_list[[", j, "]], rownames =FALSE, escape = FALSE, options = list(pageLength = 3))\n\n```") out = c(out, g, knit_expanded) }
r paste(knit(text = out), collapse = '\n')
5. RESTRICTION ZONES
buffer_size <- buffer_size[order(buffer_size, decreasing = FALSE)] buffer <- buffer_ppn(outbreak, buffer_size) proj4string(buffer) <- CRS("+init=epsg:3021") buffer_sp <- hole(buffer, buffer_size)
buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:3021")) if(all(is.na(over(farms_RT90, buffer_sp)))) { farms_in_buffers <- outbreak1 } else { check_in_buffers <- over(farms_RT90, buffer_sp) farms_in_buffers <- farms_RT90[buffer_sp, c("Ppn", "Species", "Kommun", "Adress", "Postadress")] farms_in_buffers@data$buffer <- check_in_buffers$buffer[ row.names(check_in_buffers) %in% row.names(farms_in_buffers)] }
There is a total of r if(!identical(farms_in_buffers, outbreak)){sum(nrow(farms_in_buffers@data))}else{"0"} PPNs within the selected buffer zones. The table below reports the number of PPNs in each buffer zone.
ppn_zone_sum <- data.frame(table(farms_in_buffers@data$buffer)) colnames(ppn_zone_sum) <- c("Buffer_zone", "PPN (tot.)") ppn_zone_sum <- ppn_zone_sum[rev(order(ppn_zone_sum$Buffer_zone)), ] datatable(ppn_zone_sum, rownames =FALSE, escape = FALSE, options = list(columnDefs = list( list(className = 'dt-center', targets = c(0,1))) ))
6. SUMMARY STATISTICS FOR ANIMALS WITHIN RESTICTION ZONES
#duplicated PPN records for total herds/farms/animal calculation # if(!identical(farms_in_buffers, outbreak1)) { n_PPN_buffers <- PPN[which(PPN$Ppn %in% farms_in_buffers@data$Ppn),] n_PPN_buffers$buffer <- farms_in_buffers@data$buffer[ match(n_PPN_buffers$Ppn, farms_in_buffers@data$Ppn)] #} sum_anim <- function(n.PPN.in) { n.anim <- n.PPN.in[,c("Antal", "Antalslaktplatser", "Antalsuggplatser", "CDB.Antal", "Maxkapacitet")] ani_sum <- rowSums (n.anim, na.rm = T) n.PPN.in <- cbind (n.PPN.in, ani_sum) return (n.PPN.in) } # if(!identical(n_PPN_buffers, outbreak1)) { n.PPN.in1 <- sum_anim(n_PPN_buffers) # } # Exclusion of duplicated values when Djurhållare == DJURINNEHAVARE (to sum properly) # if(!identical(farms_in1_RT90,outbreak1)) { n.PPN.in1 <- n.PPN.in1[!duplicated(n.PPN.in1[c("Ppn", "Adress", "Typ", "tot_anim")]),] # }
b <- split(n.PPN.in1, factor(n.PPN.in1$buffer, levels=rev(levels(n.PPN.in1$buffer))), drop = TRUE) #if(!identical(farms_in1_RT90, outbreak1)) { plot_graph <- function(list_df) { counts <- table(list_df$Typ) counts2 <-tapply(list_df$ani_sum, INDEX = list_df$Typ, FUN=sum) width = ifelse(length(counts) == 1, 0.2, 0.6) par(mfrow = c(1,2), las = 2) b1a <- barplot(counts, main = paste("Number of herds by species (buffer", unique(list_df$buffer), "km)"), cex.main = 0.9, ylab = "Number of herds", ylim = c(0, max(counts * 1.4)), xlim = c(0, length(counts)), width = width) text(x = b1a, y = counts, label = counts, pos = 3, cex = 0.8, col = "black") b1b <- barplot(counts2, main = paste("Number of animals by species (buffer", unique(list_df$buffer), "km)"), cex.main = 0.9, ylab = "Number of animals", ylim = c(0, max(counts2 * 1.4)), xlim = c(0, length(counts2)), width = width) text(x = b1b, y = counts2, label = counts2, pos = 3, cex = 0.8, col = "black") return(NULL) } invisible(lapply(b, plot_graph)) # } else { # # cat("* **No PPNs other than the investigated PPN within the Restriction zones**") # }
7. LIST OF PPNs WITHIN RESTICTION ZONES
#Calculate distance matrix to assign farms to outbreaks farm if (length(ppn) > 1) { dm_farms_in1 <- DistMatrix(farms_in_buffers, longlat = FALSE, outbreak) dm_farms_in1 <- as.data.frame(t(dm_farms_in1)) outbreak_ppn <- as.character(outbreak@data$Ppn) farms_ppn <- as.character(farms_in_buffers@data$Ppn) min_dist <- apply(dm_farms_in1[, 1:length(outbreak_ppn)], 1, min) dm_farms_in1$near_out <- NULL for(i in 1:length(farms_ppn)) { dm_farms_in1$near_out[i] <- outbreak_ppn[ which(dm_farms_in1[i, 1:ncol(dm_farms_in1)] == min_dist[i])] } farms_in_buffers2 <- farms_in_buffers@data farms_in_buffers2 <- data.frame(farms_in_buffers2, nearest = as.factor(dm_farms_in1$near_out)) } else { farms_in_buffers2 <- farms_in_buffers@data farms_in_buffers2 <- data.frame(farms_in_buffers2, nearest = as.factor(ppn)) }
# farms_in_buffers <- spTransform(farms_in_buffers, CRS("+init=epsg:3021")) #?????? col_names <- names(farms_in_buffers2) farms_in_buffers2[, col_names] <- lapply(farms_in_buffers2[, col_names] , factor) farms <- split(farms_in_buffers2, factor(farms_in_buffers2$buffer, levels=rev(levels(farms_in_buffers2$buffer))), drop = TRUE) farms <- lapply(farms, function(x) { x["buffer"] <- NULL; x } ) out2 = NULL for (k in 1:length(farms)) { g2 <- paste0("<br>", "**7a. LIST OF PPNs WITHIN BUFFER **", names(farms[k]), "km", "<br>", "<br>") knit_expanded2 <- paste0("\n```r\n\ndatatable(farms[[", k, "]], escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```") out2 = c(out2, g2, knit_expanded2) }
r paste(knit(text = out2), collapse = '\n')
PPNs WITHIN RESTRICTION ZONES MAP
# CRS transformation buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:4326")) farms_in_buffers <- spTransform(farms_in_buffers, CRS("+init=epsg:4326")) outbreak2 <- spTransform(outbreak1, CRS("+init=epsg:4326")) # Set palette and popups for Leaflet map if(length(as.numeric(buffer_sp@data$buffer)) == 1) { pal <- colorNumeric( palette = c("#d7191c"), domain = as.numeric(farms_in_buffers@data$buffer)) pal2 <- colorFactor( palette = c("#d7191c"), domain = as.numeric(buffer_sp@data$buffer)) } if(length(as.numeric(buffer_sp@data$buffer)) == 2) { pal <- colorNumeric( palette = c("#ffffbf", "#d7191c"), domain = as.numeric(farms_in_buffers@data$buffer)) pal2 <- colorFactor( palette = c("#ffffbf", "#d7191c"), domain = as.numeric(buffer_sp@data$buffer)) } if(length(as.numeric(buffer_sp@data$buffer)) >= 3) { pal <- colorNumeric( palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"), domain = as.numeric(farms_in_buffers@data$buffer)) pal2 <- colorFactor( palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"), domain = as.numeric(buffer_sp@data$buffer)) } popups <- paste("Buffer", as.character(buffer_sp@data$buffer),"km") popups2 <- popups2 <- paste(sep = "<br/>", "<b>PPN</b>", farms_in_buffers@data$Ppn, "<b>Adress</b>", farms_in_buffers@data$Adress, "<b>Species</b>",farms_in_buffers@data$Species) box2 <- as.vector(buffer_sp@bbox) # Draw the map LeafletMap2 <- leaflet() %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.Positron", group = "CartoDB") %>% addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>% fitBounds(box2[1], box2[2], box2[3], box2[4]) LeafletMap2 %>% addPolygons(data = buffer_sp, fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)), stroke = TRUE, weight = 0.5, color = "black", fillOpacity = 0.3, group = "Buffers", popup = popups) %>% addCircleMarkers(data = farms_in_buffers, stroke= TRUE, color="black", weight=2, radius=3, fill = TRUE, fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)), fillOpacity = 1, group = "PPNs", popup = popups2) %>% addCircleMarkers(data = outbreak1_wgs, radius = 3, stroke = TRUE, color = "black", weight = 2, fillColor = "black", fillOpacity = 1, popup = pop_out, group = "Outbreak") %>% addLayersControl( baseGroups = c("OSM", "CartoDB", "Toner Lite"), overlayGroups = c("Buffers", "PPNs", "Outbreak"), options = layersControlOptions(collapsed = TRUE)) %>% addLegend("bottomright", values = buffer_sp@data$buffer, pal = pal2, labels = buffer_sp@data$buffer, labFormat = labelFormat(prefix = "Buffer ", suffix = "km"), opacity = 1) %>% addLegend("bottomright", colors = "black", labels = "Outbreak", opacity = 1)
8. NUMBER OF ANIMALS OF PPNs WITHIN RESTRICTION ZONES
n_anim_rz <- PPN[PPN$Ppn %in% farms_in_buffers2$Ppn, ] farms_in_buffers3 <- farms_in_buffers2[, c("Ppn", "buffer", "nearest")] n_anim_rz <- merge(n_anim_rz, farms_in_buffers3, by = "Ppn") n_anim_rz <- n_anim_rz[c("Ppn", "Species", "Typ", "tot_anim", "buffer", "nearest")] n_anim_rz <- n_anim_rz[!duplicated(n_anim_rz),] colnames(n_anim_rz) <- c("Ppn", "Species", "Typ", "Antal", "buffer", "near_out") col_names <- names(n_anim_rz)[c(1, 2, 4, 5)] n_anim_rz[, col_names] <- lapply(n_anim_rz[, col_names] , factor) n_anim_rz <- split(n_anim_rz, factor(n_anim_rz$buffer, levels=rev(levels(n_anim_rz$buffer))), drop = TRUE) n_anim_rz <- lapply(n_anim_rz, function(x) { x["buffer"] <- NULL; x } ) out3 = NULL for (l in 1:length(n_anim_rz)) { g3 <- paste0("<br>", "**8a. PPNs' NUMBER OF ANIMALS WITHIN BUFFER **", names(n_anim_rz[l]), "km", "<br>", "<br>") knit_expanded3 <- paste0("\n```r\n\ndatatable(n_anim_rz[[", l, "]], filter='top', escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```") out3 = c(out3, g3, knit_expanded3) }
r paste(knit(text = out3), collapse = '\n')
9. OWNERS OF PPNs WITHIN RESTRICTION ZONES
n_anim_own_rz <- PPN[PPN$Ppn %in% farms_in_buffers2$Ppn, ] farms_in_buffers4 <- farms_in_buffers2[, c("Ppn", "buffer", "nearest")] n_anim_own_rz <- merge(n_anim_own_rz, farms_in_buffers4, by = "Ppn") n_anim_own_rz <- n_anim_own_rz[,c("Ppn","Namn","Adress.1","Telefonnummer.1", "Mobilnummer", "Epost", "buffer", "nearest")] n_anim_own_rz <- n_anim_own_rz[!duplicated(n_anim_own_rz),] colnames(n_anim_own_rz) <- c("Ppn","Namn", "Adress","Telefon", "Mobil", "Epost", "buffer", "near_out") col_names <- names(n_anim_own_rz) n_anim_own_rz[, col_names] <- lapply(n_anim_own_rz[, col_names] , factor) n_anim_own_rz <- split(n_anim_own_rz, factor(n_anim_own_rz$buffer, levels=rev(levels(n_anim_own_rz$buffer))), drop = TRUE) n_anim_own_rz <- lapply(n_anim_own_rz, function(x) { x["buffer"] <- NULL; x } ) out4 = NULL for (h in 1:length(n_anim_own_rz)) { g4 <- paste0("<br>", "**9a. OWNERS OF PPNs WITHIN BUFFER** ", names(n_anim_own_rz[h]), "km", "<br>", "<br>") knit_expanded4 <- paste0("\n```r\n\ndatatable(n_anim_own_rz[[", h, "]], escape = FALSE, rownames = FALSE, options = list(pageLength = 5))\n\n```") out4 = c(out4, g4, knit_expanded4) }
r paste(knit(text = out4), collapse = '\n')
10. ANALYSIS OF CONTACTS (EpiContactTrace)
The analysis covers the last r report_data_object()$days days from the date of report generation (r Sys.Date()).
The most recent movements reported into the database are from r unique(max(report_data_object()$result$ani_move$t)).
Run your own contact analysis setting different parameters (click the link)
OBS! Animal movement data may be reported to Jordbruksverket as late as 7 days after a movement has occured
library(EpiContactTrace) transfers <- report_data_object()$result$ani_move days <- report_data_object()$days outbreak <- outbreak@data$Ppn # Perform contact tracing temp <- tempfile() contactTrace <- Trace(movements = transfers, root = outbreak, tEnd = Sys.Date(), days = days) show(contactTrace)
11. MISSING COORDINATES
buffer_sp <- spTransform(buffer_sp, CRS("+init=epsg:3021")) #FIX THE NAME NOT DUPLICATES! postnum_miss <- report_data_object()$result$postnum_miss postnum_not_miss <- report_data_object()$result$postnum_not_miss # LEAFLET MAP? PPN_is.na <- report_data_object()$result$PPN_is.na if (!all(is.na(over(postnum_miss, buffer_sp)))) { intersec_km <- postnum_miss[buffer_sp, ] intersec_km <- spTransform(intersec_km, CRS("+init=epsg:4326")) # match postnummer with postnummer of PPN is.na PPN_pro_km <- PPN_is.na[PPN_is.na$Postnummer %in% intersec_km@data$POSTALCODE, ] intersec_km_test <- exists("intersec_km") } else { if (!all(is.na(over(postnum_miss, buffer_sp)))) { intersec_km_test <- exists("intersec_km") intersec_km_NM <- postnum_not_miss[buffer_sp,] intersec_km_NM <- spTransform(intersec_km_NM, CRS("+init=epsg:4326")) } else { intersec_km_test <- exists("intersec_km") cat("Buffers don't intersect any postnummer. Check PPN coordinates (location and proj)") } }
# CRS transformation buffer_sp2 <- buffer_sp farms_in_buffers2 <- farms_in_buffers buffer_sp2 <- spTransform(buffer_sp2, CRS("+init=epsg:4326")) farms_in_buffers2 <- spTransform(farms_in_buffers2, CRS("+init=epsg:4326")) # Set palette and popups for Leaflet map if(length(buffer_sp2@data$buffer) == 1) { pal <- colorNumeric( palette = c("#d7191c"), domain = as.numeric(farms_in_buffers2@data$buffer)) pal2 <- colorFactor( palette = c("#d7191c"), domain = as.numeric(buffer_sp2@data$buffer)) } if(length(buffer_sp2@data$buffer) == 2) { pal <- colorNumeric( palette = c("#ffffbf", "#d7191c"), domain = as.numeric(farms_in_buffers2@data$buffer)) pal2 <- colorFactor( palette = c("#ffffbf", "#d7191c"), domain = as.numeric(buffer_sp2@data$buffer)) } if(length(buffer_sp2@data$buffer) >= 3) { pal <- colorNumeric( palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"), domain = as.numeric(farms_in_buffers2@data$buffer)) pal2 <- colorFactor( palette = c("#1a9641","#a6d96a", "#ffffbf", "#fdae61", "#d7191c"), domain = as.numeric(buffer_sp2@data$buffer)) } popups <- paste("Buffer", as.character(buffer_sp2@data$buffer),"km") popups2 <- popups2 <- paste(sep = "<br/>", "<b>PPN</b>", farms_in_buffers2@data$Ppn, "<b>Adress</b>", farms_in_buffers2@data$Adress, "<b>Species</b>",farms_in_buffers2@data$Species) if (exists("intersec_km")) { popups3 <- paste(sep = "<br/>", "<b>Postnummer</b>", intersec_km@data$POSTALCODE) }else{ popups3 <- paste(sep = "<br/>", "<b>Postnummer</b>", intersec_km_NM@data$POSTALCODE) } box3 <- as.vector(buffer_sp2@bbox) # Draw the map LeafletMap2 <- leaflet() %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.Positron", group = "CartoDB") %>% addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>% fitBounds(box3[1], box3[2], box3[3], box3[4]) if(exists("intersec_km_NM")) { LeafletMap2 %>% addPolygons(data = buffer_sp2, fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)), stroke = TRUE, weight = 0.5, color = "black", fillOpacity = 0.3, popup = popups, group = "Buffers") %>% addPolygons(data = intersec_km_NM, fillColor = "green", stroke = TRUE, weight = 2, opacity = 1, color = 'white', dashArray = '3', fillOpacity = 0.3, popup = popups3, group = "intersec_km") %>% addCircleMarkers(data = farms_in_buffers2, stroke= TRUE, color="black", weight=2, radius=3, fill = TRUE, fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)), fillOpacity = 1, popup = popups2, group = "PPNs") %>% addLayersControl( baseGroups = c("OSM", "CartoDB", "Toner Lite"), overlayGroups = c("Buffers", "PPNs", "intersec_km", "intersec_km_NM" ), options = layersControlOptions(collapsed = TRUE)) } else { LeafletMap2 %>% addPolygons(data = buffer_sp2, fillColor = ~pal2(as.numeric(buffer_sp@data$buffer)), stroke = TRUE, weight = 0.5, color = "black", fillOpacity = 0.3, popup = popups, group = "Buffers") %>% addPolygons(data = intersec_km, fillColor = "black", stroke = TRUE, weight = 2, opacity = 1, color = 'white', dashArray = '3', fillOpacity = 0.3, popup = popups3, group = "Postnummers") %>% addCircleMarkers(data = farms_in_buffers2, stroke= TRUE, color="black", weight=2, radius=3, fill = TRUE, fillColor = ~pal(as.numeric(farms_in_buffers@data$buffer)), fillOpacity = 1, popup = popups2, group = "PPNs") %>% addLayersControl(baseGroups = c("OSM", "CartoDB", "Toner Lite"), overlayGroups = c("Buffers", "PPNs", "Postnummers"), options = layersControlOptions(collapsed = FALSE)) %>% addLegend("bottomright", values = buffer_sp2@data$buffer, title = "Restriction zones", pal = pal2, labels = buffer_sp2@data$buffer, labFormat = labelFormat(prefix = "Buffer ", suffix = "km"), opacity = 0.7) }
11.1 List of PPN records with missing coordinates within postnummers
if(exists("PPN_pro_km") & nrow(PPN_pro_km) > 0) { ppn_post <- unique(PPN_pro_km[c("Postnummer", "Ppn", "Species", "tot_anim")]) ppn_post_len <- as.data.frame(table(ppn_post$Postnummer)) ppn_post <- split(ppn_post$Ppn, ppn_post$Postnummer) ppn_post <- unlist(lapply(ppn_post, function(x) { paste(x, collapse = ", ") })) ppn_post <- data.frame(cbind(labels(ppn_post), ppn_post), ppn_post_len[, 2]) colnames(ppn_post) <- c("Postnummer", "PPN (list)", "PPNs (n.)") datatable(ppn_post, rownames = FALSE, filter = "top") } else { cat("* **Zip-codes intersecting buffers have no PPNs without missing coordinates**") }
11.2 Table of PPN records with missing coordinates within postnummers
Duplicated PPNs are present when Djurhållare and Djurinnehavare are two different people
if(exists("PPN_pro_km") & nrow(PPN_pro_km) > 0) { ppn_post <- PPN_pro_km[c("Postnummer", "Ppn", "Species", "Namn", "Kommun", "Adress", "Telefonnummer.1", "Mobilnummer")] ppn_post <- ppn_post[!duplicated(ppn_post),] colnames(ppn_post) <- c("Postnr", "Ppn", "Species", "Namn", "Kommun", "Adress", "Telefon", "Mobil" ) col_names <- names(ppn_post)[c(1,2,3)] ppn_post[, col_names] <- lapply(ppn_post[, col_names] , factor) datatable(ppn_post, filter="top", rownames = FALSE, options = list(pageLength = 5, columnDefs = list( list(className = 'dt-center')) ) ) } else { cat("* **No PPNs with missing coordinates within postnummers** ") }
# create a list of all PPNs to match with SVASSS, SJV and urax data if(exists("PPN_pro_km")) { PPN_pro_km_2 <- unique(PPN_pro_km["Ppn"]) } else { PPN_pro_km_2 <- data.frame(Ppn = outbreak1@data$Ppn) } if(exists("farms_in_buffers")) { merge_farm <- data.frame(Ppn = farms_in_buffers@data$Ppn) } else { merge_farm <- data.frame(Ppn = outbreak1@data$Ppn) } alla <- unique(rbind(PPN_pro_km_2, merge_farm))
12. SYNDROMIC SURVEILLANCE DATA (SVASSS)
Data reported in the following tables are extracted from SVASSS's alarms datasets. In details, information were derived from:
- dataset of clinical data of vet visit to farms;
- dataset of lab samples submitted to SVA;
12.1. SVASSSS DATASET OF CLINICAL RECORDS
Information reported in the table were obtained by matching PPNs inside the buffer area (or within the postnummer if PPN coordinates were missing) with PPNs present in the dataset of clinical records. Data are ordered first by Syndrome then by PPN
SVASSS.SJV.alarms.data <- report_data_object()$result$SVASSS.SJV.alarms.data SVASSS.SJV <- SVASSS.SJV.alarms.data SVASSS.SJV <- SVASSS.SJV[SVASSS.SJV$PPN %in% alla$Ppn, ] if(nrow(SVASSS.SJV) != 0) { SVASSS.SJV$DATUM <- as.Date(SVASSS.SJV$DATUM, format = "%m/%d/%y", origin="01/01/1970") SVASSS.SJV2 <- SVASSS.SJV[, c("DATUM", "prediction.Syndrome.", "DJURSLAG", "PPN", "DISTRIKTNAMN")] SVASSS.SJV2 <- unique(SVASSS.SJV2) # ?????? SVASSS.SJV2 <- SVASSS.SJV2[order(SVASSS.SJV2["prediction.Syndrome."], SVASSS.SJV2["DJURSLAG"], SVASSS.SJV2["DATUM"]),] col_names <- names(SVASSS.SJV2) SVASSS.SJV2[, col_names[2:5]] <- lapply(SVASSS.SJV2[, col_names[2:5]] , factor) colnames(SVASSS.SJV2) <- c("Datum", "Syndrome", "Djurslag", "PPN", "Distriktnamn") datatable(SVASSS.SJV2, filter="top", rownames = FALSE, options = list( columnDefs = list( list(className = 'dt-center', targets = c(0,2,3,4))) )) } else { cat("* **No SVASSS clinical data are present for the considered PPNs and time frame**") }
12.2. JBV DATASET OF CLINICAL RECORDS
sjv.data <- report_data_object()$result$sjv.data sjv.data <- sjv.data[sjv.data$PPN %in% alla$Ppn, ] if(nrow(sjv.data) != 0) { sjv.data$DATUM <- as.Date(sjv.data$DATUM, format = "%m/%d/%y", origin="01/01/1970") sjv.data <- sjv.data[, c("DATUM", "prediction.Syndrome.", "DJURSLAG", "PPN", "DISTRIKTNAMN")] sjv.data <- unique(sjv.data) sjv.data <- sjv.data[order(sjv.data["prediction.Syndrome."], sjv.data["DJURSLAG"], sjv.data["DATUM"]),] col_names <- names(sjv.data) sjv.data[, col_names[2:5]] <- lapply(sjv.data[, col_names[2:5]] , factor) colnames(sjv.data) <- c("Datum", "Syndrome", "Djurslag", "PPN", "Distriktnamn") datatable(sjv.data, filter="top", rownames = FALSE, options = list( columnDefs = list( list(className = 'dt-center', targets = c(0,1,2,3,4))) )) } else { cat("* **No JBV clinical data are present for the considered PPNs and time frame**") }
13. URAX DATA
urax <- result$urax postnummer <- report_data_object()$postnummer urax$Postnummer <- sub(" ", "", urax$Postnummer) # use regexpression urax$Postnummer <- as.numeric(urax$Postnummer) # match ppns with coords urax_ppn <- urax[!is.na(urax$PPN), ] urax_match_ppn <- urax_ppn[ urax_ppn$PPN %in% farms_in_buffers@data$Ppn, ] # match ppns without coords urax_ppn_nc <- urax[is.na(urax$PPN), ] urax_match_ppn_nc <- urax_ppn_nc[PPN_pro_km_2$Ppn %in% urax_ppn_nc$PPN, ] # match postnummer urax_no_ppn <- urax[is.na(urax$PPN) & !is.na(urax$Postnummer), ] urax_post2 <- postnummer[postnummer@data$POSTALCODE %in% urax_no_ppn$Postnummer, ] # lose un postalcode urax_post2_cen <- sapply(1:nrow(urax_post2), function(x) { urax_post2@polygons[[x]]@labpt }) urax_post2_cen <- data.frame(t(urax_post2_cen), row.names = NULL) urax_post2_cen$postnummer <- as.vector(urax_post2@data$POSTALCODE) colnames(urax_post2_cen) <- c("X","Y","postnummer") # urax no match display in a table urax_table <- urax[is.na(urax$PPN) & is.na(urax$Postnummer), ] # map outbreak1_wgs <- spTransform(outbreak1, CRS("+init=epsg:4326")) pop_out <- paste0("<b>", "PPN: ", "</b>", outbreak1_wgs@data$Ppn, "<br>", "<b>", "Djurslag: ","</b>", outbreak1_wgs@data$Species, "<br>", "<b>", "Kommun: ", "</b>", outbreak1_wgs@data$Kommun) box <- as.vector(outbreak1_wgs@bbox) LeafletMap1 <- leaflet(outbreak1_wgs) %>% addTiles(group = "OSM") %>% addProviderTiles("CartoDB.Positron", group = "CartoDB") %>% addProviderTiles("Stamen.TonerLite", group = "Toner Lite") %>% fitBounds(box[1], box[2], box[3], box[4]) LeafletMap1 %>% addCircleMarkers(data = outbreak1_wgs, radius = 5, stroke = TRUE, color = "black", weight = 2, fillColor = "red", fillOpacity = 1, popup = pop_out, group = "Outbreak") %>% addLayersControl( baseGroups = c("OSM", "CartoDB", "Toner Lite"), overlayGroups = "Outbreak", options = layersControlOptions(collapsed = FALSE)) %>% addLegend("bottomright", values = outbreak1_wgs@data$Ppn, colors = "red", labels = "Investigated PPNs", opacity = 1) if (nrow(urax_match_ppn) != 0) { urax_geo <- farms_RT90[farms_RT90$Ppn %in% urax_match_ppn$PPN,] } if (nrow(urax_match_ppn_nc) != 0) { urax_post <- postnummer[postnummer@data$POSTALCODE %in% urax_match_ppn_nc$Postnummer, ] } ## continue if(nrow(urax_match_ppn) != 0) { urax_table <- urax_table[, c("Svalauppdragsid", "Namn", "Adress", "Agens", "Status", "Avslutat")] datatable(urax_table, rownames = FALSE, filter= "top") } else { cat("* **No URAX data within considered spatial radius and time frame**" ) }
urax <- result$urax postnummer <- report_data_object()$postnummer urax$Postnummer <- sub(" ", "", urax$Postnummer) # use regexpression urax$Postnummer <- as.numeric(urax$Postnummer) # match ppns with coords urax_ppn <- urax[!is.na(urax$PPN), ] urax_match_ppn <- urax_ppn[urax_ppn$PPN %in% farms_in_buffers@data$Ppn, ] # match ppns without coords urax_ppn_nc <- urax[is.na(urax$PPN), ] urax_match_ppn_nc <- urax_ppn_nc[PPN_pro_km_2$Ppn %in% urax_ppn_nc$PPN, ] urax_final <- rbind(urax_match_ppn, urax_match_ppn_nc) ## continue if(nrow(urax_final) != 0) { urax_table <- urax_final[, c("PPN", "Svalauppdragsid", "Namn", "Adress", "Agens", "Status", "Avslutat")] cat("URAX data within considered spatial radius and time frame" ) datatable(urax_table, rownames = FALSE) } else { cat("* **No PPNs are present in URAX data within considered spatial radius and time frame**" ) }
R Package Documentation
Browse R Packages
We want your feedback!
Note that we can't provide technical support on individual packages. You should contact the package authors for that.
Embedding an R snippet on your website
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.