Skip to content

Commit

Permalink
Create stratifier forms
Browse files Browse the repository at this point in the history
  • Loading branch information
@heleenderoo
heleenderoo committed Dec 6, 2023
1 parent 6b9f091 commit 76a7737
Show file tree
Hide file tree
Showing 2 changed files with 273 additions and 5 deletions.
274 changes: 270 additions & 4 deletions src/stock_calculations/carbon_stock_calculations.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -700,7 +700,7 @@ write.csv2(plot_c_stocks,



# Test function
# 1. Calculate stocks ----

source("./src/stock_calculations/functions/get_stocks.R")

Expand All @@ -715,7 +715,7 @@ get_stocks(survey_form = "so_pfh",



# 6. Visual check per plot
# 2. Compile data per level ----

df_layer <-
bind_rows(so_som_below_ground %>%
Expand Down Expand Up @@ -763,7 +763,8 @@ df_layer <-
df_stocks <-
bind_rows(so_som_profile_c_stocks %>%
mutate(survey_form = "so_som") %>%
relocate(survey_form, .before = partner_short),
relocate(survey_form, .before = partner_short) %>%
mutate(repetition = as.character(repetition)),
so_pfh_profile_c_stocks %>%
mutate(survey_form = "so_pfh") %>%
relocate(survey_form, .before = partner_short)) %>%
Expand All @@ -776,7 +777,272 @@ df_stocks <-
profile_id)



# 3. Add stratifiers ----

d_forest_type <-
read.csv2("./data/additional_data/d_forest_type.csv") %>%
select(code, short_descr) %>%
mutate(code = as.character(code))

d_soil_group <-
read.csv2("./data/raw_data/so/adds/dictionaries/d_soil_group.csv") %>%
select(code, description)

d_humus <-
read.csv2("./data/raw_data/so/adds/dictionaries/d_humus.csv") %>%
filter(is.na(valid_to_survey_year)) %>%
arrange(code) %>%
select(code, description)

d_tree_spec <-
read.csv2("./data/raw_data/si/adds/dictionaries/d_tree_spec.csv") %>%
select(code, description)

# Import the shapefile with biogeographical regions
biogeo_sf <-
read_sf(paste0("./data/additional_data/shapefiles/",
"BiogeoRegions2016.shp")) %>%
# Reduce the file size
st_simplify(dTolerance = 1000) %>%
# Remove category "outside"
filter(.data$short_name != "outside") %>%
# Rename category "Black Sea"
mutate(code = if_else(.data$short_name == "blackSea",
"Black Sea", .data$code)) %>%
select(code, geometry)


## 3.1. "so" ----

# Get manually harmonised WRB and EFTC

assertthat::assert_that(file.exists(paste0("./data/additional_data/",
"SO_PRF_ADDS.xlsx")),
msg = paste0("'./data/additional_data/",
"SO_PRF_ADDS.xlsx' ",
"does not exist."))

so_prf_adds <-
openxlsx::read.xlsx(paste0("./data/additional_data/",
"SO_PRF_ADDS.xlsx"),
sheet = 2) %>%
rename(bs_class = "BS.(high/low)",
plot_id = PLOT_ID)

so_strat <- so_prf_adds %>%
mutate(soil_wrb = paste0(RSGu, "_",
QUALu, "_",
SPECu, "_",
METHOD_RSGu, "_",
DEPTHSTOCK, "_",
bs_class, "_",
EFTC, "_",
remark)) %>%
group_by(plot_id) %>%
# Sometimes there are different options, e.g. plot_id 60_9
# No good way to solve this - we just have to pick one
summarise(soil_wrb =
names(which.max(table(soil_wrb[!is.na(soil_wrb)])))) %>%
# Split the data back into the original columns
separate(soil_wrb,
into = c("code_wrb_soil_group",
"code_wrb_qualifier_1",
"code_wrb_spezifier_1",
"method_wrb_harmonisation_fscc",
"eff_soil_depth",
"bs_class",
"code_forest_type",
"remark_harmonisation_fscc"),
sep = "_") %>%
left_join(data_availability_so %>%
select(plot_id, partner_short),
by = "plot_id") %>%
relocate(partner_short, .before = plot_id) %>%
mutate(eff_soil_depth = as.numeric(eff_soil_depth)) %>%
mutate_all(~ifelse((.) == "NA", NA, .)) %>%
mutate_all(~ifelse((.) == "", NA, .)) %>%
left_join(d_forest_type,
by = join_by(code_forest_type == code)) %>%
rename(forest_type = short_descr) %>%
left_join(d_soil_group,
by = join_by(code_wrb_soil_group == code)) %>%
rename(wrb_soil_group = description)


# Add coordinates

source("./src/functions/as_sf.R")

so_strat_sf <- so_strat %>%
left_join(coordinates_so, by = "plot_id") %>%
as_sf

# Add biogeographical region

so_strat <- st_join(so_strat_sf, biogeo_sf) %>%
rename(biogeo = code) %>%
st_drop_geometry() %>%
arrange(partner_short) %>%
# Add main tree species
left_join(si_sta %>%
select(plot_id, code_tree_species) %>%
filter(code_tree_species != -9) %>%
filter(!is.na(code_tree_species)) %>%
group_by(plot_id, code_tree_species) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_tree_species),
by = "plot_id") %>%
left_join(d_tree_spec,
by = join_by(code_tree_species == code)) %>%
rename(main_tree_species = description) %>%
# Add humus type
left_join(so_prf %>%
select(plot_id, code_humus) %>%
filter(code_humus != 99) %>%
filter(!is.na(code_humus)) %>%
group_by(plot_id, code_humus) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_humus),
by = "plot_id") %>%
left_join(d_humus,
by = join_by(code_humus == code)) %>%
rename(humus_type = description) %>%
select(partner_short,
plot_id,
longitude_dec,
latitude_dec,
wrb_soil_group,
forest_type,
humus_type,
biogeo,
main_tree_species,
bs_class,
code_wrb_soil_group,
code_wrb_qualifier_1,
code_wrb_spezifier_1,
code_forest_type,
code_humus,
code_tree_species)



