# Nuts Transformation
#'
#'
#'
#'
#'nuts heatmap output
#' @param group.by a charater vector of regional classification: "REGION" (FADN REGION with 3 numbers),
#' "NUTS1", "NUTS2" or "NUTS3" (A NUTS code begins with 2 letter code referencing the country, as abbr. in
#' the EU's Interinstitutional Style Guide).
#' @param countries a character vector with 3 letter codes of countries:
#' "DEU" for germany, "BEL" for belgium. if "all" is included, all countries are loaded and plotted.
#' @author Yang
#' @describeIn
#' @export
#' @examples
#' nuts.heatmap.group(str_data$info, "NUTS1")
nuts.heatmap.group <- function(fadn.data.info, group.by, countries = "all", onepage = FALSE){
#create DIR>plots ---
ifelse(!dir.exists(paste0(CurrentProjectDirectory,"/plot")),
dir.create(paste0(CurrentProjectDirectory,"/plot")), FALSE)
# dir.create(paste0(CurrentProjectDirectory,"/plot"), FALSE)
dir.create(paste0(CurrentProjectDirectory,"/plot/", "fadn_",
group.by,"_plots"),
if(countries == "all") countries <- unique(fadn.data.info$COUNTRY)
for (country in countries){
heatmap_data <- fadn.data.info %>%
filter(COUNTRY == country) %>%
count(.data[[group.by]],YEAR) %>%
arrange(YEAR) %>%
# pivot_wider(names_from = YEAR,values_from=n) %>%
mutate(across(3:last_col(),function(x)ifelse(is.na(x),0,1)))
# pivot_longer(c(`2004`:`2018` ), names_to = "YEAR", values_to = "n")
heatmap_data <- data.frame(lapply(heatmap_data,as.character))
path_png <- paste0(CurrentProjectDirectory,"/plot/","fadn_",group.by,"_plots/")
if (group.by == "NUTS3" && NROW(heatmap_data$NUTS3 %>% unique()) >100 ) {
text.size = 3
} else{text.size = 11}
p <- heatmap_data %>% ggplot(aes(YEAR, .data[[group.by]], fill= n)) + geom_tile() +
theme() +
ggtitle(country) +
xlab("YEAR") +
ylab(group.by) +
# theme_bw() +
theme(axis.text.y = element_text(size = text.size),legend.position="none")
# multiple plots in one page
p_name <- country
ggsave(plot = p ,
filename = paste0(path_png, country,".png"),
width = 18, height = 8)
assign(p_name, heatmap_data %>% ggplot ( aes(YEAR,.data[[group.by]], fill= n)) +
geom_tile() +
theme(legend.position="none",
axis.text.y = element_text(size = text.size),
axis.text.x = element_text(angle = 45)) +
ggtitle(country))
if(onepage== TRUE) {
png(paste0(path_png,"all_countries.png"), width = 1080, height =1080, units = "px" )
# plots <- list(NED, BEL, BGR, CYP, CZE,DAN,DEU,ELL,ESP,EST,FRA,HUN,IRE,ITA,LTU,LUX,LVA,MLT,OST,POL,POR,ROU,SUO,SVE,SVK,SVN,UKI,HRV)
# mulp <-
multiplot(NED, BEL, BGR, CYP, CZE,DAN,DEU,ELL,ESP,EST,FRA,HUN,IRE,ITA,LTU,LUX,LVA,MLT,OST,POL,POR,ROU,SUO,SVE,SVK,SVN,UKI,HRV, cols=5)
dev.off()}
# ggsave(plot = mulp ,
# filename = paste0(path_png,"all_countries.png"),
# width = 18, height = 8)
multiplot <- function(..., plotlist=NULL, cols) {
require(grid)
# Make a list from the ... arguments and plotlist
plots <- c(list(...), plotlist)
numPlots = length(plots)
# Make the panel
plotCols = cols # Number of columns of plots
plotRows = ceiling(numPlots/plotCols) # Number of rows needed, calculated from # of cols
# Set up the page
grid.newpage()
pushViewport(viewport(layout = grid.layout(plotRows, plotCols)))
vplayout <- function(x, y)
viewport(layout.pos.row = x, layout.pos.col = y)
# Make each plot, in the correct location
for (i in 1:numPlots) {
curRow = ceiling(i/plotCols)
curCol = (i-1) %% plotCols + 1
print(plots[[i]], vp = vplayout(curRow, curCol ))
}
}
#' this function related to converting NUTS between different NUTS version in both directions.
#'
#' @param data the data
#' @param countries the three letters code (e.g. "DEU") or "all".
#' If "all" is included, all available countries are loaded.
#' @param NUTS.Year a numeric vector, the year of NUTS (2003,2006,2010,2013,2016).
#' @export
#' @examples
#' ## NOT run:
#' NUTS.convert.all(str_data$info, "DEU", 2016)
#' NUTS.convert.all(str_data$info, "all", 2016)
#' NUTS.convert.all(str_data$info, c("DEU","POL","UKI"), 2016)
#' ## End (NOT run)
NUTS.convert.all<- function(data, countries, NUTS.Year){
# data = test_data
# data = test_data
# countries = c("ELL", special_countries)
# NUTS.Year = 2003
NUTS.Year.eurostat <- c("2003", "2006", "2010", "2013", "2016")
keep_columns_data <- c(colnames(data), "NUTS1_final", "NUTS2_final")
years = unique(data$YEAR)
# selected COUNTRY-YEAR in data
# if (!NUTS.Year %in% years){warning(NUTS.Year, " was not found in your given data")}
if (!NUTS.Year %in% NUTS.Year.eurostat){
warning(NUTS.Year, " was not found in NUTS versions! \nPls give the following NUTS versions:\n2003 2006, 2010, 2013 or 2016.")
return("Please give the following NUTS versions: 2003 2006, 2010, 2013 or 2016")}
if("all"%in%countries) {countries= unique(data$COUNTRY)}
# nuts2
filtered.nuts.trans_left <- nuts2.trans %>%
separate(version, sep="To", c("from", "to"), extra = "drop", fill = "left" ) %>%
filter( to <=NUTS.Year | is.na(to)) %>% filter(COUNTRY %in% countries)
filtered.nuts.trans_right <- nuts2.trans %>%
separate(version, sep="To", c("from", "to"), extra = "drop", fill = "left" ) %>%
filter( to >NUTS.Year ) %>% filter(COUNTRY %in% countries)
# nuts3
filtered.nuts3.trans_left <- nuts3.trans %>%
separate(version, sep="To", c("from", "to"), extra = "drop", fill = "left" ) %>%
filter( to <=NUTS.Year | is.na(to)) %>% filter(COUNTRY %in% countries)
filtered.nuts3.trans_right <- nuts3.trans %>%
separate(version, sep="To", c("from", "to"), extra = "drop", fill = "left" ) %>%
filter( to >NUTS.Year ) %>% filter(COUNTRY %in% countries)
# filtered.countries <- filtered.nuts.trans_left$COUNTRY %>% unique()
special_countries <- c("SVN","HUN","POL","SUO","LTU","IRE","UKI")
data_recoded <- data %>% filter(COUNTRY %in% countries & !COUNTRY %in% special_countries)
if (nrow(data_recoded)!=0){recoded = TRUE}else{recoded = FALSE}
data_rest <- data %>% filter(COUNTRY %in% countries & COUNTRY %in% special_countries)
if (nrow(data_rest)!=0){special = TRUE} else {special = FALSE}
recoded_c <- c(unique(data_recoded$COUNTRY))
# data_rest %>% select(COUNTRY) %>% unique()
# recoded
if(recoded == TRUE){
cat("Countries: ", recoded_c,"\nConverting......\n")
# old to new ......
## as we have at maximum two changes of NUTS regulation, we left join two times
test_data_nuts2 <- data_recoded %>%
left_join(filtered.nuts.trans_left, by = c( "NUTS2", "COUNTRY"))
test_data_nuts2 <- test_data_nuts2 %>%
left_join(filtered.nuts.trans_left, by = c("NUTS2_new"="NUTS2", "COUNTRY"))
## Now we generate the final NUTS2 regulation based on the left joins
recoded_final <- test_data_nuts2 %>%
mutate(NUTS2_final=case_when(
is.na(NUTS2_new) & is.na(NUTS2_new.y) ~ NUTS2,
!is.na(NUTS2_new) & is.na(NUTS2_new.y) ~ NUTS2_new,
TRUE ~ NUTS2_new.y
)) %>% select(-contains(".x"),-contains(".y"), -NUTS2_new)
# new to old ......
new2old_1 <- recoded_final %>%
left_join(filtered.nuts.trans_right, by = c( "NUTS2"= "NUTS2_new", "COUNTRY"))