Merge branch 'main' of https://github.com/bcgov/CCISS_ShinyApp

CCISS_Testing.R

@@ -0,0 +1,29 @@
+library(ccissdev)
+library(data.table)
+library(pool)
+
+pool <- dbPool(
+  drv = RPostgres::Postgres(),
+  dbname = Sys.getenv("BCGOV_DB"),
+  host = Sys.getenv("BCGOV_HOST"),
+  port = 5432, 
+  user = Sys.getenv("BCGOV_USR"),
+  password = Sys.getenv("BCGOV_PWD")
+)
+
+gcm_weight <- data.table(gcm = c("ACCESS-ESM1-5", "BCC-CSM2-MR", "CanESM5", "CNRM-ESM2-1", "EC-Earth3", 
+                                 "GFDL-ESM4", "GISS-E2-1-G", "INM-CM5-0", "IPSL-CM6A-LR", "MIROC6", 
+                                 "MPI-ESM1-2-HR", "MRI-ESM2-0", "UKESM1-0-LL"),
+                         weight = c(1,0,0,1,1,1,1,0,0,1,1,1,0))
+
+rcp_weight <- data.table(rcp = c("ssp126","ssp245","ssp370","ssp585"), 
+                         weight = c(0.8,1,0.8,0))
+
+all_weight <- as.data.table(expand.grid(gcm = gcm_weight$gcm,rcp = rcp_weight$rcp))
+all_weight[gcm_weight,wgcm := i.weight, on = "gcm"]
+all_weight[rcp_weight,wrcp := i.weight, on = "rcp"]
+all_weight[,weight := wgcm*wrcp]
+
+points <- dbGetQuery(pool, "select siteno from preselected_points where bgc = 'SBSdw3'")
+sitenos <- points$siteno[1:150]
+bgc <- dbGetCCISS(pool, sitenos, avg = T, modWeights = all_weight)

DESCRIPTION

@@ -43,5 +43,5 @@ Remotes:
 LinkingTo: Rcpp
 LazyData: true
 Roxygen: list(markdown = TRUE)
-RoxygenNote: 7.1.2
+RoxygenNote: 7.2.3
 SystemRequirements: chromium-browser

Feasibility_Maps.R

@@ -14,6 +14,7 @@ library(sf)
 library(pool)
 library(RColorBrewer)
 library(terra)