## 3.1. "s1" ----

# df_humus <-
# bind_rows(y1_st1 %>%
# select(plot_id, code_humus),
# s1_prf %>%
# select(plot_id, code_humus)) %>%
# filter(code_humus != 99) %>%
# filter(!is.na(code_humus)) %>%
# group_by(plot_id, code_humus) %>%
# summarise(count = n(),
# .groups = "drop") %>%
# group_by(plot_id) %>%
# arrange(-count) %>%
# slice_head() %>%
# ungroup() %>%
# select(plot_id, code_humus)


s1_strat <- s1_som %>%
distinct(plot_id) %>%
left_join(data_availability_s1 %>%
select(plot_id, partner_short),
by = "plot_id") %>%
relocate(partner_short, .before = plot_id)

s1_strat_sf <- s1_strat %>%
left_join(coordinates_s1, by = "plot_id") %>%
as_sf

s1_strat <-
st_join(s1_strat_sf, biogeo_sf) %>%
rename(biogeo = code) %>%
st_drop_geometry() %>%
arrange(partner_short) %>%
# Add WRB etc
left_join(s1_prf %>%
select(plot_id, code_wrb_soil_group,
code_wrb_qualifier_1, code_wrb_spezifier_1) %>%
filter(!is.na(code_wrb_soil_group)) %>%
group_by(plot_id, code_wrb_soil_group,
code_wrb_qualifier_1, code_wrb_spezifier_1) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_wrb_soil_group,
code_wrb_qualifier_1, code_wrb_spezifier_1)) %>%
left_join(d_soil_group,
by = join_by(code_wrb_soil_group == code)) %>%
rename(wrb_soil_group = description) %>%
# Add forest type
left_join(y1_st1 %>%
select(plot_id, code_forest_type) %>%
filter(code_forest_type != 99) %>%
filter(!is.na(code_forest_type)) %>%
group_by(plot_id, code_forest_type) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_forest_type),
by = "plot_id") %>%
left_join(d_forest_type,
by = join_by(code_forest_type == code)) %>%
rename(forest_type = short_descr) %>%
# Add humus type
left_join(df_humus <-
bind_rows(y1_st1 %>%
select(plot_id, code_humus),
s1_prf %>%
select(plot_id, code_humus)) %>%
filter(code_humus != 99) %>%
filter(!is.na(code_humus)) %>%
group_by(plot_id, code_humus) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_humus),
by = "plot_id") %>%
left_join(d_humus,
by = join_by(code_humus == code)) %>%
rename(humus_type = description) %>%
# Add main tree species
left_join(y1_st1 %>%
select(plot_id, code_tree_species) %>%
filter(code_tree_species != -9) %>%
filter(!is.na(code_tree_species)) %>%
group_by(plot_id, code_tree_species) %>%
summarise(count = n(),
.groups = "drop") %>%
group_by(plot_id) %>%
arrange(-count) %>%
slice_head() %>%
ungroup() %>%
select(plot_id, code_tree_species),
by = "plot_id") %>%
left_join(d_tree_spec,
by = join_by(code_tree_species == code)) %>%
rename(main_tree_species = description)



Expand Down
4 changes: 3 additions & 1 deletion src/transformation_to_layer1/solid_soil_data_transformation_to_layer1.R
View file
Original file line number Diff line number Diff line change
Expand Up @@ -60,7 +60,7 @@ sync_local_data(list_subfolders_data = "raw_data",

# Input level ----

level <- "LI"
level <- "LII"


# Define surveys and survey forms within level
Expand Down Expand Up @@ -562,6 +562,7 @@ so_prf_adds_agg <- so_prf_adds %>%
METHOD_RSGu, "_",
DEPTHSTOCK, "_",
bs_class, "_",
EFTC, "_",
remark)) %>%
group_by(plot_id) %>%
# Sometimes there are different options, e.g. plot_id 60_9
Expand All @@ -576,6 +577,7 @@ so_prf_adds_agg <- so_prf_adds %>%
"method_wrb_harmonisation_fscc",
"eff_soil_depth",
"bs_class",
"forest_type",
"remark_harmonisation_fscc"),
sep = "_") %>%
mutate(eff_soil_depth = as.numeric(eff_soil_depth))
Expand Down

0 comments on commit 76a7737

Please sign in to comment.