Merge pull request #3 from USDAForestService/development

Development

fvsOL/DESCRIPTION

@@ -1,6 +1,6 @@
 Package: fvsOL
 Title: Forest Vegetation Simulator
-Version: 2022.07.01
+Version: 2022.09.30
 Authors@R: c(person("Nicholas", "Crookston", email = "[email protected]",
                   role = c("aut")),
              person("Michael", "Shettles", email = "[email protected]",

fvsOL/R/componentWins.R

@@ -260,7 +260,7 @@ cat ("in PlantNaturalFullWin code, globals$currentCmdDefs=",globals$currentCmdDe
     list(
       mkScheduleBox("pnDOD",prms,"Schedule the date of disturbance",
         globals,input,output),    
-      div(style="background-color: rgb(255,240,240)",
+      if(full){div(style="background-color: rgb(255,240,240)",
         myInlineTextInput("pnYD", "Years following disturbance for site preparation: ", 
           globals$currentCmdDefs["pnYD"]),
         fixedRow(
@@ -269,7 +269,7 @@ cat ("in PlantNaturalFullWin code, globals$currentCmdDefs=",globals$currentCmdDe
           column(width=6,          
             myInlineTextInput("pnPMch", "% mechanically scarified: ", 
               globals$currentCmdDefs["pnPMch"]))
-      )),
+      ))},
       div(style="background-color: rgb(240,240,255)",
         fixedRow(
           column(width=5,          
@@ -332,15 +332,14 @@ cat ("in PlantNaturalFullWin code, globals$currentCmdDefs=",globals$currentCmdDe
 
 PlantNaturalFullWin.mkKeyWrd <- function(input,output,full=TRUE)
 { 
-  kwds = list()
+  kwds = sprintf("Estab     %10s",input$pnDOD)
 cat ("in PlantNaturalFullWin.mkKeyWrd\n")
-  if (full & input$pnPBrn != " ") kwds = sprintf("\nBurnPrep  %10s%10s",
-      as.character(as.numeric(input$pnDOD)+as.numeric(input$pnYD)),input$PBrn)
-  if (full & input$pnPMch != " ") kwds = if (length(kwds)) paste0(kwds,
-    sprintf("\nMechPrep  %10s%10s",
-      as.character(as.numeric(input$pnDOD)+as.numeric(input$pnYD)),input$pnPMch)) else
+  if (full & (!is.null(input$pnPBrn) && input$pnPBrn != " ")) kwds = paste0(kwds,
+    sprintf("\nBurnPrep  %10s%10s",
+      as.character(as.numeric(input$pnDOD)+as.numeric(input$pnYD)),input$pnPBrn))
+  if (full & (!is.null(input$pnPMch) && input$pnPMch != " ")) kwds = paste0(kwds,
     sprintf("\nMechPrep  %10s%10s",
-      as.character(as.numeric(input$pnDOD)+as.numeric(input$pnYD)),input$pnPMch) 
+      as.character(as.numeric(input$pnDOD)+as.numeric(input$pnYD)),input$pnPMch))
   kwds = if (length(kwds)) paste0(kwds,"\n",if (input$pnSprt == "1") "Sprout" else "NoSprout") else
          if (input$pnSprt == "1") "Sprout" else "NoSprout"
   if (full) kwds = paste0(kwds,"\n",if (input$pnIng  == "1") "InGrow" else "NoInGrow")

fvsOL/R/externalCallable.R

@@ -1,4 +1,4 @@
-# $Id$
+# $Id: externalCallable.R 4018 2022-07-27 22:59:15Z nickcrookston $
 #
 #' Build an FVS run in a project
 #'
@@ -242,7 +242,7 @@ extnFromRaw = function(x) unserialize(memDecompress(x,type="gzip"))
 #' @export
 extnListRuns <- function (prjDir=getwd())
 {
-  if (!dir.exists(prjDir)) return(NULL) 
+  if (!dir.exists(prjDir)) return(NULL)
   prjDir = normalizePath(prjDir)
   db = connectFVSProjectDB(prjDir)
   on.exit(dbDisconnect(db))
@@ -279,7 +279,7 @@ extnDeleteRuns <- function (prjDir=NULL,runUUIDs=NULL,delOutput=TRUE)
 {
   if (is.null(runUUIDs)) stop("runUUIDs must be specified.")
   if (is.null(prjDir)) prjDir=getwd() 
-  if (!dir.exists(prjDir)) return(NULL) 
+  if (!dir.exists(prjDir)) return(NULL)
   prjDir = normalizePath(prjDir)
   db = connectFVSProjectDB(prjDir)         
   on.exit({
@@ -532,7 +532,7 @@ extnGetComponentKwds <- function(prjDir=getwd(),runUUID,returnType="fvsCmp")
 {
   if (missing(runUUID)) stop("runUUID required")
   if (! returnType %in% c("fvsCmp","raw","character")) stop ("invalid value for 'returnType'")
-  prjDir = normalizePath(prjDir)              
+  prjDir = normalizePath(prjDir)
   db = connectFVSProjectDB(prjDir)
   on.exit(dbDisconnect(db)) 
   fvsRun = loadFVSRun(db,runUUID)
@@ -937,7 +937,6 @@ extnSimulateRun <- function(prjDir=getwd(),runUUID,fvsBin="FVSBin",ncpu=detectCo
 #for testing:
 #prjDir=getwd();runUUID=extnListRuns()[1,1];fvsBin="FVSBin";ncpu=detectCores()
 #keyFileName=NULL;wait=FALSE;verbose=TRUE
-  devVersion <<- "fvsOLdev" %in% (.packages())
   curdir=getwd()
   if (missing(runUUID)) stop("runUUID required")
   setwd(prjDir)

fvsOL/R/fvsRunUtilities.R

@@ -1,4 +1,4 @@
-# $Id$
+# $Id: fvsRunUtilities.R 3982 2022-05-10 18:07:19Z mshettles521 $
 
 loadStandTableData <- function (globals, dbIcon)
 {
@@ -231,6 +231,7 @@ cat("mkSimCnts, foundStand=",foundStand," start=",start," end=",end,
   paste0("length(list)=",length(list)) else sels,"\n")
     if (length(fvsRun$stands)) for (i in start:end) 
     {
+      if(length(fvsRun$stands) < i) break
       ## these two lines are needed to deal with old runs that may not have these elements in the stand class
       if (class(fvsRun$stands[[i]]$rep  )!="numeric") fvsRun$stands[[i]]$rep  =0
       if (class(fvsRun$stands[[i]]$repwt)!="numeric") fvsRun$stands[[i]]$repwt=1
@@ -852,8 +853,8 @@ mkModMCats <- function(globals)
       "Modify Root Disease bark beetles" = "keyword.wrd3.wrd_brk_btl")))
   catsel = append(catsel,list(   
     "Modify Sprouting" = c(
-      "Turn off Sprouting" = "keyword.estbstrp.NoSprout",
-      "Adjust Sprouting" = "keyword.estbstrp.Sprout"),
+      "Turn off Sprouting" = "Estab keyword.estbstrp.NoSprout",
+      "Adjust Sprouting" = "Estab keyword.estbstrp.Sprout"),
     "Modify Percent Canopy Cover" = c( 
       "Adjust Overlap Correction" = "keyword.base.CCAdj")))
   catsel

fvsOL/R/mkInputElements.R

@@ -1,4 +1,4 @@
-# $Id$
+# $Id: mkInputElements.R 4001 2022-05-23 15:04:37Z mshettles521 $
 
 mkeltList <- function (pkeys,prms,globals,input,output,
                        cndflag=FALSE,funcflag=FALSE,comptitle=NULL)
@@ -428,6 +428,7 @@ mkVarList <- function (globals)
   varList = c(
      " "=" ",
      "Age: Age at beginning of an FVS cycle"="Age", 
+     "AgeCmp: Estimated average age for the dominant size class"="AgeCmp",
      "Aspect: Aspect in degrees"="Aspect", 
      "BaDBH: Before thin quadractic mean DBH"="BaDBH", 
      "BBA: Before thin basal area"="BBA", 
@@ -560,10 +561,12 @@ mkFuncList <- function (globals)
     "DBHDist: Returns the diameter of the tree corresponding to the nominal percentile in the distribution of one of 11 specific attributes"="DBHDist",
     "Decade: Returns the argument the corresponds to the decade the simulation is in"="Decade",
     "HTDist: Returns the height of the tree corresponding to the nominal percentile in the trees per acre distribution"="HTDist",
+    "Index: Returns the value associated with the index specified in the first argument"="Index",
     "LinInt: Returns a linear interpolation between points on a simple Y-over-X graph"="LinInt",                   
     "MaxIndex: Returns the argument index corresponding to the largest value"="MaxIndex",                
     "MinIndex: Returns the argument index corresponding to the smallest value"="MinIndex",
     "Normal: Returns a random normal variate given a mean and std. dev"="Normal",
+    "PointID: Returns the inventory point number corresponding to the FVS sequential point number"="PointID",
     "SpMcDBH: Returns the trees, basal area, or one of 10 other attributes for trees of a given species, tree value class, or tree-size range"="SpMcDBH",
     "StrStat: Returns the information in the structural statistics report under before or after thinning conditions"="StrStat",
     "SumStat: Returns values from the Summary Statistics table"="SumStat",

fvsOL/R/server.R

@@ -110,7 +110,7 @@ mkGlobals <- setRefClass("globals",
     specLvl="list",dClsLvl="list",htClsLvl="list",treeLvl="list",tbsFinal="list",
     selRuns = "character", selUuids = "character",selAllVars="logical",
     explorePass="numeric",lastNewPrj="character",prjFilesOnly="logical",
-    tableMessage="logical",exploring="logical")) 
+    tableMessage="logical",exploring="logical", RepsDesign='logical')) 
 
 isLocal <- function () Sys.getenv('SHINY_PORT') == ""
 
@@ -146,7 +146,7 @@ zipList <- list(
   "Output data base for for all runs"  = "outdb",  
   "Keyword file for current run" = "key",  
   "FVS output file for current run" = "out",  
-  "SVS output files for current run" = "subdir",  
+  "Visualize output files for current run" = "subdir",  
   "Input data base FVS_Data.db" = "FVS_Data", 
   "Spatial data (SpatialData.RData)" = "SpatialData")  
 selZip <- unlist(zipList[1:4])  
@@ -3987,8 +3987,28 @@ cat ("changeind=",globals$changeind,"\n")
 cat("Nulling uiRunPlot at Save and Run\n")
         output$uiRunPlot <- output$uiErrorScan <- renderUI(NULL)
         globals$currentQuickPlot = character(0) 
-        # timeing checks.
+        # timing checks.
         thisYr = as.numeric(format(Sys.time(), "%Y"))
+        # First check to see if required start year, end year, or cycle length fields are blank.
+        if (input$startyr =="") {
+            session$sendCustomMessage(type = "infomessage",
+                    message = paste0("The common starting year is blank."))
+            updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
+            return()
+        }
+        if (input$endyr =="") {
+            session$sendCustomMessage(type = "infomessage",
+                    message = paste0("The common ending year is blank."))
+            updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
+            return()
+          }
+        if (input$cyclelen =="") {
+          session$sendCustomMessage(type = "infomessage",
+                  message = paste0("The growth and reporting interval is blank."))
+          updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
+          return()
+        }
+        # other start year checks
         for(i in 1:length(globals$fvsRun$stands)){
           if (((input$startyr !="" && ((as.numeric(input$startyr)) > (thisYr + 50))) ||
                ((input$startyr !="") && nchar(input$startyr) > 4))){
@@ -4005,14 +4025,8 @@ cat("Nulling uiRunPlot at Save and Run\n")
             updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
             return()
           }
-          if (input$startyr =="") {
-            session$sendCustomMessage(type = "infomessage",
-                    message = paste0("The common starting year is blank."))
-            updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
-            return()
-          }
         }
-        # End year checks
+        # other end year checks
         for(i in 1:length(globals$fvsRun$stands)){
           if (((input$endyr !="" && ((as.numeric(input$endyr)) > 
             (as.numeric(input$cyclelen) * 40 + as.numeric(input$startyr)))) ||
@@ -4031,14 +4045,8 @@ cat("Nulling uiRunPlot at Save and Run\n")
             updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
             return()
           }
-          if (input$endyr =="") {
-            session$sendCustomMessage(type = "infomessage",
-                    message = paste0("The common ending year is blank."))
-            updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
-            return()
-          }
         }
-        # Cycle length checks
+        # other cycle length check
         if (((input$cyclelen !="" && ((as.numeric(input$cyclelen)) > 50))) ||
              ((input$cyclelen !="") && nchar(input$cyclelen) > 4)){
           session$sendCustomMessage(type = "infomessage",
@@ -4047,12 +4055,6 @@ cat("Nulling uiRunPlot at Save and Run\n")
           updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
           return()
         }
-        if (input$cyclelen =="") {
-          session$sendCustomMessage(type = "infomessage",
-                  message = paste0("The growth interval is blank."))
-          updateTabsetPanel(session=session,inputId="rightPan",selected="Time")
-          return()
-        }
         baseCycles = seq(as.numeric(globals$fvsRun$startyr),as.numeric(globals$fvsRun$endyr),
                          as.numeric(globals$fvsRun$cyclelen))
         cycleat = scan(text=gsub(";"," ",gsub(","," ",globals$fvsRun$cycleat)),
@@ -4077,7 +4079,7 @@ cat("Nulling uiRunPlot at Save and Run\n")
               }
             }
           }
-        }        
+        }  
         progress <- shiny::Progress$new(session,min=1,
                            max=length(globals$fvsRun$stands)+10)
         progress$set(message = "Run preparation: ", 
@@ -4173,6 +4175,9 @@ cat ("No climate attributes data found.\n")
           progress$close()
 cat ("exiting, stop fvschild\n")          
           try(stopCluster(fvschild))
+          Sys.sleep(0.3)
+          unlink(paste0(globals$fvsRun$uuid,".db"))
+          unlink(paste0(globals$fvsRun$uuid,"_genrpt.txt"))
         }) 
         clusterEvalQ(fvschild,library(rFVS))
         cmd = paste0("clusterEvalQ(fvschild,fvsLoad('",
@@ -8116,7 +8121,7 @@ cat ("in customRunOps runScript: ",input$runScript,"\n")
         fn=paste0("customRun_",globals$fvsRun$runScript,".R")
         if (!file.exists(fn)) fn=system.file("extdata", fn, package=if (devVersion) "fvsOLdev" else "fvsOL")
         if (!file.exists(fn)) return()        
-        rtn = try(source(fn))
+        rtn = try(source(fn,local=TRUE))
         if (class(rtn) == "try-error") return()
         uiF = try(eval(parse(text=paste0(sub("fvsRun","ui",globals$fvsRun$runScript)))))
         if (class(uiF) != "function") return()

fvsOL/R/ui.R

@@ -785,7 +785,12 @@ FVSOnlineUI <- fixedPage(
             downloadButton("dlFVSRunkey","Keyword file for current run"),h4(),        
             checkboxGroupInput("dlZipSet","Set contents of FVSProjectData.zip",   
               zipList,selZip,inline=FALSE),  
-            downloadButton("dlFVSRunZip","Download FVSProjectData.zip") 
+            downloadButton("dlFVSRunZip","Download FVSProjectData.zip"),
+            HTML(paste0('<p style="font-size:17px;color:darkgreen"><br>',         
+              'The contents of the FVSProjectData.zip file can be uploaded using the ',               
+              '<i>Import runs and other items</i> tab.<br><br>Note: If you need to create ',
+              'a zip file backup of your entire project, use the "Make a project backup zip file" ',
+              'utility under the <i>Manage project</i> tab.</p>'))
           ) #END Downloads tabPanel                                        
         )  #END  tabsetPanel for toolsPan
       ),  ## END Manage Projects          

fvsOL/R/writeKeyFile.R

@@ -80,6 +80,7 @@ kcpVetting <- function (kcpconts)
     commkw <- grep("COMMENT", toupper(kcpconts[j]))
     commkw <- length(commkw)
     compkw <- toupper(strsplit(kcpconts[j]," ")[[1]][1])=="COMPUTE"
+    if(!is.na(match("DESIGN", toupper(kcpconts[j]))))RepsDesign=TRUE
     # omit comments, lines that continue (supplemental records), parameter-only lines, compute expressions (contains "="), and THEN keywords
     if(is.na(!comment && commentflag==0 && !continuation && is.na(numvalue) && !length(expression) && !thenkw)) next
     if(!comment && commentflag==0 && !continuation && is.na(numvalue) && !length(expression) && !thenkw){
@@ -498,6 +499,7 @@ writeKeyFile <- function (globals,dbIcon,newSum=TRUE,keyFileName=NULL,verbose=TR
   cycleat = sort(union(cycleat,as.numeric(globals$fvsRun$endyr))) 
   for (std in globals$fvsRun$stands)
   { 
+    RepsDesign=FALSE
     names(fvsInit) <- toupper(names(fvsInit))
     sRows = match (std$sid, fvsInit$STAND_ID)
     sRowp = match (std$sid, fvsInit$STANDPLOT_ID)
@@ -563,7 +565,6 @@ writeKeyFile <- function (globals,dbIcon,newSum=TRUE,keyFileName=NULL,verbose=TR
         {
           if(lastExt != "base") cat ("End\n",file=fc,sep="")
           cat ("EndIf\n",file=fc,sep="")
-          if(lastExt == lastExt) cat (extensPrefixes[exten],"\n",file=fc,sep="")
           lastCnd = NULL
         }
         if (cmp$atag == "c") lastCnd = cmp$uuid
@@ -626,6 +627,7 @@ writeKeyFile <- function (globals,dbIcon,newSum=TRUE,keyFileName=NULL,verbose=TR
           }
           cat ("!Exten:",cmp$exten," Title:",cmp$title,"\n",
                     cmp$kwds,"\n",file=fc,sep="")
+          if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE
         }
       }
     } 
@@ -681,7 +683,8 @@ writeKeyFile <- function (globals,dbIcon,newSum=TRUE,keyFileName=NULL,verbose=TR
       else {
       cat ("!Exten:",cmp$exten," Name:",cmp$kwdName,"\n",
                      cmp$kwds,"\n",file=fc,sep="")  
-        }
+      }
+      if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE
     }
     if (!is.null(lastCnd) && lastExt != "base") {
       cat ("End\n",file=fc,sep="")
@@ -690,15 +693,15 @@ writeKeyFile <- function (globals,dbIcon,newSum=TRUE,keyFileName=NULL,verbose=TR
     if (!is.null(lastCnd) && lastExt == "base") cat ("EndIf\n",file=fc,sep="")
     if (is.null(lastCnd) && lastExt != "base") cat ("End\n",file=fc,sep="")
     # insert modified sampling weight if needed.
-    if (!is.null(wtofix[[std$sid]]))
+    if (!is.null(wtofix[[std$sid]]) && !RepsDesign)
     {
       swt=as.numeric(fvsInit$SAM_WT[sRows])
       if (is.na(swt)) swt=1
       swt=swt*wtofix[[std$sid]][std$rep]
       cswt=sprintf("%10s",as.character(swt))
       if (nchar(cswt)>10) cswt=sprintf("%9.5g",swt)
       cat ("Design",strrep(" ",53),cswt,"\n",file=fc,sep="")
-    } 
+    }
     cat ("SPLabel\n",file=fc,sep="")
     for (i in 1:length(std$grps))
     {