+library(ccissdev)
 
 ##some setup
 con <- dbPool(
@@ -47,6 +48,38 @@ outline <- st_read(con,query = "select * from bc_outline")
 S1 <- setDT(dbGetQuery(sppDb,"select bgc,ss_nospace,spp,newfeas from feasorig"))
 setnames(S1,c("BGC","SS_NoSpace","Spp","Feasible"))
 
+library(Rcpp)
+cppFunction('NumericVector ModelDir(NumericMatrix x, NumericVector Curr, std::string dir){
+  int n = x.nrow();
+  NumericVector res(n);
+  NumericVector temp(5);
+  NumericVector temp2;
+  double curr_suit;
+  if(dir == "Improve"){
+    for(int i = 0; i < n; i++){
+      temp = x(i,_);
+      temp.push_front(0);
+      curr_suit = Curr[i];
+      if(curr_suit == 4){
+        curr_suit = 3;
+      }
+      res[i] = sum(temp[Range(0,curr_suit)]);
+    }
+  }else{
+    for(int i = 0; i < n; i++){
+      temp = x(i,_);
+      temp.push_back(0);
+      curr_suit = Curr[i];
+      if(curr_suit == 4){
+        curr_suit = 3;
+      }
+      res[i] = sum(temp[Range(curr_suit,4)]);
+    }
+  }
+  
+  return(res);
+}
+')
 ##adapted feasibility function
 ccissMap <- function(SSPred,suit,spp_select){
   ### generate raw feasibility ratios
@@ -65,7 +98,9 @@ ccissMap <- function(SSPred,suit,spp_select){
   suitVotes <- data.table::dcast(suitMerge, SiteRef + Spp + FuturePeriod + SS_NoSpace ~ Feasible, 
                                  value.var = "SSprob", fun.aggregate = sum)
   # Fill with 0 if columns does not exist, encountered the error at SiteRef 3104856 
+  colNms <- c("1","2","3","X")
   set(suitVotes, j = as.character(1:5)[!as.character(1:5) %in% names(suitVotes)], value = 0)
+
   suitVotes[,VoteSum := `1`+`2`+`3`+`4`+`5`]
   suitVotes[,X := 1 - VoteSum]
   suitVotes[,VoteSum := NULL]
@@ -77,11 +112,18 @@ ccissMap <- function(SSPred,suit,spp_select){
   suitVotes[is.na(Curr), Curr := 5]
   setorder(suitVotes,SiteRef,SS_NoSpace,Spp,FuturePeriod)
   suitVotes[Curr > 3.5, Curr := 4]
-  colNms <- c("1","2","3","X")
+
+  suitVotes[,Improve := ModelDir(as.matrix(.SD), Curr = Curr, dir = "Improve"),.SDcols = colNms]
+  suitVotes[,Decline := ModelDir(as.matrix(.SD), Curr = Curr, dir = "Decline"),.SDcols = colNms]
+  datRot <- suitVotes[,lapply(.SD, mean),.SDcols = c("Improve","Decline"), by = list(SiteRef,SS_NoSpace,Spp,Curr)]
+  datRot[,`:=`(Improve = round(Improve*100),Decline = round(Decline*100))]
+  datRot[,Curr := NULL]
+
   suitVotes <- suitVotes[,lapply(.SD, sum),.SDcols = colNms, 
                          by = .(SiteRef,FuturePeriod, SS_NoSpace,Spp,Curr)]
   suitVotes[,NewSuit := `1`+(`2`*2)+(`3`*3)+(X*5)]
-  suitRes <- suitVotes[,.(Curr = mean(Curr),NewSuit = mean(NewSuit)), by = .(SiteRef)]
+  suitVotes <- merge(suitVotes, datRot, by = c('SiteRef','SS_NoSpace','Spp'),all = T)
+  suitRes <- suitVotes[,.(Curr = mean(Curr),NewSuit = mean(NewSuit), Improve = mean(Improve), Decline = mean(Decline)), by = .(SiteRef)]
   return(suitRes)
 }
 
@@ -162,7 +204,7 @@ for(timeperiod in timeperiods[-1]){
   # loop through edatope and species
   eda <- "C4"
   for(eda in edas[-1]){
-    spp <- "Bl"
+    spp <- "Fd"
     for(spp in spps){ ##ignore warnings,"Fd","Sx","Pl", "Yc", "Yc", "Oa", "Yp"
       cat("Plotting ",spp, eda,"\n")
 

NAMESPACE

@@ -5,6 +5,7 @@ export(cleanData)
 export(dbBbox)
 export(dbGetBGC)
 export(dbGetCCISS)
+export(dbGetCCISSRaw)
 export(dbGetClimSum)
 export(dbGetSppLimits)
 export(dbPointInfo)

R/RcppExports.R

@@ -25,6 +25,10 @@ stepDiff <- function(Year, NewSuit, Curr) {
     .Call(`_ccissdev_stepDiff`, Year, NewSuit, Curr)
 }
 
+#' Function for quickly calculating model direction/agreement
+#' @name ModelDir
+#' @param x data
+#' @return NumericVector
 ModelDir <- function(x, Curr, dir) {
     .Call(`_ccissdev_ModelDir`, x, Curr, dir)
 }

R/eda_overlap.R

@@ -91,6 +91,7 @@ edatopicOverlap <- function(BGC,E1,E1_Phase,onlyRegular = FALSE){
   SSsp.out <- new[,list(allOverlap = 1/.N,SS.pred,BGC.prop), keyby = list(SiteRef,FuturePeriod,BGC,BGC.pred,SS_NoSpace)]
 
   ##regular site series edatopes
+  SS <- E1[is.na(SpecialCode),list(BGC,SS_NoSpace,Edatopic)]
   temp <- rbind(SS,E1_Phase[is.na(SpecialCode),list(BGC,SS_NoSpace,Edatopic)])
   CurrBGC <- temp[BGC, on = "BGC", allow.cartesian = T]
   CurrBGC <- CurrBGC[!duplicated(CurrBGC),]

app/server.R

@@ -32,6 +32,8 @@ onStop(function() {
   poolClose(poolclim)
 })
 
+DEV = TRUE
+
 #####load feas table from database
 S1 <- setDT(dbGetQuery(sppDb,"select bgc,ss_nospace,spp,newfeas from feasorig"))
 setnames(S1,c("BGC","SS_NoSpace","Spp","Feasible"))
@@ -93,54 +95,56 @@ shinyServer(function(input, output, session) {
   source("./server/instructions.R", local = TRUE)
 
   ##login
-  showModal(
-    modalDialog(
-      size = "xl",
-      footer = NULL,
-      textOutput("login_error"),
-      splitLayout(
-        wellPanel(
-          h4("Sign Up"),
-          textInput("su_email","Email:"),
-          textInput("su_uname", "Create Username"),
-          selectInput("su_role","What are you?", choices = c("", "Forester","Government","Academic","Student","Unicorn","Good CCISSer"), 
-                      selected = NULL),
-          actionButton("su_go","Sign Up!")
-        ),
-        wellPanel(
-          h4("Log In"),
-          textInput("login_uname","Enter Username"),
-          actionButton("login_go","Log In!")
+  if(!DEV){
+    showModal(
+      modalDialog(
+        size = "xl",
+        footer = NULL,
+        textOutput("login_error"),
+        splitLayout(
+          wellPanel(
+            h4("Sign Up"),
+            textInput("su_email","Email:"),
+            textInput("su_uname", "Create Username"),
+            selectInput("su_role","What are you?", choices = c("", "Forester","Government","Academic","Student","Unicorn","Good CCISSer"), 
+                        selected = NULL),
+            actionButton("su_go","Sign Up!")
+          ),
+          wellPanel(
+            h4("Log In"),
+            textInput("login_uname","Enter Username"),
+            actionButton("login_go","Log In!")
+          )
         )
       )
     )
-  )
-
-  output$login_error <- renderText({login_text$message})
-
-  observeEvent(input$su_go, {
-    if(input$su_email == "" | input$su_uname == "" | input$su_role == ""){
-      login_text$message <- "Please enter your email and password."
-    }else{
-      tryCatch({
-        dbExecute(pool, paste0("INSERT INTO cciss_users (username, email, role, nsession) VALUES ('",
-                               input$su_uname,"', '",input$su_email,"','",input$su_role,"',0)"))
+
+    output$login_error <- renderText({login_text$message})
+
+    observeEvent(input$su_go, {
+      if(input$su_email == "" | input$su_uname == "" | input$su_role == ""){
+        login_text$message <- "Please enter your email and password."
+      }else{
+        tryCatch({
+          dbExecute(pool, paste0("INSERT INTO cciss_users (username, email, role, nsession) VALUES ('",
+                                 input$su_uname,"', '",input$su_email,"','",input$su_role,"',0)"))
+          removeModal()
+        },
+        error = function(e) {
+          login_text$message <- "Username Exists. Please login or choose a new one."
+        })
+      }
+    })
+
+    observeEvent(input$login_go, {
+      if(dbGetQuery(pool, paste0("SELECT exists (SELECT 1 FROM cciss_users WHERE username = '",input$login_uname,"' LIMIT 1);"))[,1]){
+        dbExecute(pool,paste0("UPDATE cciss_users SET nsession = nsession + 1 WHERE username = '",input$login_uname,"';"))
         removeModal()
-      },
-      error = function(e) {
-        login_text$message <- "Username Exists. Please login or choose a new one."
-      })
-    }
-  })
-
-  observeEvent(input$login_go, {
-    if(dbGetQuery(pool, paste0("SELECT exists (SELECT 1 FROM cciss_users WHERE username = '",input$login_uname,"' LIMIT 1);"))[,1]){
-      dbExecute(pool,paste0("UPDATE cciss_users SET nsession = nsession + 1 WHERE username = '",input$login_uname,"';"))
-      removeModal()
-    }else{
-      login_text$message <- "Username does not exist."
-    }
-  })
+      }else{
+        login_text$message <- "Username does not exist."
+      }
+    })
+  }
 
   ##hover text for feasibility report
   hoverText <- c("Species","Time Period","Percentage of models preciting each feasibility",

src/RcppExports.cpp

@@ -91,6 +91,7 @@ NumericVector ModelDir(NumericMatrix x, NumericVector Curr, std::string dir);
 RcppExport SEXP _ccissdev_ModelDir(SEXP xSEXP, SEXP CurrSEXP, SEXP dirSEXP) {
 BEGIN_RCPP
     Rcpp::RObject rcpp_result_gen;
+    Rcpp::RNGScope rcpp_rngScope_gen;
     Rcpp::traits::input_parameter< NumericMatrix >::type x(xSEXP);
     Rcpp::traits::input_parameter< NumericVector >::type Curr(CurrSEXP);
     Rcpp::traits::input_parameter< std::string >::type dir(dirSEXP);

src/ccissdev.cpp

@@ -148,7 +148,11 @@ NumericVector stepDiff(IntegerVector Year, NumericVector NewSuit, NumericVector
   return(res);
 }
 
-// [[Rcpp::export(rng=false)]]
+//' Function for quickly calculating model direction/agreement
+//' @name ModelDir
+//' @param x data
+//' @return NumericVector
+// [[Rcpp::export]]
 NumericVector ModelDir(NumericMatrix x, NumericVector Curr, std::string dir){
   int n = x.nrow();
   NumericVector res(n);