Merge branch 'main' of https://github.com/un-fao/calipseo-shiny into …

…main
un-fao · Jul 24, 2024 · 38c3d9f · 38c3d9f
2 parents fb5deeb + b8792b4
commit 38c3d9f
Show file tree

Hide file tree

Showing 4 changed files with 89 additions and 173 deletions.
diff --git a/NEWS.md b/NEWS.md
@@ -1,4 +1,4 @@
-# **calipseo-shiny [v1.5.5](https://github.com/un-fao/calipseo-shiny/releases/tag/v1.5.5) - 2024-07-12**
+# **calipseo-shiny [v1.6.0](https://github.com/un-fao/calipseo-shiny) - ONGOING**
 
 ## Enhancements
 

diff --git a/assets/country/LBN/artfish_method.R b/assets/country/LBN/artfish_method.R
@@ -14,175 +14,11 @@ artfish_estimates<-function(con,year=NULL,month=NULL,data_effort=NULL,data_landi
   ref_species<-subset(ref_species,select=c(ID,Species))
   names(ref_species)<-c("EST_SPC","EST_SPC_NAME")
 
-  effort<-data_effort%>%
-    dplyr::rename(EST_YEAR=year,
-           EST_MONTH=month,
-           EST_BGC=fishing_unit)%>%
-    mutate(EST_BGC=as.character(EST_BGC))%>%
-    group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-    dplyr::summarise(
-      EST_EFF_NSMP=length(days_sampled),
-      EST_EFF_NBDAYS=length(unique(days)),
-      EST_EFF_SRVTYPE=as.integer(unique(effort_type)),
-      EST_EFF_APPROACH=ifelse(EST_EFF_SRVTYPE==7,"WEEKLY","To DO"),
-      EST_EFF_ACTDAYS=sum(days_sampled,na.rm = T),
-      EST_EFF_EXDAYS=EST_EFF_NSMP*EST_EFF_SRVTYPE,
-      EST_EFF_PBA=EST_EFF_ACTDAYS/EST_EFF_EXDAYS,
-      EST_EFF_NACT=unique(NB_ACTIVE_DAYS),
-      EST_EFF_NBOATS=unique(BG),
-      EST_EFF_POP=EST_EFF_NBOATS*EST_EFF_NACT,
-      EST_EFF_EFFORT=EST_EFF_PBA*EST_EFF_NBOATS*EST_EFF_NACT,
-      mean=mean(days_sampled,na.rm=T),
-      sd=sd(days_sampled,na.rm=T),
-      se=sd/sqrt(EST_EFF_NSMP),
-      EST_EFF_CV=se/mean,
-      EST_EFF_SPAACCUR=artfish_accuracy(n=EST_EFF_NSMP,N=EST_EFF_NBOATS*4,method="higher"),
-      EST_EFF_TMPACCUR=1,
-      EST_EFF_SUI=unif_index(days)
-    )%>%
-    ungroup()%>%
-    left_join(fishing_units, by="EST_BGC")%>%
-    select(EST_YEAR,
-           EST_MONTH,
-           EST_BGC,
-           EST_BGC_NAME,
-           EST_EFF_NBOATS,
-           EST_EFF_NACT,
-           EST_EFF_NBDAYS,
-           EST_EFF_ACTDAYS,
-           EST_EFF_EXDAYS,
-           EST_EFF_PBA,
-           EST_EFF_NSMP,
-           EST_EFF_CV,
-           EST_EFF_SUI,
-           EST_EFF_SRVTYPE,
-           EST_EFF_APPROACH,
-           EST_EFF_SPAACCUR,
-           EST_EFF_TMPACCUR,
-           EST_EFF_POP,
-           EST_EFF_EFFORT
-           )
-
- ####Landing
-
- landing<-data_landing%>%
-   dplyr::rename(EST_YEAR=year,
-          EST_MONTH=month,
-          EST_BGC=fishing_unit)%>%
-   mutate(EST_BGC=as.character(EST_BGC))%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC,days,id)%>%
-   dplyr::summarise(quantity=sum(quantity,na.rm = T),value=sum(value,na.rm=T),price=mean(price,na.rm=T))%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-   dplyr::mutate(quantity = replace(quantity,is.na(quantity), 0))%>%
-   dplyr::summarise(
-     EST_LND_NDAYS=length(unique(days)),
-     EST_LND_SMPCATCH=sum(quantity),
-     EST_LND_NSMP=length(quantity),
-     EST_LND_CPUE_G=EST_LND_SMPCATCH/EST_LND_NSMP,
-     sd=sd(quantity,na.rm=T),
-     se=sd/sqrt(EST_LND_NSMP),
-     EST_LND_CV=se/EST_LND_CPUE_G,
-     EST_LND_SUI=unif_index(days)
-   )%>%
-  ungroup()%>%
-  left_join(fishing_units, by="EST_BGC")%>%
-  select(
-    EST_YEAR,
-    EST_MONTH,
-    EST_BGC,
-    EST_BGC_NAME,
-    EST_YEAR,
-    EST_LND_NDAYS,
-    EST_LND_SMPCATCH,
-    EST_LND_NSMP,
-    EST_LND_CPUE_G,
-    EST_LND_CV,
-    EST_LND_SUI
+  artfishr::artfish_estimates(
+    data_effort = data_effort, data_landing = data_landing,
+    ref_fishingunits = fishing_units, ref_species = ref_species,
+    year = year, month = month
   )
-
- estimate<-effort%>%
-   left_join(landing)%>%
-   mutate(EST_BGC=as.character(EST_BGC))%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-   dplyr::mutate(
-     EST_LND_CATCH_G=EST_EFF_EFFORT*EST_LND_CPUE_G,
-     EST_LND_SPAACCUR=artfish_accuracy(n=EST_LND_NSMP,N=EST_EFF_POP,method="higher"),
-     EST_LND_TMPACCUR=artfish_accuracy(n=EST_LND_NDAYS,N=EST_EFF_NACT,method="higher"),
-     EST_ACCUR=min(EST_EFF_SPAACCUR,EST_EFF_TMPACCUR,EST_LND_SPAACCUR,EST_LND_TMPACCUR,na.rm=T)
-   )
-
- estimate<-data_landing%>%
-   dplyr::rename(EST_YEAR=year,
-          EST_MONTH=month,
-          EST_BGC=fishing_unit,
-          EST_SPC=species)%>%
-   mutate(EST_SPC=as.character(EST_SPC))%>%
-   mutate(EST_BGC=as.character(EST_BGC))%>%
-   left_join(ref_species, by="EST_SPC")%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-   filter(!is.na(EST_SPC))%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC,EST_SPC,EST_SPC_NAME)%>%
-   dplyr::summarise(n=sum(quantity),EST_LND_NOFISH=sum(number),EST_LND_PRICE=mean(price))%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-   dplyr::mutate(sum=sum(n),ratio=n/sum,EST_NOSPE=length(unique(EST_SPC)))%>%
-   select(-n,-sum)%>%
-   left_join(estimate)%>%
-   ungroup()%>%
-   dplyr::mutate(EST_LND_CPUE=EST_LND_CPUE_G*ratio,
-          EST_LND_CATCH=EST_EFF_EFFORT*EST_LND_CPUE,
-          EST_LND_VALUE=EST_LND_CATCH*EST_LND_PRICE,
-          EST_LND_AVW=EST_LND_CATCH/EST_LND_NOFISH)%>%
-   select(-ratio)%>%
-   group_by(EST_YEAR,EST_MONTH,EST_BGC)%>%
-   dplyr::mutate(EST_LND_VALUE_G=sum(EST_LND_VALUE,na.rm = T))%>%
-   ungroup()%>%
-   dplyr::mutate(EST_LND_PRICE_G=EST_LND_VALUE_G/EST_LND_CATCH_G)
-
- estimate<-estimate%>%
-   select(
-     EST_YEAR,
-     EST_MONTH,
-     EST_BGC,
-     EST_BGC_NAME,
-     EST_EFF_EFFORT,
-     EST_EFF_NBOATS,
-     EST_EFF_NACT,
-     EST_EFF_PBA,
-     EST_EFF_ACTDAYS,
-     EST_EFF_EXDAYS,
-     EST_EFF_NSMP,
-     EST_EFF_NBDAYS,
-     EST_EFF_POP,
-     EST_EFF_SRVTYPE,
-     EST_EFF_APPROACH,
-     EST_EFF_CV,
-     EST_EFF_SPAACCUR,
-     EST_EFF_TMPACCUR,
-     EST_EFF_SUI,
-     EST_LND_CATCH_G,
-     EST_LND_CPUE_G,
-     EST_LND_SMPCATCH,
-     EST_LND_NSMP,
-     EST_LND_VALUE_G,
-     EST_LND_PRICE_G,
-     EST_LND_NDAYS,
-     EST_LND_CV,
-     EST_LND_SPAACCUR,
-     EST_LND_TMPACCUR,
-     EST_LND_SUI,
-     EST_ACCUR,
-     EST_NOSPE,
-     EST_SPC,
-     EST_SPC_NAME,
-     EST_LND_NOFISH,
-     EST_LND_CATCH,
-     EST_LND_CPUE,
-     EST_LND_VALUE,
-     EST_LND_PRICE,
-     EST_LND_AVW
-   )
-
- return(estimate)
 }
 
 ###Artfish estimates

