Author

VM

Show the code 
knitr::opts_chunk$set(
            echo = TRUE, 
            message = FALSE, warning = FALSE,
            cache=FALSE, 
            dpi=150,
            results="hide",fig.height=7,fig.width=9,
            figcap.prefix = "Figure", 
            figcap.sep = ":", figcap.prefix.highlight = "**")
Show the code 
library(terra)
library(tidyverse)
library(tidyterra)
library(sf)
library(prismatic)

aoi_ras<-rast(xmin=-162.94,xmax=-162.75,ymin=68.04,ymax=68.085)

SOURCES

AMC II

Show the code 
cn_II_ras<-crop(rast("V:/Data/CN/Global_CN/GCN250_ARCII.tif"),
             aoi_ras) 

terra::plot(cn_II_ras,type="classes")

As a conservative approach the ponds or NA were defined as CN=99

Show the code 
cn_II_ras[is.na(cn_II_ras)]<-99

terra::plot(cn_II_ras,type="classes")

AMC III

Show the code 
cn_III_ras<-crop(rast("V:/Data/CN/Global_CN/GCN250_ARCIII.tif"),
             aoi_ras) 

plot(cn_III_ras,type="classes")

As a conservative approach the ponds or NA were defined as CN=99

Show the code 
cn_III_ras[is.na(cn_III_ras)]<-99

plot(cn_III_ras,type="classes")

Show the code 
cn_III_tbl<-cn_III_ras%>% 
  fortify() %>% 
  dplyr::rename(CN=GCN250_ARCIII)

cn_II_tbl<-cn_II_ras%>% 
  fortify() %>% 
  dplyr::rename(CN=GCN250_ARCII)

Orthophoto

Show the code 
# Orthophoto
ortho_ras<-rast(here::here("data","photo","20220929-PL1A-CGG-RedDog-orthophoto-LDP.tif"))

#upscale 16 times
ortho_ras2<-terra::aggregate(ortho_ras,8)

#coordinate system
ortho_ras_ll<-project(ortho_ras2,crs(aoi_ras))

#to data.frame
ortho_ras_ll_df<-fortify(ortho_ras_ll) 

#rename colors
names(ortho_ras_ll_df)[3:5]<-c("r","g","b")

#add colors form layers
ortho_ras_ll_df %<>%
  dplyr::filter(complete.cases(.)) %>% 
  mutate(color=rgb(green = g/255,
                   blue = b/255,
                   red=r/255)
  )

ggplot()+
  geom_raster(data=ortho_ras_ll_df, aes(x=x, y=y, fill=color)) +
  scale_fill_identity()+
  coord_quickmap()+
  theme_light()+
  labs(x="lon [deg]",y="lat [deg]")

FUNCTIONS

Show the code 
gp_tbl_fn<-function(cn_tbl=cn_II_tbl,cn_ras=cn_II_ras,file_sh=file_sh_ll,id="Basin_ID"){

  g1<-ggplot()+
    geom_tile(data=cn_tbl,aes(x=x,y=y,fill=CN),col="grey")+
    geom_text(data=cn_tbl,aes(x=x,y=y,label=CN),size=2.0)+
    scale_fill_binned(type =  "viridis",breaks = seq(0,100,5))+
    geom_sf(data=file_sh,aes(),fill="grey",col="black",alpha=0.2)+
    # geom_sf_label(data=file_sh,aes(label=NAME))+
    coord_sf()+
    labs(x="longitude",y="latitude")+
    theme(legend.position="bottom")
  
  file_sh$CN<-terra::extract(cn_ras,vect(file_sh),
                                fun=mean,na.rm=T,method="bilinear",weights=T) %>% 
    .[,2]
  
  
  g2<-ggplot()+
    scale_fill_binned(type =  "viridis")+
    geom_sf(data=file_sh,aes(fill=CN),alpha=0.8,size=2,col="black")+
    geom_sf_label(data=file_sh,aes(label=round(CN,1)),alpha=0.2)+
    coord_sf()+
    theme_minimal()+
    theme(legend.position = "bottom")+
    labs(x="Longitude",y="Latitude")
  
  
  g3<-ggplot()+
    geom_raster(data=ortho_ras_ll_df, aes(x=x, y=y, fill=color)) +
    scale_fill_binned(type =  "viridis")+
    geom_sf(data=file_sh,alpha=0.6,size=2,col="black")+
    geom_sf_label(data=file_sh,
                  aes(label=paste0(NAME,"\n",round(CN,0))),alpha=0.2)+
    scale_fill_identity()+
    theme_minimal()+
    labs(x="Longitude",y="Latitude")
  

  tbl1<-file_sh %>% 
    as.data.frame() %>% 
    dplyr::select(id,CN) %>%
    dplyr::filter(complete.cases(.)) %>% 
    dplyr::arrange(id) 
  
  results<-list(g1,g2,g3,tbl1)
  
  names(results)<-c("g1","g2","g3","tbl1")
  
  return(results)
}

Golder Watersheds

Show the code 
file_sh<-read_sf(here::here("data","shp","Golder_catchments_20190419_rk.shp")) 

