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") }
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)
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))
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))
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))
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')
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))) ))
#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**") # }
#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')
# 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)
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')
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')
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)
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) }
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**") }
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))
Data reported in the following tables are extracted from SVASSS's alarms datasets. In details, information were derived from:
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**") }
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**") }
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**" ) }
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.