diff --git a/modules/core/computation_server.R b/modules/core/computation_server.R
@@ -828,11 +828,91 @@ computation_server <- function(id, pool) {
 
     SetEdgeStyle(tree, arrowhead = "vee", color = "grey35", penwidth = 2,dir="back")
 
-    target <- Traverse(tree, filterFun = function(x) x$level == 1 & x$type=="process")
-    process <- Traverse(tree, filterFun = function(x) x$level > 1 & x$type=="process")
+
+    #patch for R 4.3 (issue of double || operator)
+    Traverse = function(node, 
+                        traversal = c("pre-order", "post-order", "in-order", "level", "ancestor"), 
+                        pruneFun = NULL,
+                        filterFun = NULL) {
+      #traverses in various orders. See http://en.wikipedia.org/wiki/Tree_traversal
+
+      nodes <- list()
+
+      if(length(traversal) > 1L) {
+        traversal <- traversal[1L]
+      }
+      print(traversal)
+      if(is.function(traversal) | traversal == "pre-order" | traversal == "post-order") {
+
+        if (length(pruneFun) == 0 || pruneFun(node)) {
+
+          if (is.function(traversal)) {
+            children <- traversal(node)
+            if (is(children, "Node")) children <- list(children)
+            if (is.null(children)) children <- list()
+          } else children <- node$children
+
+          for(child in children) {
+            nodes <- c(nodes, Traverse(child, traversal = traversal, pruneFun = pruneFun, filterFun = filterFun))
+          }
+          test = filterFun(node)
+          print(test)
+          print(length(test))
+          if(length(filterFun) == 0 || any(filterFun(node))) {
+            if(is.function(traversal) || traversal == "pre-order") nodes <- c(node, nodes)
+            else nodes <- c(nodes, node)
+          }
+        }
+
+      } else if(traversal == "in-order") {
+        if(!node$isBinary) stop("traversal in-order valid only for binary trees")
+        if(length(pruneFun) == 0 | pruneFun(node)) {
+          if(!node$isLeaf) {
+            n1 <- Traverse(node$children[[1]], traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
+            if(length(filterFun) == 0 | filterFun(node)) n2 <- node
+            else n2 <- list()
+            n3 <- Traverse(node$children[[2]], traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
+            nodes <- c(n1, n2, n3)
+          } else {
+            if(length(filterFun) == 0 | filterFun(node)) n2 <- node
+            else n2 <- list()
+            nodes <- c(nodes, n2)
+          }
+        }
+
+      } else if (traversal == "ancestor") {
+
+
+        if (!isRoot(node)) {
+          nodes <- Traverse(node$parent, traversal = traversal, pruneFun = pruneFun, filterFun = filterFun)
+        }
+
+        if(length(filterFun) == 0 || any(filterFun(node))) {
+          nodes <- c(node, nodes)
+        }
+
+      } else if (traversal == "level") {
+
+        nodes <- Traverse(node, filterFun = filterFun, pruneFun = pruneFun)
+        if (length(nodes) > 0) nodes <- nodes[order(Get(nodes, function(x) x$level))]
+
+
+      } else {
+        stop("traversal must be pre-order, post-order, in-order, ancestor, or level")
+      }
+      return (nodes)
+    }
+
+
+    print("pipo")
+    target <- Traverse(tree, filterFun = function(x){ x$level == 1 & x$type=="process" })
+    print("pipo2")
+    process <- Traverse(tree, filterFun = function(x){ x$level > 1 & x$type=="process"})
     data <- Traverse(tree, filterFun = function(x) x$type =="data")
     local <- Traverse(tree, filterFun = function(x) x$type =="local")
 
+
+
     Do(target,SetNodeStyle,style = "filled,rounded", shape = "box", fontcolor="black",fillcolor = "#90dbf4", fontname = "helvetica",penwidth="4px")
     Do(process,SetNodeStyle,style = "filled,rounded", shape = "box", fontcolor="black",fillcolor = "#8eecf5", fontname = "helvetica",penwidth="2px")
 

diff --git a/package.json b/package.json
@@ -1,7 +1,7 @@
 {
   "id": "shiny-calipseo",
-  "version": "1.5.4",
-  "date": "2024-07-02",
+  "version": "1.6.0",
+  "date": "2024-07-23",
   "dependencies": [
     {"package": "dotenv", "version": "1.0.3", "repos": "https://cran.r-project.org"},
     {"package": "htmltools", "version": "0.5.2", "repos": "https://cloud.r-project.org"},