# file_sh<-read_sf(here::here("data","shp","TSFarea_closure_v1.shp")) 

#from UTM to lat and long
file_sh_ll<-st_transform(file_sh,st_crs(aoi_ras))

AMC II

Show the code 
golder_II_res<-gp_tbl_fn(cn_tbl = cn_II_tbl,cn_ras = cn_II_ras,file_sh = file_sh_ll,id = "Basin_ID" )

print(golder_II_res$g1)

Show the code 
print(golder_II_res$g2)

Show the code 
print(golder_II_res$g3)

Show the code 
golder_II_res$tbl1 %>% 
  arrange(Basin_ID) %>% 
  pander::pandoc.table(style="simple")
Basin_ID CN
PIT00 87.22
RDC01 80.95
RDC02 85.81
RDC03 86.08
RDC04 86.02
SCP01 90.52
TBD01 81.35
TBD02 83.29
TBD03 90.77
TSF00 96.72
TSF01 90.73
TSF02 84.1
TSF03 87.29
TSF04 84.87
TSF05 91.25
TSF06 89.98

AMC III

Show the code 
golder_III_res<-gp_tbl_fn(cn_tbl = cn_III_tbl,cn_ras = cn_III_ras,file_sh = file_sh_ll,id = "Basin_ID" )

print(golder_III_res$g1)

Show the code 
print(golder_III_res$g2)

Show the code 
print(golder_III_res$g3)

Show the code 
golder_III_res$tbl1 %>% 
  arrange(Basin_ID) %>% 
  pander::pandoc.table(style="simple")
Basin_ID CN
PIT00 94.8
RDC01 91.27
RDC02 93.94
RDC03 94.11
RDC04 94.06
SCP01 95.88
TBD01 91.64
TBD02 93.12
TBD03 96.43
TSF00 98.23
TSF01 96.42
TSF02 92.88
TSF03 94.74
TSF04 93.4
TSF05 97.06
TSF06 96.42

Synthesis

Show the code 
golder_tbl<-tibble::tribble(
  ~Basin_ID, ~GOLDER,
  "TSF00",     95L,
  "TSF01",     90L,
  "TSF02",     86L,
  "TSF03",     86L,
  "TSF04",     87L,
  "TSF05",     92L,
  "TSF06",     91L
)


plyr::join_all(list(golder_tbl,golder_II_res$tbl1 %>% dplyr::rename(CN_AMCII=CN),
           golder_III_res$tbl1 %>% dplyr::rename(CN_AMCIII=CN)
           ),match = "all") %>% 
  arrange(Basin_ID) %>% 
  pander::pandoc.table(round=0,missing="-")
Basin_ID GOLDER CN_AMCII CN_AMCIII
TSF00 95 97 98
TSF01 90 91 96
TSF02 86 84 93
TSF03 86 87 95
TSF04 87 85 93
TSF05 92 91 97
TSF06 91 90 96

Closure

Show the code 
file_sh<-read_sf(here::here("data","shp","TSFarea_closure_v1.shp")) 

#from UTM to lat and long
file_sh_ll<-st_transform(file_sh,st_crs(aoi_ras))

AMC II

Show the code 
closure_II_res<-gp_tbl_fn(cn_tbl = cn_II_tbl,cn_ras = cn_II_ras,file_sh = file_sh_ll,id = "NAME" )

print(closure_II_res$g1)

Show the code 
print(closure_II_res$g2)

Show the code 
print(closure_II_res$g3)

Show the code 
closure_II_res$tbl1 %>% 
      arrange(NAME) %>% 

  pander::pandoc.table(style="simple")
NAME CN
TSF00 95.06
TSF02 84.08
TSF03 86.48
TSF04 91.16
TSF05 90.57
TSF06 90.97
TSF07 91.41
TSF08 90.83
TSF11 86.92
TSF12 78.63

AMC III

Show the code 
closure_III_res<-gp_tbl_fn(cn_tbl = cn_III_tbl,cn_ras = cn_III_ras,file_sh = file_sh_ll,id = "NAME" )

print(closure_III_res$g1)

Show the code 
print(closure_III_res$g2)

Show the code 
print(closure_III_res$g3)

Show the code 
closure_III_res$tbl1 %>% 
    arrange(NAME) %>% 

  pander::pandoc.table(style="simple")
NAME CN
TSF00 97.57
TSF02 93.05
TSF03 94.3
TSF04 96.65
TSF05 96.72
TSF06 96.99
TSF07 97.1
TSF08 96.88
TSF11 94.45
TSF12 89.94

Synthesis

Show the code 
plyr::join(closure_II_res$tbl1 %>% dplyr::rename(CN_AMCII=CN),
           closure_III_res$tbl1 %>% dplyr::rename(CN_AMCIII=CN)) %>% 
  arrange(NAME) %>% 
  pander::pandoc.table(round=0,style="simple")
NAME CN_AMCII CN_AMCIII
TSF00 95 98
TSF02 84 93
TSF03 86 94
TSF04 91 97
TSF05 91 97
TSF06 91 97
TSF07 91 97
TSF08 91 97
TSF11 87 94
TSF12 79 90