koppen

zoometh · Feb 24, 2024 · fccdbb7 · fccdbb7
1 parent 4ad3410
commit fccdbb7
Show file tree

Hide file tree

Showing 14 changed files with 256 additions and 117 deletions.
diff --git a/R/neo_isochr.R b/R/neo_isochr.R
@@ -29,9 +29,9 @@ neo_isochr <- function(df.c14 = "https://raw.githubusercontent.com/zoometh/neone
                        time.line.size = 1,
                        bck.alpha = .2,
                        zoom = NA,
-                       lbl.dates = TRUE,
+                       lbl.dates = FALSE,
                        lbl.dates.size = 2,
-                       lbl.time.interv = TRUE,
+                       lbl.time.interv = FALSE,
                        lbl.time.interv.size = 3,
                        coloramp = c("Reds", "Blues"),
                        mapname = NA,
@@ -45,10 +45,15 @@ neo_isochr <- function(df.c14 = "https://raw.githubusercontent.com/zoometh/neone
   # check which periods have been selected
   neolithic <- selected.per %in% c("EN", "EMN", "MN", "LN", "UN")
   paleolithic <- !neolithic
-  df.dates <- sf::st_read(df.c14, quiet = T)
+  if(is.character(df.c14)){
+    df.dates <- sf::st_read(df.c14, quiet = T)
+  }
+  if(inherits(df.c14, "sf")){
+    df.dates <- df.c14
+  }
   nb.dates.tot <- nrow(df.dates)
   if(verbose){
-    print(paste0("Original GeoJSON file: ", nb.dates.tot, " dates"))
+    print(paste0("Original file: ", nb.dates.tot, " dates"))
   }
   # subset on periods
   df.dates <- df.dates[df.dates$Period %in% selected.per, ]
@@ -164,9 +169,10 @@ neo_isochr <- function(df.c14 = "https://raw.githubusercontent.com/zoometh/neone
     stamenbck <- tryCatch(ggmap::get_stadiamap(bbox, 
                                                zoom = zoom,
                                                maptype = "stamen_terrain_background"), error = function(e) NULL)
-    # stamenbck <- tryCatch(ggmap::get_stamenmap(bbox, 
+    # stamenbck <- tryCatch(ggmap::get_stamenmap(bbox,
     #                                            zoom = zoom,
     #                                            maptype = "terrain-background"), error = function(e) NULL)
+    # stamenbck <- ggmap::get_stamenmap(bbox, maptype = "terrain-background")
     zoom <- zoom - 1
     if (!is.null(stamenbck)) {
       print(zoom)

diff --git a/R/neo_kcc.R b/R/neo_kcc.R
@@ -0,0 +1,29 @@
+neo_kcc <- function(){
+  kcc <- "C:/Rprojects/neonet/doc/data/clim/koeppen_7k.tif"
+  kcc_geo <- terra::rast(kcc)
+  # colors
+  colors <- terra::coltab(kcc_geo)[[1]] # Get the color table for the first (or only) layer
+  cat_df <- levels(kcc_geo)[[1]] # Get the levels/categories for the first (or only) layer
+  final_df$hexColour <- rgb(final_df$colour.red, final_df$colour.green, final_df$colour.blue, maxColorValue = 255)
+  color_vector <- setNames(final_df$hexColour, final_df$code)
+  # kcc_geo <- raster::raster(kcc)
+  raster_df <- as.data.frame(kcc_geo, xy = TRUE)
+  bbox <- st_bbox(df.c14)
+  ggplot2::ggplot() +
+    ggplot2::geom_raster(data = raster_df, aes(x = x, y = y, fill = factor(code))) + 
+    ggplot2::geom_sf(data = df.c14, color = "black", size = 0.5) +  # Add the sf object, assuming df.c14 is ready
+    ggplot2::coord_sf() +  # Use coordinate system from sf object
+    ggplot2::scale_fill_manual(values = color_vector) +  # Map fill colors using color_vector
+    ggplot2::labs(fill = "Climate Code") + # Optional: add a legend title
+    ggplot2::coord_sf(xlim = c(bbox$xmin, bbox$xmax), ylim = c(bbox$ymin, bbox$ymax))
+}
+
+ggplot() +
+  ggplot2::geom_raster(data = raster_df, aes(x = x, y = y, fill = factor(code))) + 
+  ggplot2::scale_fill_manual(values = color_vector) +  # Map fill colors using color_vector
+  ggplot2::geom_sf(data = df.c14, color = "red", size = 0.5) +  # Add the sf object
+  ggplot2::coord_sf() +  # Use coordinate system from sf object
+  ggplot2::labs(fill = "Climate Code") + # Optional: add a legend title
+  ggplot2::coord_sf(xlim = c(bbox$xmin, bbox$xmax), ylim = c(bbox$ymin, bbox$ymax))
+
+
diff --git a/R/neo_leapfrog.R b/R/neo_leapfrog.R
@@ -1,4 +1,5 @@
 #' Read, format and merge Leapfrog dataset and cultures with NeoNet
+#' # v. "C:\Rprojects\leapfrog"
 #'
 #' @name neo_leapfrog
 #'

diff --git a/README.md b/README.md
@@ -369,8 +369,43 @@ Add the [pastclim](https://github.com/EvolEcolGroup/pastclim) generated Koppen C
 * [Contribution rules](https://github.com/zoometh/neonet/blob/master/github/CONTRIBUTING.md)
 * [NeoNet package license](https://github.com/zoometh/neonet/blob/master/LICENSE)
 
-### Communication
+## Communication
 
 * Big Historical Data Conference
   - Shiny server (with the app embeded): http://shinyserver.cfs.unipi.it:3838/neonet/bhdc
   - GitHub (without the app embeded): https://zoometh.github.io/neonet/doc/talks/2023-bhdc
+
+## Koppen
+
+| KoppenCode |   list | values                                    | hexa   | color                                                    |
+|------------|-------:|:------------------------------------------|:-------|:---------------------------------------------------------|
+| Af         |      1 | Tropical, rainforest                      | 0000FF | ![#0000FF](https://placehold.co/15x15/0000FF/0000FF.png) |
+| Am         |      2 | Tropical, monsoon                         | 0078FF | ![#0078FF](https://placehold.co/15x15/0078FF/0078FF.png) |
+| Aw         |      3 | Tropical, savannah                        | 46AAF  | ![#46AAF](https://placehold.co/15x15/46AAF/46AAF.png)    |
+| BWh        |      4 | Arid, desert, hot                         | FF0000 | ![#FF0000](https://placehold.co/15x15/FF0000/FF0000.png) |
+| BWk        |      5 | Arid, desert, cold                        | FF9696 | ![#FF9696](https://placehold.co/15x15/FF9696/FF9696.png) |
+| BSh        |      6 | Arid, steppe, hot                         | F5A500 | ![#F5A500](https://placehold.co/15x15/F5A500/F5A500.png) |
+| BSk        |      7 | Arid, steppe, cold                        | FFDC64 | ![#FFDC64](https://placehold.co/15x15/FFDC64/FFDC64.png) |
+| Csa        |      8 | Temperate, dry summer, hot summer         | FFFF00 | ![#FFFF00](https://placehold.co/15x15/FFFF00/FFFF00.png) |
+| Csb        |      9 | Temperate, dry summer, warm summer        | C8C800 | ![#C8C800](https://placehold.co/15x15/C8C800/C8C800.png) |
+| Csc        |     10 | Temperate, dry summer, cold summer        | 969600 | ![#969600](https://placehold.co/15x15/969600/969600.png) |
+| Cwa        |     11 | Temperate, dry winter, hot summer         | 96FF96 | ![#96FF96](https://placehold.co/15x15/96FF96/96FF96.png) |
+| Cwb        |     12 | Temperate, dry winter, warm summer        | 64C864 | ![#64C864](https://placehold.co/15x15/64C864/64C864.png) |
+| Cwc        |     13 | Temperate, dry winter, cold summer        | 329632 | ![#329632](https://placehold.co/15x15/329632/329632.png) |
+| Cfa        |     14 | Temperate, no dry season, hot summer      | C8FF50 | ![#C8FF50](https://placehold.co/15x15/C8FF50/C8FF50.png) |
+| Cfb        |     15 | Temperate, no dry season, warm summer     | 64FF50 | ![#64FF50](https://placehold.co/15x15/64FF50/64FF50.png) |
+| Cfc        |     16 | Temperate, no dry season, cold summer     | 32C800 | ![#32C800](https://placehold.co/15x15/32C800/32C800.png) |
+| Dsa        |     17 | Cold, dry summer, hot summer              | FF00FF | ![#FF00FF](https://placehold.co/15x15/FF00FF/FF00FF.png) |
+| Dsb        |     18 | Cold, dry summer, warm summer             | C800C8 | ![#C800C8](https://placehold.co/15x15/C800C8/C800C8.png) |
+| Dsc        |     19 | Cold, dry summer, cold summer             | 963296 | ![#963296](https://placehold.co/15x15/963296/963296.png) |
+| Dsd        |     20 | Cold, dry summer, very cold winter        | 966496 | ![#966496](https://placehold.co/15x15/966496/966496.png) |
+| Dwa        |     21 | Cold, dry winter, hot summer              | AAAF   | ![#AAAF](https://placehold.co/15x15/AAAF/AAAF.png)       |
+| Dwb        |     22 | Cold, dry winter, warm summer             | 5A78DC | ![#5A78DC](https://placehold.co/15x15/5A78DC/5A78DC.png) |
+| Dwc        |     23 | Cold, dry winter, cold summer             | 4B50B4 | ![#4B50B4](https://placehold.co/15x15/4B50B4/4B50B4.png) |
+| Dwd        |     24 | Cold, dry winter, very cold winter        | 320087 | ![#320087](https://placehold.co/15x15/320087/320087.png) |
+| Dfa        |     25 | Cold, no dry season, hot summer           | 00FFFF | ![#00FFFF](https://placehold.co/15x15/00FFFF/00FFFF.png) |
+| Dfb        |     26 | Cold, no dry season, warm summer          | 37C8FF | ![#37C8FF](https://placehold.co/15x15/37C8FF/37C8FF.png) |
+| Dfc        |     27 | Cold, no dry season, cold summer          | 007D7D | ![#007D7D](https://placehold.co/15x15/007D7D/007D7D.png) |
+| Dfd        |     28 | Cold, no dry season, very cold winter     | 00465F | ![#00465F](https://placehold.co/15x15/00465F/00465F.png) |
+| ET         |     29 | Polar, tundra                             | B2B2B2 | ![#B2B2B2](https://placehold.co/15x15/B2B2B2/B2B2B2.png) |
+| EF         |     30 | Polar, frost                              | 666666 | ![#666666](https://placehold.co/15x15/666666/666666.png) |
diff --git a/doc/bhdc.R → doc/talks/2023-bhdc/bhdc.R b/doc/bhdc.R → doc/talks/2023-bhdc/bhdc.R
diff --git a/doc/talks/2024-simep/collect_c14.R → ...talks/2024-simep/(archives)/collect_c14.R b/doc/talks/2024-simep/collect_c14.R → ...talks/2024-simep/(archives)/collect_c14.R
diff --git a/doc/talks/2024-simep/collect_c14_1.R → ...lks/2024-simep/(archives)/collect_c14_1.R b/doc/talks/2024-simep/collect_c14_1.R → ...lks/2024-simep/(archives)/collect_c14_1.R
diff --git a/doc/talks/2024-simep/collect_c14_2.R → ...lks/2024-simep/(archives)/collect_c14_2.R b/doc/talks/2024-simep/collect_c14_2.R → ...lks/2024-simep/(archives)/collect_c14_2.R
diff --git a/doc/talks/2024-simep/collect_c14_3.R b/doc/talks/2024-simep/collect_c14_3.R
@@ -9,123 +9,118 @@ library(gridExtra)
 library(sf)
 library(rnaturalearth)
 
+fspat <- function(df_selected, roi, outfile){
+  ## distribution spat = map
+  df_spat <- st_as_sf(df_selected, coords = c("lon", "lat"), crs = 4326)
+  buff <- .5
+  world <- ne_countries(scale = "medium", returnclass = "sf")
+  distr_spat <- ggplot2::ggplot(world) +
+    # TODO: color scale ramp on column 'c14age_uncalBC'
+    ggplot2::geom_sf() +
+    ggplot2::geom_sf(data = df_spat, inherit.aes = FALSE, size = 1) +
+    ggplot2::coord_sf(xlim = c(sf::st_bbox(roi)[1] - buff, sf::st_bbox(roi)[3] + buff),
+                      ylim = c(sf::st_bbox(roi)[2] - buff, sf::st_bbox(roi)[4] + buff)) +
+    ggplot2::theme_bw() +
+    ggplot2::theme(axis.text = ggplot2::element_text(size = 6)) 
+  g.out <- paste0("C:/Rprojects/neonet/doc/talks/2024-simep/img/", outfile)
+  ggsave(file = g.out, distr_spat, width = 14, height = 10)
+}
 
+parse_db <- function(l.dbs, df.all, col.req){
+  for(selected.db in l.dbs){
+    # selected.db <- l.dbs[i]
+    # selected.db <- "calpal"
+    print(paste0("*read: ", selected.db))
+    df <- get_c14data(selected.db) # YES period, culture
+    print(paste0("  n = ", nrow(df)))
+    # colnames(df)
+    ## filters
+    is.not.both <- !("culture" %in% colnames(df) & "period" %in% colnames(df))
+    is.not.period <- !("period" %in% colnames(df))
+    is.not.culture <- !("culture" %in% colnames(df))
+    df_selected <- df
+    if(is.not.both & is.not.culture){
+      df_selected$culture <- NA 
+    }
+    if(is.not.both & is.not.period){
+      df_selected$period <- NA 
+    }
+    df_selected <- df_selected[ , col.req]
+    df_selected <- df_selected %>%
+      filter(!(is.na("period") & is.na("culture")))
+    df_selected$c14age_uncalBC <- df_selected$c14age - present
+    df_selected$c14age_uncalBC <- - df_selected$c14age_uncalBC# data
+    # df_selected <- df_selected[complete.cases(df_selected[col.req]), ]
+    # chrono
+    df_selected <- df_selected[df_selected$c14age_uncalBC > chr.interval.uncalBC[1] & df_selected$c14age_uncalBC < chr.interval.uncalBC[2], ]
+    nrow(df_selected)
+    # spatial
+    df_selected <- df_selected[!(df_selected$lon == "" & df_selected$lat == ""), ]
+    df_selected <- df_selected[!is.na(df_selected$lon) & !is.na(df_selected$lat), ]
+    # df_selected <- df_selected %>%
+    #   filter(!(is.na("lon") & is.na("lat")))
+    df_sf <- st_as_sf(df_selected, coords = c("lon", "lat"), crs = 4326)
+    inside <- st_within(df_sf, roi, sparse = FALSE)
+    df_selected <- df_selected[inside, ]
+    df_selected <- df_selected[, col.req]
+    df.all <- rbind(df.all, df_selected)
+  }
+  return(df.all)
+}
+
+fref <- function(df.all.res, outfile = "df_ref_per.xlsx"){
+  print(unique(df.all.res$sourcedb))
+  df.ref.per <- df.all.res[, c("period", "culture")]
+  df.ref.per <- df.ref.per[!duplicated(df.ref.per), ]
+  openxlsx::write.xlsx(df.ref.per, paste0(root.path, "/", outfile))
+}
+
+frm_duplicates <- function(df.classes){
+  df.classes <- df.classes[!duplicated(df.classes$labnr), ]
+  return(df.classes)
+}
+
+fread_ref <- function(infile = "C:/Rprojects/neonet/doc/talks/2024-simep/df_ref_per.xlsx"){
+  df_ref_per <- openxlsx::read.xlsx(infile)
+  df_ref_per$class <- toupper(df_ref_per$class)
+  df_ref_per <- df_ref_per[!is.na(df_ref_per$class), ]
+  return(df_ref_per)
+}
+
+root.path <-"C:/Rprojects/neonet/doc/talks/2024-simep"
 present <- 1950
 chr.interval.uncalBC <- c(-9000, -4000)
 roi <- sf::st_read("https://raw.githubusercontent.com/zoometh/neonet/main/doc/talks/2024-simep/roi.geojson",
                    quiet = TRUE)
-listing.head <- 60
-listing.sz <- .7
-# layouts
-mytheme.listing <- gridExtra::ttheme_default(
-  core = list(fg_params = list(cex = listing.sz),
-              padding = unit(c(1, 1), "mm")),
-  colhead = list(fg_params = list(cex = listing.sz)),
-  rowhead = list(fg_params = list(cex = listing.sz)))
-lay <- rbind(c(1, 1, 1, 1, 1, 1, 4, 4, 4, 4), 
-             c(1, 1, 1, 1, 1, 1, 3, 3, 3, 3), 
-             c(1, 1, 1, 1, 1, 1, 3, 3, 3, 3), 
-             c(1, 1, 1, 1, 1, 1, 3, 3, 3, 3),
-             c(2, 2, 2, 2, 2, 2, 3, 3, 3, 3), 
-             c(2, 2, 2, 2, 2, 2, 3, 3, 3, 3))
-
 # dbs
 # DB not done: kiteeastafrica, nerd, aida,  (no culture)
 # DB done: calpal, medafricarbon, agrichange, neonet, bda, calpal, radon, katsianis
+l.dbs <- c("calpal", "medafricarbon", "agrichange", "neonet", "bda", "calpal", "radon", "katsianis")
+# l.dbs <- c("calpal", "medafricarbon")
+col.req <- c("sourcedb", "site", "labnr", "c14age", "c14std", "period", "culture", "lon", "lat")
+df.all <- setNames(data.frame(matrix(ncol = length(col.req), nrow = 0)), col.req)
+df.all.res <- parse_db(l.dbs, df.all, col.req, outfile = "_db__all.png")
+# fspat(df.all.res, roi, outfile = "_db__all_class.png")
+# fspat(df.all.res, roi, outfile = "_db__all.png")
+df_ref_per <- fread_ref("C:/Rprojects/neonet/doc/talks/2024-simep/df_ref_per.xlsx")
+df_ref_per$period_culture <- paste0(df_ref_per$period, "/", df_ref_per$culture)
+df.all.res$period_culture <- paste0(df.all.res$period, "/", df.all.res$culture)
+df.classes <- merge(df.all.res, df_ref_per, by = "period_culture")
+df.classes <- frm_duplicates(df.classes)
+df.classes$site
+df.classes <- df.classes %>%
+  rename(db_sourcedb = sourcedb,
+         SiteName = site,
+         LabCode = labnr,
+         C14Age = c14age,
+         C14SD = c14std,
+         db_period = period.x,
+         db_culture = culture.x,
+         Period = class,
+         lon = lon,
+         lat = lat) %>%
+  select(db_sourcedb, SiteName, LabCode, C14Age, C14SD, db_period, db_culture, Period, lon, lat)
 
-selected.db <- "nerd"
-df <- get_c14data(selected.db) # YES period, culture
-# .. and Grob
-top_title <- grid::textGrob(paste("db:", selected.db))
-# colnames(df)
-
-## filters
-# columns (by default we try 'period')
-col.req <- c("labnr", "c14age", "c14std", "period", "lon", "lat")
-# test if the "period" column exist or not
-df_selected <- tryCatch({
-  df[, c(col.req, c("site"))]
-}, error = function(e) {
-  col.req <- c("labnr", "c14age", "c14std", "culture", "lon", "lat")
-  df[, c(col.req, c("site"))]
-})
-is.period <- "period" %in% colnames(df_selected)
-if(is.period){
-  chr.column <- "period"
-  } else {
-  chr.column <- "culture"
-  col.req <- c("labnr", "c14age", "c14std", "culture", "lon", "lat")
-  }
-
-df_selected$c14age_uncalBC <- df_selected$c14age - present
-df_selected$c14age_uncalBC <- - df_selected$c14age_uncalBC# data
-df_selected <- df_selected[complete.cases(df_selected[col.req]), ]
-# chrono
-df_selected <- df_selected[df_selected$c14age_uncalBC > chr.interval.uncalBC[1] & df_selected$c14age_uncalBC < chr.interval.uncalBC[2], ]
-nrow(df_selected)
-# spatial
-df_sf <- st_as_sf(df_selected, coords = c("lon", "lat"), crs = 4326)
-inside <- st_within(df_sf, roi, sparse = FALSE)
-df_selected <- df_selected[inside, ]
-# .. and Grob
-context_title <- grid::textGrob(paste0("Dates subsetted btw ",
-                                       paste0(chr.interval, collapse = "/"), " uncal BC (",
-                                       nrow(df_selected), " dates) \n",
-                                       "Everything here is uncal BC"), 
-                                gp = grid::gpar(fontsize = 12))
-
-
-## dataframes
-# t1: nb of dates by culture
-df_ndates_by_group <- as.data.frame(table(df_selected[[chr.column]]))
-df_ndates_by_group <- df_ndates_by_group[order(-df_ndates_by_group$Freq), ]
-names(df_ndates_by_group)[names(df_ndates_by_group) == "Var1"] <- chr.column
-names(df_ndates_by_group)[names(df_ndates_by_group) == "Freq"] <- "date_nb"
-# t2: mean dates of cultures
-df_mean_by_group <- df_selected %>%
-  group_by(.data[[chr.column]]) %>%
-  summarise(date_avg = mean(c14age_uncalBC)) 
-df_mean_by_group$date_avg <- as.integer(df_mean_by_group$date_avg)
-# merge t1 and t2
-df_groups = merge(df_ndates_by_group, df_mean_by_group, by = chr.column)
-df_groups <- df_groups %>%
-  arrange(date_avg)
-# .. and Grob
-df_groups_grob <- tableGrob(head(df_groups, listing.head),
-                            rows = NULL, 
-                            theme = mytheme.listing)
-
-
-## distribution chr = histogram
-distr_chr <- ggplot(df_selected, aes(x = c14age_uncalBC)) + 
-  # TODO: color scale ramp on column 'c14age_uncalBC'
-  geom_histogram(binwidth = 100, # You can adjust the binwidth as needed
-                 color = "blue", fill = "blue") +
-  labs(x = "uncal BC",
-       y = "Frequency") +
-  theme_minimal() +
-  theme(
-    axis.title.x = element_blank(), 
-    axis.title.y = element_blank(),
-    axis.text = ggplot2::element_text(size = 6)
-  )
-
-## distribution spat = map
-df_spat <- st_as_sf(df_selected, coords = c("lon", "lat"), crs = 4326)
-buff <- .5
-world <- ne_countries(scale = "medium", returnclass = "sf")
-distr_spat <- ggplot2::ggplot(world) +
-  # TODO: color scale ramp on column 'c14age_uncalBC'
-  ggplot2::geom_sf() +
-  ggplot2::geom_sf(data = df_spat, inherit.aes = FALSE, size = 1) +
-  ggplot2::coord_sf(xlim = c(sf::st_bbox(roi)[1] - buff, sf::st_bbox(roi)[3] + buff),
-                    ylim = c(sf::st_bbox(roi)[2] - buff, sf::st_bbox(roi)[4] + buff)) +
-  ggplot2::theme_bw() +
-  ggplot2::theme(axis.text = ggplot2::element_text(size = 6)) 
-
-## plot
-g <- grid.arrange(distr_spat, distr_chr, df_groups_grob, context_title,
-                      layout_matrix = lay,
-                      top = top_title)
-g.out <- paste0("C:/Rprojects/neonet/doc/talks/2024-simep/img/", "_db_", selected.db, ".png")
-ggsave(file = g.out, g, width = 14, height = 10)
+df.c14 <- st_as_sf(df.classes, coords = c("lon", "lat"), crs = 4326)
+# ...
+df <- read.csv(paste0(root.path, "/medians.csv"))
diff --git a/doc/talks/2024-simep/df_ref_per.xlsx b/doc/talks/2024-simep/df_ref_per.xlsx
diff --git a/doc/talks/2024-simep/img/_db__all.png b/doc/talks/2024-simep/img/_db__all.png
diff --git a/doc/talks/2024-simep/img/_db__all_class.png b/doc/talks/2024-simep/img/_db__all_class.png
diff --git a/doc/talks/2024-simep/medians.csv b/doc/talks/2024-simep/medians.csv
@@ -0,0 +1,2 @@
+"","x"
+"1",TRUE