Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 1 | #!/usr/bin/Rscript |
| 2 | library(RKorAPClient) |
| 3 | library(ggplot2) |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 4 | library(sf) |
Marc Kupietz | 35eecca | 2022-09-07 10:45:42 +0200 | [diff] [blame] | 5 | # library(R.cache) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 6 | |
Marc Kupietz | e457d99 | 2019-09-29 18:17:05 +0200 | [diff] [blame] | 7 | devAskNewPage(ask = FALSE) |
Marc Kupietz | 35eecca | 2022-09-07 10:45:42 +0200 | [diff] [blame] | 8 | |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 9 | mapfile <- file.path(tempdir(), "map-sf-v1.rds") |
Marc Kupietz | 35eecca | 2022-09-07 10:45:42 +0200 | [diff] [blame] | 10 | |
| 11 | # Caching data in the user's home filespace by default |
| 12 | # is not allowed to package demos by CRAN policies ... |
| 13 | # |
| 14 | # mapfile <- file.path(R.cache::getCachePath(), "map-v2.rds") |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 15 | |
| 16 | fetchAndPrepareMap <- function(map, pick) { |
| 17 | cat("Downloading GADM map data for ", map, "\n") |
Marc Kupietz | 6b27e2f | 2025-08-17 12:18:58 +0200 | [diff] [blame] | 18 | sp <- readRDS(url(sprintf("https://geodata.ucdavis.edu/gadm/gadm3.6/Rsp/gadm36_%s_sp.rds", map))) |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 19 | sfobj <- sf::st_as_sf(sp) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 20 | if (pick > 0) { |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 21 | sfobj <- sfobj[pick, ] |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 22 | } |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 23 | # Keep only geometry to standardize columns across layers |
| 24 | sfobj <- sfobj["geometry"] |
| 25 | sfobj |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 26 | } |
| 27 | |
| 28 | fetchMaps <- function(maps, picks) { |
| 29 | if (file.exists(mapfile)) { |
| 30 | df <- readRDS(mapfile) |
| 31 | } else { |
| 32 | cat("Downloading and caching GADM map data.\nPlease note that the GADM map data is licensed for academic use and other non-commercial use, only.\nSee https://gadm.org/license.html\n") |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 33 | # Fetch individual sf layers and row-bind |
| 34 | sflist <- mapply(fetchAndPrepareMap, maps, picks, SIMPLIFY = FALSE) |
| 35 | df <- do.call(rbind, sflist) |
| 36 | # Create a stable group index compatible with original regions index logic |
| 37 | df$grp <- seq_len(nrow(df)) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 38 | dir.create(dirname(mapfile), recursive = TRUE, showWarnings = FALSE) |
| 39 | saveRDS(df, mapfile) |
| 40 | } |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 41 | # If cache is from an older version (non-sf tidy data), refresh |
| 42 | if (!inherits(df, "sf")) { |
| 43 | cat("Cached map is in outdated format; re-downloading as sf...\n") |
| 44 | sflist <- mapply(fetchAndPrepareMap, maps, picks, SIMPLIFY = FALSE) |
| 45 | df <- do.call(rbind, sflist) |
| 46 | df$grp <- seq_len(nrow(df)) |
| 47 | dir.create(dirname(mapfile), recursive = TRUE, showWarnings = FALSE) |
| 48 | saveRDS(df, mapfile) |
| 49 | } else if (is.null(df$grp)) { |
| 50 | df$grp <- seq_len(nrow(df)) |
| 51 | } |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 52 | df |
| 53 | } |
| 54 | |
Marc Kupietz | b1be8b4 | 2019-09-28 17:57:31 +0200 | [diff] [blame] | 55 | map <- fetchMaps(c("DEU_1", "AUT_0", "CHE_0", "LUX_0", "BEL_3", "ITA_1", "LIE_0"), c(0, 0, 0, 0, 34, 17, 0)) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 56 | |
Marc Kupietz | 617266d | 2025-02-27 10:43:07 +0100 | [diff] [blame] | 57 | geoDistrib <- function(query, kco = KorAPConnection(verbose=TRUE)) { |
Marc Kupietz | e457d99 | 2019-09-29 18:17:05 +0200 | [diff] [blame] | 58 | regions <- readRDS("demo/data/regions.rds") |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 59 | regions$freq <- NA |
Marc Kupietz | 9402dec | 2019-09-28 22:29:30 +0200 | [diff] [blame] | 60 | regions$url <- NA |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 61 | plot <- NULL |
| 62 | vc <- "" |
| 63 | for (i in 1:nrow(regions)) { |
| 64 | if (!is.na(regions[i,]$query)) { |
Marc Kupietz | b1be8b4 | 2019-09-28 17:57:31 +0200 | [diff] [blame] | 65 | cat(as.character(regions[i,]$region), "\n") |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 66 | regions[i,]$total <- corpusStats(kco, vc=paste0(vc, regions[i,]$query))@tokens |
| 67 | if (regions[i,]$total == 0) { |
| 68 | regions[i,]$afreq <- 0 |
| 69 | regions[i,]$freq <- NA |
| 70 | } else { |
Marc Kupietz | 9402dec | 2019-09-28 22:29:30 +0200 | [diff] [blame] | 71 | kqo <- corpusQuery(kco, query, vc=paste0(vc, regions[i,]$query)) |
| 72 | regions[i,]$afreq <- kqo@totalResults |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 73 | regions[i,]$freq <- regions[i,]$afreq / regions[i,]$total |
Marc Kupietz | 9402dec | 2019-09-28 22:29:30 +0200 | [diff] [blame] | 74 | regions[i,]$url <- kqo@webUIRequestUrl |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 75 | } |
| 76 | cat(regions[i,]$afreq, regions[i,]$total, regions[i,]$freq, "\n") |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 77 | cat("\n\n") |
| 78 | } |
| 79 | } |
Marc Kupietz | 3da02eb | 2019-10-04 09:15:00 +0200 | [diff] [blame] | 80 | plot <- updatePlot(query, map, regions) |
Marc Kupietz | 5fb892e | 2021-03-05 08:18:25 +0100 | [diff] [blame] | 81 | print(plot) |
| 82 | plot |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 83 | } |
| 84 | |
Marc Kupietz | 9402dec | 2019-09-28 22:29:30 +0200 | [diff] [blame] | 85 | updatePlot <- function(query, map, regions) { |
| 86 | map$ipm <- sapply(map$grp, function(grp) regions$freq[grp] * 10^6) |
| 87 | map$region <- sapply(map$grp, function(grp) regions$region[grp]) |
| 88 | map$url <- sapply(map$grp, function(grp) regions$url[grp]) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 89 | regionsPlot <- ggplot(map) + |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 90 | geom_sf(aes(fill = ipm), colour = "black", linewidth = .1) + |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 91 | theme(axis.line.x = element_blank(), |
| 92 | axis.line.y = element_blank(), |
| 93 | panel.grid.major = element_blank(), |
| 94 | panel.grid.minor = element_blank(), |
| 95 | panel.border = element_blank(), |
| 96 | panel.background = element_blank(), |
| 97 | axis.line=element_blank(),axis.text.x=element_blank(), |
| 98 | axis.text.y=element_blank(),axis.ticks=element_blank(), |
| 99 | axis.title.x=element_blank(), |
| 100 | axis.title.y=element_blank()) + |
Marc Kupietz | 4d8824c | 2025-08-17 12:37:24 +0200 | [diff] [blame^] | 101 | coord_sf() + |
Marc Kupietz | e457d99 | 2019-09-29 18:17:05 +0200 | [diff] [blame] | 102 | labs(title = sprintf("Regional distribution of \u201c%s\u201d", query)) |
Marc Kupietz | 451980d | 2019-09-23 23:45:10 +0200 | [diff] [blame] | 103 | print(regionsPlot) |
| 104 | regionsPlot |
| 105 | } |
| 106 | |
| 107 | #geoDistrib("wegen dem [tt/p=NN]") |
| 108 | geoDistrib("heuer") |
| 109 | #geoDistrib("Sonnabend") |
| 110 | #geoDistrib("eh") |