From 09b51e669fb19903af892dd4799a41c1fd2e683f Mon Sep 17 00:00:00 2001 From: Daniel Wagner Date: Mon, 22 May 2023 10:27:34 -0400 Subject: [PATCH 1/3] Squashed commit of the following: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit commit 07a9aee26977a50643737ef6ceb0837a3d3dbb3f Merge: faf1542 c171a15 Author: Daniel Wagner Date: Wed May 3 12:18:32 2023 -0400 Merge branch 'development' into staging commit c171a1562c5843265d51666ed7143e38a40d8472 Author: MICHAEL A. SHETTLES Date: Thu Mar 30 05:23:28 2023 -0600 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable commit a91514066278e2136102d8a64ce66445d71fa0a3 Merge: 348cced dc70eb6 Author: MICHAEL A. SHETTLES Date: Wed Mar 29 17:39:37 2023 -0600 Merge pull request #20 from forest-service/_pr15CrookstonDevelopment Pr15 crookston development commit dc70eb67a8b49899afe2c817e15e9689bf8c96d8 Author: Nicholas Crookston Date: Mon Mar 13 16:56:06 2023 -0700 Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. commit ba451694feb15e78112f6a54b55ee95c1c563c52 Author: Nicholas Crookston Date: Mon Mar 13 16:45:59 2023 -0700 Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. commit 20d7e1c38a6aa408f1184ac79928e32c57125cac Merge: e5463fc 348cced Author: Daniel Wagner Date: Fri Feb 24 15:34:01 2023 -0500 Merge branch 'development' of https://code.fs.usda.gov/forest-service/ForestVegetationSimulator-Interface into development commit 348cced1ddce0eaad9ecc6243d58ef8c54c03777 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 13:33:24 2023 -0700 Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) commit e5463fc9801f9691c996ab926aab19ba3279d41f Merge: 18d4719 8e04abb Author: Daniel Wagner Date: Fri Feb 24 14:36:40 2023 -0500 Merge branch 'development' of https://github.com/USDAForestService/ForestVegetationSimulator-Interface into development commit 18d47196a9ae69c733631d11b6081dabe4096039 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 12:29:40 2023 -0700 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list commit 955d5a2ecad8a502f9ee4306e053b6c28d5133b6 Author: MICHAEL A. SHETTLES Date: Thu Feb 16 11:33:06 2023 -0700 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. commit 8e04abb647131018852cd24767a2ee22e109350a Author: Michael Shettles Date: Fri Feb 10 11:48:04 2023 -0700 Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). commit e1b9bfbf09f5417c9face3f63c2788ac9f9a57d3 Author: DANIEL S. WAGNER Date: Mon Feb 6 16:33:44 2023 -0500 Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests commit bee30907733ded48557983a0995f5ea3f69f17e6 Merge: f563c78 6879a78 Author: DANIEL S. WAGNER Date: Thu Feb 2 09:44:52 2023 -0500 Merge pull request #16 from forest-service/Q2FVSCHANGES Round 2 for the changes since Jan 30th. commit 6879a782f155518f7aae0f35f3cfa3776006f506 Author: Michael Shettles Date: Wed Feb 1 16:27:10 2023 -0700 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. commit f563c78550babcc2648522c8b8b99c310ecc1271 Merge: a7063a5 d7514de Author: MICHAEL A. SHETTLES Date: Wed Feb 1 13:13:25 2023 -0700 Merge pull request #14 from forest-service/pr/nickcrookston/14 Pr/nickcrookston/14 commit d7514deff88c951412827f829fc8b753682deb2a Author: Daniel Wagner Date: Wed Feb 1 14:18:01 2023 -0500 Pull Request #14 Updates from NCrookston commit 0b35e4ce5a2872639e2933e5f7dc0bcbced0c9d4 Author: Nicholas Crookston Date: Wed Feb 1 08:41:12 2023 -0800 fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION commit 3c202662c3c1119e626a63e24cb78bbc608c4d00 Author: Nicholas Crookston Date: Wed Feb 1 08:38:43 2023 -0800 rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION commit a7063a5b7905da507c5ff02fb41cdfcc02582aaa Author: Nicholas Crookston Date: Fri Jan 13 15:02:16 2023 -0800 Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. commit 18fa412541b775e4c4adbc64d073437e9a3da8d2 Author: Nicholas Crookston Date: Thu Jan 12 15:49:37 2023 -0800 Fixed a bug I just introduced. commit 3bc464d4fff160ff739173bfbc36ccc47b5b08d6 Author: Nicholas Crookston Date: Thu Jan 12 15:28:20 2023 -0800 Commented out the ability to specify "development" code in new projects. commit 2e84c7904f4efa48966407632d5b5956673eec0a Author: Nicholas Crookston Date: Wed Dec 14 13:25:16 2022 +0100 Finished changes to convert from package sp to sf for spatial data commit 67ac4d5c5c5ec4a8c0ffc5576d6584acb585df39 Author: Nicholas Crookston Date: Tue Dec 13 11:48:42 2022 +0100 Rmeoved "NAMESPACE" from management by the repository commit 96434c5c79990417260288ade4f4667f847047d8 Author: Nicholas Crookston Date: Tue Dec 13 11:46:05 2022 +0100 Started process of adding support of package sf commit 4563c6b81e8593b272e1e92a65195ee4bbfa43e4 Merge: 231904a b3f05a0 Author: Nicholas Crookston Date: Tue Dec 13 10:17:49 2022 +0100 Merge branch 'development' of github.com:USDAForestService/ForestVegetationSimulator-Interface into development Local development branch is out of date with what Mike has commit 231904ad39c2c80312c3ebf5c6be0ab8866f7413 Author: Nicholas Crookston Date: Tue Dec 13 10:08:13 2022 +0100 rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). --- FVSPrjBldr/server.R | 6 +- FVSPrjBldr/ui.R | 8 +- fvsOL/DESCRIPTION | 5 +- fvsOL/NAMESPACE | 21 - fvsOL/R/componentWins.R | 47 +- fvsOL/R/externalCallable.R | 45 +- fvsOL/R/fvsRunUtilities.R | 6 +- fvsOL/R/mkInputElements.R | 4 +- fvsOL/R/server.R | 324 ++++----- fvsOL/R/ui.R | 8 +- fvsOL/R/writeKeyFile.R | 30 +- fvsOL/inst/extdata/customRun_fvsRunAcadian.R | 714 ++++++++++--------- fvsOL/makefile | 2 +- fvsOL/parms/ardwrd3.kwd | 6 +- fvsOL/parms/armwrd3.kwd | 6 +- fvsOL/parms/basekeys.kwd | 5 +- fvsOL/parms/dbs.kwd | 20 +- fvsOL/parms/keylist.prm | 167 ++--- fvsOL/parms/phewrd3.kwd | 6 +- rFVS/DESCRIPTION | 22 +- rFVS/NAMESPACE | 24 - rFVS/R/fvsCutNow.R | 27 + rFVS/R/fvsGetSpeciesAttrs.R | 78 +- rFVS/R/fvsMakeyFile.R | 81 +++ rFVS/R/fvsSetSpeciesAttr.R | 116 +-- rFVS/makefile | 2 +- 26 files changed, 972 insertions(+), 808 deletions(-) delete mode 100644 fvsOL/NAMESPACE delete mode 100644 rFVS/NAMESPACE create mode 100644 rFVS/R/fvsCutNow.R create mode 100644 rFVS/R/fvsMakeyFile.R diff --git a/FVSPrjBldr/server.R b/FVSPrjBldr/server.R index 9f96522..2f438d3 100644 --- a/FVSPrjBldr/server.R +++ b/FVSPrjBldr/server.R @@ -29,10 +29,10 @@ shinyServer(function(input, output, session) { workDir = paste0("/home/shiny/FVSwork/",uuid) cat("workDir=",workDir,"\n") dir.create(workDir) - if (input$version == "production") +# if (input$version == "production") cat ('library(fvsOL)\nfvsOL(fvsBin="/home/shiny/FVS/bin")\n',file=paste0(workDir,"/app.R")) - if (input$version == "development") - cat ('library(fvsOLdev)\nfvsOL(fvsBin="/home/shiny/FVSdev/bin")\n',file=paste0(workDir,"/app.R")) +# if (input$version == "development") +# cat ('library(fvsOLdev)\nfvsOL(fvsBin="/home/shiny/FVSdev/bin")\n',file=paste0(workDir,"/app.R")) # projectId file... cat("email=",emailnew,"\ntitle=",input$title,"\n") cat(file=paste0(workDir,"/projectId.txt"), diff --git a/FVSPrjBldr/ui.R b/FVSPrjBldr/ui.R index c97af24..1d3d369 100644 --- a/FVSPrjBldr/ui.R +++ b/FVSPrjBldr/ui.R @@ -20,10 +20,10 @@ shinyUI(fluidPage( textInput("title", "Your new project title"), textInput("emailnew", "Your Email address"), textInput("emaildup", "Your Email address again"), - radioButtons("version",NULL,choices=list( - "Use the production version of the software"="production", - "Use the development version"="development"), - selected="production"), +# radioButtons("version",NULL,choices=list( +# "Use the production version of the software"="production", +# "Use the development version"="development"), +# selected="production"), p("By pressing submit you are certifying that you agree to the Notice posted below."), actionButton("submitnew","Submit"), tags$style(type="text/css","#actionMsg{color:darkred;}"), diff --git a/fvsOL/DESCRIPTION b/fvsOL/DESCRIPTION index 0cd66ee..216ab85 100644 --- a/fvsOL/DESCRIPTION +++ b/fvsOL/DESCRIPTION @@ -1,6 +1,6 @@ Package: fvsOL Title: Forest Vegetation Simulator -Version: 2023.01.06 +Version: 2023.05.18 Authors@R: c(person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", role = c("aut")), person("Michael", "Shettles", email = "michael.a.shettles@usda.gov", @@ -14,4 +14,5 @@ Depends: R (>= 4.0.0), rFVS (>= 2021.03.15), shiny (>= 1.6.0), Cairo (>= 1.5.11) Suggests: rgdal (>= 1.5-23), nlme (>= 3.1-140) License: MIT Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 +Encoding: UTF-8 diff --git a/fvsOL/NAMESPACE b/fvsOL/NAMESPACE deleted file mode 100644 index f411e61..0000000 --- a/fvsOL/NAMESPACE +++ /dev/null @@ -1,21 +0,0 @@ -# Generated by roxygen2: do not edit by hand - -export(addNewRun2DB) -export(extnAddComponentKwds) -export(extnAddStands) -export(extnDeleteComponents) -export(extnDeleteRuns) -export(extnDuplicateRun) -export(extnErrorScan) -export(extnFromRaw) -export(extnGetComponentKwds) -export(extnListRuns) -export(extnListStands) -export(extnLoadFVSRun) -export(extnMakeKeyfile) -export(extnMakeRun) -export(extnSetRunOptions) -export(extnSimulateRun) -export(extnStoreFVSRun) -export(extnToRaw) -export(fvsOL) diff --git a/fvsOL/R/componentWins.R b/fvsOL/R/componentWins.R index 024012e..c6c0aeb 100644 --- a/fvsOL/R/componentWins.R +++ b/fvsOL/R/componentWins.R @@ -53,7 +53,7 @@ keyword.dbs.StandSQL.Win <- function(title, prms, globals, input, output) } keyword.dbs.StandSQL.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0("StandSQL\n",input$freeEdit,"\nEndSQL\n"), reopn = c(freeEdit=input$freeEdit) ) @@ -82,14 +82,12 @@ keyword.dbs.TreeSQL.Win <- function(title, prms, globals, input, output) } keyword.dbs.TreeSQL.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0("TreeSQL\n",input$freeEdit,"\nEndSQL\n"), reopn = c(freeEdit=input$freeEdit) ) } - - keyword.dbs.SQLIn.Win <- function(title, prms, globals, input, output) { globals$currentCmdDefs <- c(f1=" ",freeEdit="") @@ -99,22 +97,29 @@ keyword.dbs.SQLIn.Win <- function(title, prms, globals, input, output) ans = list( list ( mkScheduleBox("f1",prms,NULL,globals,input,output), + tags$style(type="text/css", + "#freeEditCols{font-family:monospace;font-size:90%;width:95%;}"), + tags$p(id="freeEditCols", + HTML(paste0(" ",paste0("....+....",1:8,collapse="")))), tags$style(type="text/css", "#freeEdit{font-family:monospace;font-size:90%;width:95%;}"), tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"]), tags$p(id="instruct",HTML(paste0( - "Run an query on the DSNIn connection. If the query is a SELECT, ", - "then the last row of the result table will define the values of ", - "variables in the Event Monitor. The variables will have the column names.
", - "Example:
Select Inv_Year as MyYear from FVS_StandInit ", - "where Stand_ID = '%StandID%';
will define MyYear in the Event Monitor") - )) + "Run a query on the DSNIn connection. If the query is a SELECT, ", + "the column names from the table are compared to the names of ", + "user-defined Event Monitor variables. For any matching variable, ", + "the value in the last row of the result table will define the values of ", + "variables in the Event Monitor.
", + "Example:
SELECT Inv_Year as MyYear
FROM FVS_StandInit
", + "WHERE Stand_ID = '%StandID%'
will define ", + "MyYear as a variable in the Event Monitor") + )) ),list()) ans } keyword.dbs.SQLIn.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0(sprintf("SQLIn %10s\n",input$f1),input$freeEdit,"\nEndSQL\n"), reopn = c(f1=input$f1,freeEdit=input$freeEdit) ) @@ -130,15 +135,29 @@ keyword.dbs.SQLOut.Win <- function(title, prms, globals, input, output) ans = list( list ( mkScheduleBox("f1",prms,NULL,globals,input,output), + tags$style(type="text/css", + "#freeEditCols{font-family:monospace;font-size:90%;width:95%;}"), + tags$p(id="freeEditCols", + HTML(paste0(" ",paste0("....+....",1:8,collapse="")))), tags$style(type="text/css", "#freeEdit{font-family:monospace;font-size:90%;width:95%;}"), - tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"])), - list()) + tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"]), + tags$p(id="instruct",HTML(paste0( + "Run a query on the DSNOut connection. If the query is a SELECT, ", + "the column names from the table are compared to the names of ", + "user-defined Event Monitor variables. For any matching variable, ", + "the value in the last row of the result table will define the values of ", + "variables in the Event Monitor.
", + "Example:
SELECT SDI as MySDI
FROM FVS_Summary2
", + "WHERE StandID = '%StandID%'
will define ", + "MySDI as a variable in the Event Monitor") + )) + ),list()) ans } keyword.dbs.SQLOut.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0(sprintf("SQLOut %10s\n",input$f1),input$freeEdit,"\nEndSQL\n"), reopn = c(f1=input$f1,freeEdit=input$freeEdit) ) diff --git a/fvsOL/R/externalCallable.R b/fvsOL/R/externalCallable.R index a119675..67e0bdd 100644 --- a/fvsOL/R/externalCallable.R +++ b/fvsOL/R/externalCallable.R @@ -679,7 +679,7 @@ extnMakeKeyfile <- function(prjDir=getwd(),runUUID,fvsBin="FVSBin", #' @param prjDir is the path name to the project directory, if null the #' current directory is the project directory. #' @param runUUID a character string of the run uuid that is processed -#' @return a vector of stand ids that are in the run. +#' @return data.frame of stand ids and corresponding uuids that are in the run. #' @examples #' runID <- extnMakeRun(title="Make a run, list the stands", #' standIDs=c("01100202010068","01100205010076","01100202010146"), @@ -693,9 +693,42 @@ extnListStands <- function(prjDir=getwd(),runUUID) on.exit(dbDisconnect(db)) fvsRun = loadFVSRun(db,runUUID) if (!exists("fvsRun")) stop("runUUID run data not loaded") - stands = c() - for (std in fvsRun$stands) stands=c(stands,std$sid) - return(stands) + return(data.frame(uuid= unlist(lapply(fvsRun$stands,function(x) x$uuid)), + stand=unlist(lapply(fvsRun$stands,function(x) x$sid )))) +} + +#' Given a project directory a run uuid, this function deletes stands using +#' the stand's UUIDs. +#' +#' @param prjDir is the path name to the project directory, if null the +#' current directory is the project directory. +#' @param runUUID a character string of the run uuid that is processed +#' @param a vector of stand UUIDs that are in the run that you want deleted. +#' @return the number of stands deleted. +#' @examples +#' runID <- extnMakeRun(title="Make a run, list the stands", +#' standIDs=c("01100202010068","01100205010076","01100202010146"), +#' variant="ie") +#' thestands <- extnListStands(runUUID=runID) +#' todel <- thestands[1,2] # delete the second stand +#' extnDeleteStands(prjDir=getwd(),runUUID,todel) +#' @export +extnDeleteStands <- function(prjDir=getwd(),runUUID,deleteStandUUIDs) +{ + if (missing(runUUID)) stop("runUUID required") + if (missing(deleteStandUUIDs)) stop("deleteStandUUIDs required") + db = connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(db)) + fvsRun = loadFVSRun(db,runUUID) + if (!exists("fvsRun")) stop("runUUID run data not loaded") + uuids=unlist(lapply(fvsRun$stands,function(x) x$uuid)) + del=na.omit(match(deleteStandUUIDs,uuids)) + if (length(del)) + { + fvsRun$stands[del]=NULL + storeFVSRun(db,fvsRun) + } + return(length(del)) } #' Fetch a run @@ -810,8 +843,6 @@ extnAddStands <- function(prjDir=getwd(),runUUID,stands, } allNeed = c("Groups","Inv_Year","AddFiles","FVSKeywords","Sam_Wt",needFs) fields = intersect(toupper(fields),toupper(allNeed)) - if (length(fields) < length(allNeed)) stop("required db fields are missing") - getStds = data.frame(getStds=if (addStandReps) stands else setdiff(stands, unlist(lapply(fvsRun$stands,function(x) x$sid)))) if (nrow(getStds) == 0) return(nadd) @@ -842,7 +873,7 @@ extnAddStands <- function(prjDir=getwd(),runUUID,stands, newstd <- mkfvsStd(sid=sid,uuid=uuidgen(),rep=0,repwt=1,invyr=as.character(invyr)) addfiles = fvsInit[row,"ADDFILES"] - if (!is.na(addfiles)) for (addf in names(addfiles)) + if (!is.null(addfiles)) for (addf in names(addfiles)) { nadd$ncmps=nadd$ncmps+1 newstd$cmps <- append(newstd$cmps, diff --git a/fvsOL/R/fvsRunUtilities.R b/fvsOL/R/fvsRunUtilities.R index 995e636..33eaff7 100644 --- a/fvsOL/R/fvsRunUtilities.R +++ b/fvsOL/R/fvsRunUtilities.R @@ -442,8 +442,8 @@ resetActiveFVS <- function(globals) "ls: Lake States"="ls", "ne: Northeast"="ne", "sn: Southern"="sn") - keep=match(globals$activeVariants,vars) - globals$activeVariants = if (length(keep) && !is.na(keep)) vars[keep] else character(0) + keep=na.omit(match(globals$activeVariants,vars)) + globals$activeVariants = if (length(keep)) vars[keep] else character(0) globals$activeExtens=character(0) } @@ -616,6 +616,7 @@ mkKeyWrd = function (ansFrm,input,pkeys,variant) cat("mkKeyWrd, ansFrm=\n",ansFrm,"\ninput=",input,"\n") state=0 out = NULL + if(variant!="ne" && length(grep("ThinRDSL",ansFrm))>0) out="ThinRDSL" if (is.null(pkeys) || is.null(input) || is.null(ansFrm)) return(out) for (i in 1:length(input)){ if(!is.null(input) && input[i]==" ") next @@ -927,6 +928,7 @@ moveToPaste <- function(item,globals,fvsRun,atag=NULL) names(globals$pastelistShadow)[1] = toRm$title } } + if(length(fvsRun$stands)==1)fvsRun$grps = list() fvsRun$stands[[i]] = NULL return(TRUE) } diff --git a/fvsOL/R/mkInputElements.R b/fvsOL/R/mkInputElements.R index 63a4120..da87788 100644 --- a/fvsOL/R/mkInputElements.R +++ b/fvsOL/R/mkInputElements.R @@ -434,6 +434,7 @@ mkVarList <- function (globals) "BCanCov: Before thin percent canopy cover (StrClass keyword required)"="BCanCov", "BCCF: Before thin CCF"="BCCF", "BDBHwtBA: Before thin average DBH weighted by stand basal area"="BDBHwtBA", + "BHTWTBA: Before thin average height weighted by stand basal area"="BHTWTBA", "BMaxHS: Before thin height of tallest tree in uppermost stratum (StrClass keyword required)"="BMaxHS", "BMCuFt: Before thin merchantable (western variants) sawtimber (eastern variants) cubic foot volume"="BMCuFt", "BMinHS: Before thin height of shortest tree in uppermost stratum (StrClass keyword required)"="BMinHS", @@ -478,7 +479,8 @@ mkVarList <- function (globals) "ABdFt: After thin board foot (western variants) sawtimber (eastern variants) volume"="ABdFt", "ACanCov: After thin percent canopy cover (StrClass keyword required)"="ACanCov", "ACCF: After thin CCF"="ACCF", - "ADBHwtBA: After thin average DBH weighted by stand basal area"="ADBHwtBA", + "ADBHwtBA: After thin average DBH weighted by stand basal area"="ADBHwtBA", + "AHTWTBA: After thin average height weighted by stand basal area"="AHTWTBA", "AMaxHS: After thin height of tallest tree in uppermost stratum (StrClass keyword required)"="AMaxHS", "AMCuFt: After thin merchantable (western variants) sawtimber (eastern variants) cubic foot volume"="AMCuFt", "AMinHS: After thin height of shortest tree in uppermost stratum (StrClass keyword required)"="AMinHS", diff --git a/fvsOL/R/server.R b/fvsOL/R/server.R index acda2b9..f1e57a0 100644 --- a/fvsOL/R/server.R +++ b/fvsOL/R/server.R @@ -136,7 +136,7 @@ trim <- function (x) gsub("^\\s+|\\s+$","",x) defaultRun <- list("Default useful for all FVS variants"="fvsRun") -## used in Tools, dlZipSet +# used in Tools, dlZipSet zipList <- list( "FVSProject data base (Runs, Custom components (kcp), Custom queries, GraphSettings)" = "fvsProjdb", "Output data base for for all runs" = "outdb", @@ -410,6 +410,26 @@ cat ("exit now\n") } }) + ## changeind + observe({ + cat ("changeind=",globals$changeind,"\n") + if (globals$changeind == 0){ + output$contChange <- renderUI("Run") + output$srtYr <-renderUI({ + HTML(paste0("",input$startyr,"")) + }) + output$eYr <-renderUI({ + HTML(paste0("",input$endyr,"")) + }) + output$cyLen <-renderUI({ + HTML(paste0("",input$cyclelen,"")) + }) + output$cyAt <-renderUI({ + HTML(paste0("",input$cycleat,"")) + }) + } + }) + ## Load observe({ if (input$topPan == "View Outputs" && input$leftPan == "Load") @@ -536,8 +556,7 @@ cat ("tb=",tb," cnt=",cnt,"\n") setProgress(value = NULL) return() } - isolate(dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh)) - input$bldstdsk # force this section to be reactive to changing "bldstdsk" + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) if (!isMetric) { if ("FVS_Summary" %in% tbs && ncases > 1) @@ -788,24 +807,71 @@ cat ("tbs7=",tbs,"\n") } }) - ## changeind - observe({ - cat ("changeind=",globals$changeind,"\n") - if (globals$changeind == 0){ - output$contChange <- renderUI("Run") - output$srtYr <-renderUI({ - HTML(paste0("",input$startyr,"")) - }) - output$eYr <-renderUI({ - HTML(paste0("",input$endyr,"")) - }) - output$cyLen <-renderUI({ - HTML(paste0("",input$cyclelen,"")) - }) - output$cyAt <-renderUI({ - HTML(paste0("",input$cycleat,"")) - }) - } + ## bldstdsk + observeEvent(input$bldstdsk,{ + tbs <- myListTables(dbGlb$dbOcon) +cat ("tbs related to the run",tbs,"\n") + if (length(tbs) == 0) + { + updateSelectInput(session, "selectdbtables", choices=list()) + return() + } + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) + tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) + if (any(tlprocs)) + { + tlprocs = names(tlprocs)[tlprocs] + chtoEast = function(cmd) + { + cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) + cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) + cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) + gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) + } + for (tlp in tlprocs) + { + if (tlp == "tlwest") + { + C_StdStkDBHSp = Create_StdStkDBHSp + C_HrvStdStk = Create_HrvStdStk + C_StdStk1Hrv = Create_StdStk1Hrv + C_StdStk1NoHrv = Create_StdStk1NoHrv + C_StdStkFinal = Create_StdStkFinal + C_CmpStdStk = Create_CmpStdStk + detail = "Building StdStk from tree lists" + stdstk = "StdStk" + clname = "FVS_CutList" + } else { + C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) + C_HrvStdStk = chtoEast(Create_HrvStdStk ) + C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) + C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) + C_StdStkFinal = chtoEast(Create_StdStkFinal ) + C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) + C_CmpStdStk = chtoEast(Create_CmpStdStk ) + C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) + C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) + detail = "Building StdStk_East from tree lists" + stdstk = "StdStk_East" + clname = "FVS_CutList_East" + } + exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + if (clname %in% tbs) + { + exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } else { + exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } + exqury(dbGlb$dbOcon,C_StdStkFinal) + ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] + if (ncases > 1) exqury(dbGlb$dbOcon,C_CmpStdStk) + } + } }) ## selectdbtables @@ -1067,8 +1133,9 @@ cat ("sqlSel input$sqlSel=",input$sqlSel," isnull=", if (!is.null(input$sqlSel)) { sel = as.numeric(input$sqlSel) + if(is.na(sel)) sel = as.numeric(match(input$sqlSel,names(globals$customQueries))) cat ("sqlSel sel=",sel,"\n") - if (length(globals$customQueries) >= sel) + if (length(globals$customQueries) >= sel || !is.null(sel)) { updateTextInput(session=session, inputId="sqlTitle", value=names(globals$customQueries)[sel]) @@ -1501,7 +1568,7 @@ cat("filterRows and/or pivot\n") output$table <- renderTable(dat) }) - ## Graphs + ##Graphs observe({ if (input$leftPan == "Explore" && input$outputRightPan == "Graphs") { @@ -1875,10 +1942,11 @@ cat ("vf test hit, nlevels(dat[,vf])=",nlevels(dat[,vf]),"\n") nlv = 1 + (!is.null(pb)) + (!is.null(vf)) + (!is.null(hf)) vars = c(input$xaxis, vf, hf, pb, input$yaxis) nd = NULL - sumOnSpecies = !"Species" %in% vars && "Species" %in% names(dat) && - nlevels(dat$Species)>1 - sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && - nlevels(dat$DBHClass)>1 + specOpts <- c("Species","SpeciesFVS","SpeciesPLANTS","SpeciesFIA") + sumOnSpecies= (all(!specOpts %in% vars) && any(specOpts %in% names(dat)) && + nlevels(dat$Species)>1) + sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && + nlevels(dat$DBHClass)>1 for (v in vars[(nlv+1):length(vars)]) { if (is.na(v) || !v %in% names(dat)) return(nullPlot()) @@ -1899,7 +1967,7 @@ cat("sumOnSpecies=",sumOnSpecies," sumOnDBHClass=",sumOnDBHClass,"\n") nd=subset(nd,DBHClass!="All") nd$DBHClass="Sum" } - if (sumOnSpecies||sumOnDBHClass) + if (sumOnSpecies || sumOnDBHClass) { nd=ddply(nd,setdiff(names(nd),"Y"),.fun=function (x) sum(x$Y)) names(nd)[ncol(nd)]="Y" @@ -2301,7 +2369,6 @@ cat ("Stands\n") cat ("inTabs\n") }) - ## inVars has changed observe({ if (is.null(input$inVars)) return() @@ -2318,8 +2385,10 @@ cat ("inVars globals$activeVariants=",globals$activeVariants, cat ("in reloadStandSelection\n") if (is.null(input$inTabs) || is.null(input$inVars)) return() sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) "StandPlot_ID" else "Stand_ID" - grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups from ",input$inTabs, + grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups, INV_YEAR from ",input$inTabs, ' where lower(variant) like "%',tolower(input$inVars),'%"'))) + grps <- subset(grps, !is.na(grps[grep("inv_year",tolower(names(grps)))])) + grps <- subset(grps, grps[grep("inv_year",tolower(names(grps)))] !="") if (class(grps) == "try-error" || is.null(grps) || nrow(grps) == 0) { dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") @@ -3748,7 +3817,7 @@ cat ("in buildKeywords, oReopn=",oReopn," kwPname=",kwPname,"\n") ans } ## Save in run - observe({ + observe({ if (length(input$cmdSaveInRun) && input$cmdSaveInRun == 0) return() isolate ({ if (identical(globals$currentEditCmp,globals$NULLfvsCmp) && @@ -3828,7 +3897,7 @@ cat ("Editing as freeform\n") } } cat ("Building a component: kwPname=",kwPname,"\n") - ans = if (kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), + ans = if (length(kwPname)==1 && kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), reopn=NULL,kwds=input$freeEdit) else buildKeywords(oReopn,pkeys, kwPname,globals) gensps <- grep("SpGroup", ans$kwds) if(length(gensps)) @@ -3944,26 +4013,6 @@ cat ("saving, kwds=",ans$kwds," title=",input$cmdTitle," reopn=",ans$reopn,"\n") globals$schedBoxPkey <- character(0) }) }) - - ## changeind - observe({ -cat ("changeind=",globals$changeind,"\n") - if (globals$changeind == 0){ - output$contChange <- renderUI("Run") - output$srtYr <-renderUI({ - HTML(paste0("",input$startyr,"")) - }) - output$eYr <-renderUI({ - HTML(paste0("",input$endyr,"")) - }) - output$cyLen <-renderUI({ - HTML(paste0("",input$cyclelen,"")) - }) - output$cyAt <-renderUI({ - HTML(paste0("",input$cycleat,"")) - }) - } - }) ## time--start year observe({ @@ -4766,6 +4815,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") if(length(globals$customCmps)==1){ customCmps=NULL removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() updateSelectInput(session=session, inputId="kcpSel", choices=list()) updateTextInput(session=session, inputId="kcpTitle", value="") updateTextInput(session=session, inputId="kcpEdit", value="") @@ -4786,6 +4836,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") } else { customCmps=NULL removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() updateSelectInput(session=session, inputId="kcpSel", choices=list()) updateTextInput(session=session, inputId="kcpTitle", value="") updateTextInput(session=session, inputId="kcpEdit", value="") @@ -4796,7 +4847,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") ## Download KCP output$kcpDownload <- downloadHandler(filename=function () - paste0(input$kcpSel,".kcp"), + paste0(input$kcpTitle,".kcp"), content=function (tf = tempfile()) { write(input$kcpEdit,tf) @@ -5310,7 +5361,7 @@ cat ("mapDsRunList input$mapDsTable=",isolate(input$mapDsTable), cat ("length(uidsToGet)=",length(uidsToGet),"\n") if (!length(uidsToGet)) return() uidsFound = NULL - library(rgdal) + library(sf) spatdat = "SpatialData.RData" if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && file.exists(spatdat)) load(spatdat,envir=dbGlb) @@ -5332,16 +5383,21 @@ cat ("1 matchVar=",matchVar,"\n") if (!length(uidsToGet)) break matchVar = attr(map,"MatchesStandID") cat ("2 matchVar=",matchVar,"\n") - uids=intersect(uidsToGet, map@data[,matchVar]) + # if the map has class sp, it needs to be converted. This code was added in Nov 2022 + # and can be removed once all the map data is converted to package sf. Note that + # this code allows for some members of the SpatialData to be sf and others sp. + qsp = attr(class(map),"package") + if (!is.null(qsp) && qsp == "sp") map=st_as_sf(map) + uids=intersect(uidsToGet, map[[matchVar]]) if (length(uids) == 0) next uidsFound = c(uidsFound,uids) - pp = spTransform(map[match(uids,map@data[,matchVar]),],CRS("+init=epsg:4326")) - if (class(pp)=="SpatialPolygonsDataFrame") + pp = st_transform(map[match(uids,map[[matchVar]]),],st_crs("epsg:4326")) + if (length(grep("POLYGON",st_geometry_type(pp)[1]))) { polys = if (is.null(polys)) pp else rbind(polys,pp) polyLbs= if (is.null(polyLbs)) uids else rbind(polyLbs,uids) } - if (class(pp)=="SpatialPointsDataFrame") + if (length(grep("POINT",st_geometry_type(pp)[1]))) { pts = if (is.null(pts)) pp else rbind(pts,pp) ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) @@ -5440,19 +5496,15 @@ cat ("rows to keep=",length(keep),"\n") } uids = latLng[,"Stand_ID"] uidsFound = c(uidsFound,uids) - coordinates(latLng) <- ~Longitude+Latitude - setProj <- function (obj) - { - proj4string(obj) <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs") - obj - } - latLng <- try(setProj(latLng)) - if (class(latLng)=="try-error") + latLng = st_as_sf(latLng, coords = c("Longitude","Latitude")) + latLng <- try(st_set_crs(latLng, + st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))) + if ("try-error" %in% class(latLng)) { output$leafletMessage=renderText("Error setting projection in location data.") return() } - pp = spTransform(latLng,CRS("+init=epsg:4326")) + pp = st_transform(latLng,st_crs("epsg:4326")) pts= if (is.null(pts)) pp else rbind(pts,pp) ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) } @@ -7559,7 +7611,7 @@ cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) rownames(dbGlb$tbl) = dbGlb$tbl$rowid for (col in 2:ncol(dbGlb$tbl)) - if (class(dbGlb$tbl[[col]]) != "character") + if (class(dbGlb$tbl[[col]])[1] != "character") dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else { @@ -7587,6 +7639,7 @@ cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), message = "Are you sure you want to delete all rows from this database table?")) } }) + observe({ if(input$clearTableDlgBtn == 0) return() cat ("clearTable, tbl=",dbGlb$tblName,"\n") @@ -7617,47 +7670,10 @@ cat ("clearTable, tbl=",dbGlb$tblName,"\n") if(input$inputDBPan == "Upload Map data") { cat ("Map data hit.\n") - require(rgdal) - progress <- shiny::Progress$new(session,min=1,max=3) - progress$set(message = "Preparing projection library",value = 2) - updateSelectInput(session=session, inputId="mapUpIDMatch",choices=list()) - if (!exists("prjs",envir=dbGlb,inherit=FALSE)) - { - dbGlb$prjs = make_EPSG() - delList = c("Unknown","deprecated","Unable to","Unspecified","Paris","China", - "Oslo","NZGD","Kalianpur","Hartebeesth","ELD79","Sierra Le","Locodjo","ETRS89", - "Xian 1980","Italy","GDM2000","KKJ ","Karbala","North Pole","LGD2006","JAD2","GDA94", - "HTRS96","Bermuda","Pitcairn","Cuba ","Kertau","Portug","Brunei","Jakarta","Abidjan", - "Chile","Russia","Japan","Israel","Nahrwan","Fiji","Viti L","PRS92","MAGNA-","Banglade", - "Minna","poraloko","Sahara","Zanderij","MGI","Ain el","Afgooye","Barbados","Carthage", - "Luzon","Maroc","Massawa","Schwarzeck","Tanana","Timbalai","OSNI","Irish","Trinidad", - "Voirol","Yoff","Belge ","Tokyo","British","Amersfoort","Lao ","Yemen ","Brazil", - "Indian","Indonesia","Garoua","Fahud","Egypt","Deir ez","Corrego","Cape /","Hong Kong", - "Bogota","Camacupa","Beijing","Batavia","Aratu","Adindan","Pulkovo","Lisbon","Hanoi", - "Macedonia","Cayman","Arctic","Europe","Krovak","Panama","Sibun G","Ocotepeque", - "Peru","DRUKREF","TUREF","Korea","Spain","Congo","Katanga","Manoca","LKS9","Tahiti", - "Argentina","Iraq","Slovenia","Naparima","Mauritania","Maupiti","Martinique","Estonian", - "Qatar","Doulas","Easter","Qornoq","Rassad","Miquelon","Segara","Tahhaa","Singapore") - dbGlb$prjs <- dbGlb$prjs[!is.na(dbGlb$prjs[,3]),] - for (del in delList) - { - tod = grep(del,dbGlb$prjs[,2],ignore.case=TRUE) -# cat ("del=",del," len=",length(tod)," nrow=",nrow(dbGlb$prjs),"\n") - if (length(tod)) dbGlb$prjs = dbGlb$prjs[-tod,] - } - } - dbGlb$prjs = dbGlb$prjs[order(dbGlb$prjs[,2]),] - grp = c(grep ("NAD",dbGlb$prjs[,2],fixed=TRUE),grep("WGS",dbGlb$prjs[,2],fixed=TRUE)) - dbGlb$prjs = rbind(dbGlb$prjs[grp,],dbGlb$prjs[-grp,]) + library(sf) updateSelectInput(session=session, inputId="mapUpLayers", choices=list(), selected=0) - epsg = as.character(1:nrow(dbGlb$prjs)) - names(epsg) = paste0("epsg:",dbGlb$prjs$code," ",dbGlb$prjs$note) - updateSelectInput(session=session, inputId="mapUpSelectEPSG", choices=epsg, - selected=0) - updateTextInput(session=session, inputId="mapUpProjection",value="") output$mapActionMsg = renderText(" ") - progress$close() } }) ## mapUpload @@ -7691,18 +7707,16 @@ cat ("mapUpload, filename=",input$mapUpload$datapath," ending=",fileEnding,"\n") progress$set(message = "Getting layers",value = 2) if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) setwd(mapDir) - lyrs = try(ogrListLayers(dir(mapDir))) + lyrs = try(sf::st_layers(dir(mapDir))) setwd(curdir) cat ("mapUpload, class(lyrs)=",class(lyrs),"\n") - if (class(lyrs) == "try-error" || length(lyrs) == 0) + if ("try-error" %in% class(lyrs) || length(lyrs$name)==0) { output$mapActionMsg = renderText("Can not find layers in data") progress$close() return() } - attributes(lyrs) = NULL - lyrs = as.list(lyrs) - names(lyrs) = unlist(lyrs) + lyrs = as.list(lyrs$name) if (length(lyrs) > 1) { lyr = grep ("poly",names(lyrs),ignore.case=TRUE) @@ -7729,38 +7743,33 @@ cat ("input$mapUpLayers =",input$mapUpLayers,"\n") if (length(dir(datadir)) == 1) setwd(datadir) progress <- shiny::Progress$new(session,min=1,max=3) progress$set(message = paste0("Loading map: ",datadir," Layer: ",input$mapUpLayers),value=2) - txtoutput = capture.output(dbGlb$spd <- try(readOGR(dir(),input$mapUpLayers, - drop_unsupported_fields=TRUE))) + txtoutput = capture.output(dbGlb$spd <- try(st_read(dir(),input$mapUpLayers))) setwd(curdir) - if (class(dbGlb$spd) == "try-error") + if ("try-error" %in% class(dbGlb$spd)) { output$mapActionMsg = renderText(paste0("Map read error: ",dbGlb$spd)) progress$close() setwd(curdir) return() } - for (col in colnames(dbGlb$spd@data)) - { - if (is.factor(dbGlb$spd@data[,col])) - dbGlb$spd@data[,col]=levels(dbGlb$spd@data[,col])[as.numeric(dbGlb$spd@data[,col])] - } txtoutput = paste0(txtoutput,collapse="\n") output$mapActionMsg = renderText(txtoutput) progress$set(message = txtoutput,value=3) - choices = as.list(names(dbGlb$spd@data)) - names(choices) = choices stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") ids = try(dbGetQuery(dbGlb$dbIcon,paste0('select Stand_ID from ',stdInit))) cat ("length(ids)=",length(ids),"\n") - if (class(ids) == "try-error" || nrow(ids) == 0) + choices = setdiff(names(dbGlb$spd),"geometry") + names(choices) = choices + if ("try-error" %in% class(ids) || nrow(ids) == 0) { - selected = grep("ID",names(dbGlb$spd@data),ignore.case=TRUE)[1] - selected = if (is.na(selected)) 0 else names(dbGlb$spd@data)[selected] + selected = grep("ID",choices,ignore.case=TRUE)[1] + if (is.na(selected)) selected=0 } else { ids = unlist(ids) + names(ids) = NULL cnts = NULL - for (col in colnames(dbGlb$spd@data)) - cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd@data[,col])))) + for (col in choices) + cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd[,col][[col]])))) cnts = cnts/length(ids)*100 choices = paste0(choices," ",format(cnts,digits=3),"%") selected = choices[which.max(cnts)] @@ -7768,48 +7777,9 @@ cat ("length(ids)=",length(ids),"\n") cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected=",selected,"\n") updateSelectInput(session=session, inputId="mapUpIDMatch", choices=choices,selected=selected) - prj = proj4string(dbGlb$spd) - if (!is.na(prj)) - { - updateTextInput(session=session, inputId="mapUpProjection",value=prj) - i = grep (prj,dbGlb$prjs$prj4,fixed=TRUE) - if(length(i) && !is.na(i)) - updateSelectInput(session=session, inputId="mapUpSelectEPSG",selected=i) - } progress$close() }) - ## mapUpSelectEPSG - observe({ - if(length(input$mapUpSelectEPSG)) - updateTextInput(session=session, inputId="mapUpProjection", - value=dbGlb$prjs[as.numeric(input$mapUpSelectEPSG),"prj4"]) - }) - ## mapUpSetPrj - observe({ - if(input$mapUpSetPrj > 0) - { - if (!exists("spd",envir=dbGlb,inherit=FALSE)) - { - output$mapActionMsg = renderText("No map, upload one then set projection") - return() - } - prjstring = trim(isolate(input$mapUpProjection)) - if (nchar(prjstring) == 0) - { - output$mapActionMsg = renderText("proj4 string is empty") - return() - } - prj = try(CRS(prjstring)) - if (class(prj) == "try-error") - { - output$mapActionMsg = renderText("proj4 string is not valid") - } else { - proj4string(dbGlb$spd) = prjstring - output$mapActionMsg = renderText("proj4 set/reset") - } - } - }) - ## prepSpatialData + prepSpatialData = function(dbGlb) { if (!exists("spd",envir=dbGlb,inherit=FALSE)) return(NULL) @@ -7817,18 +7787,22 @@ cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected ids1 = try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct Stand_ID from ',stdInit))) ids1 = if (class(ids1)=="try-error") list() else unlist(ids1) names(ids1) = NULL - ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) - ids2 = if (class(ids2)=="try-error") list() else unlist(ids2) - names(ids2) = NULL - keep=union(ids1,ids2) + if ("FVS_Cases" %in% + dbGetQuery(dbGlb$dbOcon,"SELECT * FROM sqlite_master where type='table'")$name) + { + ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) + ids2 = if ("try-error" %in% class(ids2)) list() else unlist(ids2) + names(ids2) = NULL + keep=union(ids1,ids2) + } else keep=ids1 matID = unlist(strsplit(input$mapUpIDMatch," "))[1] - keep=na.omit(charmatch(keep,dbGlb$spd@data[,matID])) + keep=na.omit(charmatch(keep,dbGlb$spd[,matID][[matID]])) if (length(keep)) { SpatialData=dbGlb$spd[keep,] attr(SpatialData,"MatchesStandID") = matID output$mapActionMsg = renderText(paste0("Map saved for this project, StandID match=", - matID,", Number of objects kept=",nrow(SpatialData@data))) + matID,", Number of objects kept=",nrow(SpatialData))) } else { SpatialData=NULL output$mapActionMsg = renderText("No map or data to save.") @@ -8112,15 +8086,17 @@ cat("unload zip had ",length(uz),"items. ml[[2]]=",ml[[2]],"\n") } else{ customQueries = list() newtitle = mkNameUnique(curTitle,customQueries) - } + } + globals$customQueries[newtitle]= source[curTitle] customQueries[newtitle] = source[curTitle] storeOrUpdateObject(dbGlb$prjDB,customQueries) output$impCustomQueriesMsg = renderText(paste0('Query "',curTitle,'" imported and ', ' is named "',newtitle,'" in your current project.')) updateSelectInput(session=session,inputId="sqlSel",choices=as.list(names(customQueries)), - selected=names(customQueries)[1]) + selected="") })} }) + ## impFVS_Data observe({ if (input$impFVS_Data > 0) diff --git a/fvsOL/R/ui.R b/fvsOL/R/ui.R index 4e62ce2..9271b80 100644 --- a/fvsOL/R/ui.R +++ b/fvsOL/R/ui.R @@ -672,18 +672,14 @@ FVSOnlineUI <- fixedPage( ), tabPanel("Upload Map data", h4('Upload a stand layer to use in the "View On Maps" feature.'), - h5("Note: Only spatial data found to have corresponding inventory data are stored (so load it first)."), + h5("Note: Only spatial data found to have corresponding inventory data are stored (so load your inventory data first)."), fileInput("mapUpload","Step 1: Upload polygon or point data (.zip that contains spatial data)", width="90%"), h6(), selectInput("mapUpLayers", label="Layer", choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), selectInput("mapUpIDMatch", label="Variable that matches StandID", choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), - selectInput("mapUpSelectEPSG", label="Projection library (abridged)", - choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), - textInput("mapUpProjection", label="proj4 projection string",width="70%"), - actionButton("mapUpSetPrj","Set/Reset proj4 projection (does not reproject uploaded data)"),h6(), - p(strong("Step 2: Do one of the following:")), + p(strong("Step 2: Do one of the following:")), tags$style(type="text/css","#mapUpSave{font-size: 120%; color:green;}"), tags$style(type="text/css","#mapUpAdd{font-size: 120%; color:green;}"), actionButton("mapUpSave","Install imported spatial data"), diff --git a/fvsOL/R/writeKeyFile.R b/fvsOL/R/writeKeyFile.R index bbac7db..c448840 100644 --- a/fvsOL/R/writeKeyFile.R +++ b/fvsOL/R/writeKeyFile.R @@ -483,6 +483,7 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) for (std in globals$fvsRun$stands) { RepsDesign=FALSE + EndPrev=FALSE names(fvsInit) <- toupper(names(fvsInit)) sRows = match (std$sid, fvsInit$STAND_ID) sRowp = match (std$sid, fvsInit$STANDPLOT_ID) @@ -548,6 +549,14 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) { if(lastExt != "base") cat ("End\n",file=fc,sep="") cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE + lastCnd = NULL + } + if (cmp$atag == "c" && (cmp$uuid != lastCnd && !is.null(lastCnd))) + { + if(lastExt != "base") cat ("End\n",file=fc,sep="") + cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE lastCnd = NULL } if (cmp$atag == "c") lastCnd = cmp$uuid @@ -557,7 +566,8 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) if (lastExt != exten && lastExt != "base") { lastExt = "base" - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE } naughty <- "Econ_reports" if (lastExt != exten && !any(!is.na(match(naughty,cmp$kwdName)))) @@ -612,6 +622,7 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) cmp$kwds,"\n",file=fc,sep="") if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE } + EndPrev=FALSE } } if (length(std$cmps)) for (cmp in std$cmps) @@ -621,15 +632,24 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) { if(lastExt != "base") cat ("End\n",file=fc,sep="") cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE lastCnd = NULL } + if (cmp$atag == "c" && (cmp$uuid != lastCnd && !is.null(lastCnd))) + { + if(lastExt != "base") cat ("End\n",file=fc,sep="") + cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE + lastCnd = NULL + } if (cmp$atag == "c") lastCnd = cmp$uuid exten= if (length(grep("&",cmp$exten,fixed=TRUE))) unlist(strsplit(cmp$exten,"&"))[1] else cmp$exten if (lastExt != exten && lastExt != "base") { lastExt = "base" - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE } naughty <- "Econ_reports" if (lastExt != exten && !any(!is.na(match(naughty,cmp$kwdName)))) @@ -668,13 +688,15 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) cmp$kwds,"\n",file=fc,sep="") } if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE + EndPrev=FALSE } if (!is.null(lastCnd) && lastExt != "base") { - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE lastExt = "base" } if (!is.null(lastCnd) && lastExt == "base") cat ("EndIf\n",file=fc,sep="") - if (is.null(lastCnd) && lastExt != "base") cat ("End\n",file=fc,sep="") + if (is.null(lastCnd) && lastExt != "base" && !EndPrev) cat ("End\n",file=fc,sep="") # insert modified sampling weight if needed. if (!is.null(wtofix[[std$sid]]) && !RepsDesign) { diff --git a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R index 5a9e57c..13d6435 100644 --- a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R +++ b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R @@ -1,356 +1,358 @@ - -unlink("Acadian.log") - -# Note: The form of the function call is very carefully coded. Make sure -# "runOps" exists if you want them to be used. -fvsRunAcadian <- function(runOps,logfile="Acadian.log") -{ - - if (!is.null(logfile) && !interactive()) - { - sink() - sink(logfile,append=TRUE) - } - - #load the growth model R code - rFn="AcadianGY.R" - if (file.exists(rFn)) source(rFn) else - { - rFn = system.file("extdata", rFn, package="fvsOL") - if (! file.exists(rFn)) stop("can not find and load model code") - source(rFn) - } - cat ("\nSource file for this fvsRunAcadian=\n",rFn,"\n") - cat ("*** in fvsRunAcadian",date()," AcadianVersionTag=",AcadianVersionTag,"\n") - cat ("\nrunOps=\n") - print (runOps) - - # process the ops. - INGROWTH = if (is.null(runOps$uiAcadianIngrowth)) "N" else - runOps$uiAcadianIngrowth - MinDBH = as.numeric(if (is.null(runOps$uiAcadianMinDBH)) "3.0" else - runOps$uiAcadianMinDBH) - mortModel= if (is.null(runOps$uiAcadianMort)) "Acadian" else - runOps$uiAcadianMort - CutPoint = if (is.null(runOps$uiAcadianCutPoint)) 0.95 else - as.numeric(runOps$uiAcadianCutPoin) - volLogic = if (is.null(runOps$uiAcadianVolume)) "Base Model" else - runOps$uiAcadianVolume - wThinMod = if (is.null(runOps$uiAcadianTHIN)) FALSE else - runOps$uiAcadianTHIN == "Yes" - CDEF = if (is.null(runOps$uiAcadianSBWCDEF)) NA else - as.numeric(runOps$uiAcadianSBWCDEF) - SBW.YR = if (is.null(runOps$uiAcadianSBW.YR)) NA else - as.numeric(runOps$uiAcadianSBW.YR) - SBW.DUR = if (is.null(runOps$uiAcadianSBW.DUR)) NA else - as.numeric(runOps$uiAcadianSBW.DUR) - SBW = if (is.null(runOps$uiAcadianSBW)) NULL else - if (runOps$uiAcadianSBW == "No") NULL else - c(CDEF=CDEF,SBW.YR=SBW.YR,SBW.DUR=SBW.DUR) - if (!is.null(SBW) && any(is.na(SBW))) SBW=NULL - - cat ("fvsRunAcadian, options set\n") - - #load some handy conversion factors - CMtoIN = fvsUnitConversion("CMtoIN") - INtoCM = fvsUnitConversion("INtoCM") - FTtoM = fvsUnitConversion("FTtoM") - MtoFT = fvsUnitConversion("MtoFT") - M3toFT3 = fvsUnitConversion("M3toFT3") - ACRtoHA = fvsUnitConversion("ACRtoHA") - HAtoACR = fvsUnitConversion("HAtoACR") - spcodes = fvsGetSpeciesCodes() - - #initialize THINMOD - THINMOD = NULL - - incr = list() - # define the acadian height function - calc_acd_ht=function(tree=orgtree){ - tree=tree %>% - dplyr::rowwise() %>% - dplyr::mutate(mcw=mcw(sp=SP, dbh=DBH), # Max crown width - MCA=100*((pi*(mcw/2)^2)/10000)*EXPF) %>% - dplyr::group_by(PLOT) %>% - dplyr::mutate(CCF=sum(MCA)) %>% # Plot crown competition factor - dplyr::ungroup() %>% - dplyr::rowwise() %>% - dplyr::mutate(pHT= HTPred(SPP=SP, DBH=DBH, CSI=CSI, CCF=CCF, BAL=BAL), # Predicted height - HT= case_when(HT == 0 | HT>100 ~pHT, # Use predicted height where value is missing or in excess of 100 - TRUE ~ HT), - HCB= HCBPred(SPP=SP, DBH=DBH, HT=pHT,CCF=CCF, BAL=BAL)) %>% - dplyr::ungroup() %>% - dplyr::mutate(pCR= (HT-HCB)/HT, # predicted crown ratio - CR= case_when(CR == 0 ~pCR, # use predicted crown ratio where value is missing - TRUE ~ CR)) - tree - } - - # start FVS but return prior to dubbing and calibration to dub in missing - # heights and crown ratios - - fvsRun(7,0) - CSI = fvsGetEventMonitorVariables("csi") - if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM - CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) - orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio")) - names(orgtree) = toupper(names(orgtree)) - orgtree$TREE= 1:nrow(orgtree) - names(orgtree)[match("SPECIES",names(orgtree))] = "SP" - names(orgtree)[match("TPA",names(orgtree))] = "EXPF" - orgtree$SP = spcodes[orgtree$SP,1] - #change CR to a proportion and take abs; note that in FVS a negative CR - #signals that CR change has been computed by the fire or insect/disease model - orgtree$CR = abs(orgtree$CRATIO) * .01 - orgtree$ba = orgtree$DBH * orgtree$DBH * 0.005454 * orgtree$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") - orgtree$DBH = orgtree$DBH * INtoCM - orgtree$HT = orgtree$HT * FTtoM - orgtree$EXPF = orgtree$EXPF * HAtoACR - orgtree = dplyr::arrange(orgtree, PLOT, desc(DBH)) - temp = unlist(by(orgtree$ba,INDICES=orgtree$PLOT,FUN=cumsum)) - orgtree$BAL = temp-orgtree$ba - orgtree = dplyr::arrange(orgtree, TREE) - newtree = calc_acd_ht(tree=orgtree) - fvsSetTreeAttrs(list(ht =as.numeric(newtree$HT*MtoFT), - cratio=round(as.numeric(newtree$CR)*100,2))) - - cat ("Starting repeat loop\n") - - repeat - { - #stopPointCode 5 (after growth and mortality, before it is added) - #stopPointCode 6 (just before estab, place to add new trees) - - #BE CAREFULL: the next few lines control when to exit the loop and - #the details are very important. It is easy to break this code! - rtn = fvsRun(stopPointCode=5,stopPointYear=-1) - if (rtn != 0) break - stopPoint <- fvsGetRestartcode() - # end of current stand? - cat ("first stopPoint code=",stopPoint,"\n") - if (stopPoint == 100) break - - cat ("fvsRunAcadian: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=", - mortModel,"\n volLogic=",volLogic," SBW=",SBW,"\n") - - # if there are no trees, this code does not work. - # NB: room is used below, so if this rule changes, move this code - room=fvsGetDims() - if (room["ntrees"] == 0) next - - #fetch some stand level information - stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear","elev")) - stdIds = fvsGetStandIDs() - cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 - attributes(cyclen) = NULL - CSI = fvsGetEventMonitorVariables("csi") - if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM - CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) - ELEV = as.numeric(stdInfo["elev"]) * FTtoM - cat ("fvsRunAcadian: CSI=",CSI," ELEV=",ELEV,"\n") - - #set/reset THINMOD based on pre and post event monitor variables - if (wThinMod) - { - thinning = fvsGetEventMonitorVariables(c("bba","aba","badbh","aadbh","rtpa")) - if (thinning["rtpa"] > 0) - { - THINMOD = c(stdInfo["year"], - (1-(thinning["aba"]/thinning["bba"]))*100., - thinning["bba"]*fvsUnitConversion("FT2pACRtoM2pHA"), - if (thinning["aadbh"]>=1) - thinning["badbh"]/thinning["aadbh"] else NA) - names(THINMOD) = c("YEAR_CT","pBArm","BApre","QMDratio") - } else if (!is.null(THINMOD) && - stdInfo["year"]-THINMOD["YEAR_CT"] > 20) THINMOD=NULL - } - - #fetch the fvs trees and form the AcadianGY "tree" dataframe - orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special")) - names(orgtree) = toupper(names(orgtree)) - orgtree$TREE= 1:nrow(orgtree) - names(orgtree)[match("SPECIES",names(orgtree))] = "SP" - names(orgtree)[match("TPA",names(orgtree))] = "EXPF" - orgtree$SP = spcodes[orgtree$SP,1] - #change CR to a proportion and take abs; note that in FVS a negative CR - #signals that CR change has been computed by the fire or insect/disease model - orgtree$CR = abs(orgtree$CRATIO) * .01 - orgtree$DBH = orgtree$DBH * INtoCM - orgtree$HT = orgtree$HT * FTtoM - orgtree$EXPF = orgtree$EXPF * HAtoACR - - #load the form and risk class data using FVS variable ISPECL loaded using "special" - - orgtree$Form = rep(" ",nrow(orgtree)) - orgtree$Risk = rep(" ",nrow(orgtree)) - tmpset = orgtree$SPECIAL > 0 & orgtree$SPECIAL < 85 - orgtree$Form[tmpset] = paste0("F",as.integer(orgtree$SPECIAL[tmpset] %/% 10)) - orgtree$Risk[tmpset] = paste0("R",as.integer(orgtree$SPECIAL[tmpset] %% 10)) - - stand = list(CSI=CSI,ELEV=ELEV) - ops = list(verbose=TRUE,INGROWTH=INGROWTH,MinDBH=MinDBH, - CutPoint=0.5, # >0 uses threshold probability (>0-1). - mortType="continuous", #mortType="discrete", - SBW=SBW,THINMOD=THINMOD,verbose=TRUE, - rtnVars = c("PLOT","SP","DBH","EXPF","TREE","HT","HCB","Form","Risk")) - - tree=orgtree - - for (year in stdInfo["year"]:stdInfo["cendyear"]) - { - tree$YEAR = year - cat ("fvsRunAcadian: calling AcadianGY, year=",year,"\n") - treeout = try(AcadianGYOneStand(tree,stand=stand,ops=ops)) - if (class(treeout)=="try-error" || any(is.na(treeout$DBH)) || - any(is.na(treeout$HT)) || any(is.na(treeout$EXPF))) - { - cat("AcadianGYOneStand failed in year=",year,"\n") - dmpFile=file.path(getwd(),paste0("AcadianGYOneStand.Failure.",year,".RData")) - if (class(treeout)!="try-error") treeout="critical result contains NA values" - cat ("dmpFile name=",dmpFile,"\n") - save(file=dmpFile,treeout,tree,stand,ops) - tree=NULL - break - } - tree=treeout - } - # if there was a failure, tree will be NULL, go on to the next stand cycle - if (is.null(tree)) next - # put the PLOT variable back to a character string (defactor it). - if (is.factor(tree$PLOT)) tree$PLOT = levels(tree$PLOT)[as.numeric(tree$PLOT)] - # restore the order of the trees - tree = tree[order(tree$TREE),] - - cat ("fvsRunAcadian: is.null(tree$dEXPF)=",is.null(tree$dEXPF),"\n") - cat ("fvsRunAcadian: cyclen=",cyclen,"sum1 EXPF=",sum(tree$EXPF), - " sum dEXPF=",if (is.null(tree$dEXPF)) NA else sum(tree$dEXPF),"\n") - - names(tree)[match("TPA",names(tree))] = "EXPF" - - tree$CR = round((1-(tree$HCB/tree$HT))*100,1) - tofvs = data.frame(id=orgtree$TREE, - dg=(tree$DBH[orgtree$TREE]-orgtree$DBH)*CMtoIN, - htg=(tree$HT[orgtree$TREE]-orgtree$HT)*MtoFT, - # set the crown ratio sign to negetive so that FVS - # doesn't change them. if already negetive, don't change them. - cratio=ifelse(orgtree$CRATIO < 0, orgtree$CRATIO, - -tree$CR[orgtree$TREE])) - special=as.numeric(substr(tree$Form[orgtree$TREE],2,2))*10+ - as.numeric(substr(tree$Risk[orgtree$TREE],2,2)) - - if (mortModel == "Acadian") tofvs$mort=(orgtree$EXPF- - tree$EXPF[orgtree$TREE])*ACRtoHA - fvsSetTreeAttrs(tofvs) - - atstop6 = FALSE - - # adding regeneration? - newTrees = nrow(tree) - nrow(orgtree) - cat ("fvsRunAcadian: num newtrees=",newTrees,"\n") - if (newTrees) - { - if (newTrees < room["maxtrees"] - room["ntrees"]) - { - newTrees = (nrow(orgtree)+1):nrow(tree) - toadd = data.frame(dbh =tree$DBH[newTrees]*CMtoIN, - species=match(tree$SP[newTrees],spcodes[,"fvs"]), - ht =tree$HT[newTrees]*MtoFT, - cratio =-tree$CR[newTrees], - plot =as.numeric(tree$PLOT[newTrees]), - tpa =tree$EXPF[newTrees]*ACRtoHA) - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - fvsAddTrees(toadd) - } else cat ("fvsRunAcadian: Not enough room for",newTrees, - "new trees. Stand=",fvsGetStandIDs()["standid"],"; Year=", - stdInfo["year"],"\n") - } - - # modifying volume? - if (volLogic == "Acadian") - { - cat ("fvsRunAcadian: Applying Acadian volume logic\n") - - mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) - vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) - vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], - mapply(KozakTreeVol,Bark="ob",Planted=0, - DBH=vols$dbh * INtoCM, - HT =vols$ht * FTtoM, - SPP=spcodes[vols$species,1], - stump=mcstds$mcstmp[vols$species] * FTtoM, - topD =mcstds$mctopd[vols$species] * INtoCM), 0) - - if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * - (1-(((vols$defect %% 10000) %/% 100) * .01)) - vols$mcuft = vols$mcuft * M3toFT3 - vols$species=NULL - vols$ht =NULL - vols$dbh =NULL - vols$defect =NULL - if (!atstop6) - { - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - } - fvsSetTreeAttrs(vols) - } - } - cat ("rtn=",rtn,"\n") - rtn -} - -# NOTE: I (NLCrookston) tried various ways of building these elements. Setting the -# initial value to the saved value when the elements are created seems to work well. -# What did not work was setting the initial value to some default and then -# changing it using an update call in the server code. - -uiAcadian <- function(fvsRun) -{ -cat ("in uiAcadian uiAcadianVolume=", - if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) "NULL" else - fvsRun$uiCustomRunOps$uiAcadianVolume,"\n") - - if (is.null(fvsRun$uiCustomRunOps$uiAcadianIngrowth)) - fvsRun$uiCustomRunOps$uiAcadianIngrowth = "No" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianMinDBH)) - fvsRun$uiCustomRunOps$uiAcadianMinDBH = "3.0" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianMort)) - fvsRun$uiCustomRunOps$uiAcadianMort = "Acadian" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianCutPoint)) - fvsRun$uiCustomRunOps$uiAcadianCutPoint = "0.95" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) - fvsRun$uiCustomRunOps$uiAcadianVolume = "Acadian" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianTHIN)) - fvsRun$uiCustomRunOps$uiAcadianTHIN = "Yes" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW)) - fvsRun$uiCustomRunOps$uiAcadianSBW = "No" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBWCDEF)) - fvsRun$uiCustomRunOps$uiAcadianSBWCDEF = "100" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.YR)) - fvsRun$uiCustomRunOps$uiAcadianSBW.YR = "2020" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.DUR)) - fvsRun$uiCustomRunOps$uiAcadianSBW.DUR = "10" - list( - myRadioGroup("uiAcadianIngrowth", "Simulate ingrowth:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianIngrowth), - myInlineTextInput("uiAcadianMinDBH","Minimum DBH for ingrowth", - fvsRun$uiCustomRunOps$uiAcadianMinDBH), - myRadioGroup("uiAcadianMort", "Mortality model:", - c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianMort), - myInlineTextInput("uiAcadianCutPoint","CutPoint", - fvsRun$uiCustomRunOps$uiAcadianCutPoint), - myRadioGroup("uiAcadianVolume", "Merchantable volume logic:", - c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianVolume), - myRadioGroup("uiAcadianTHIN", "Run with thinning modifiers:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianTHIN), - myRadioGroup("uiAcadianSBW", "Run with Spruce Budworm modifiers:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianSBW), - myInlineTextInput("uiAcadianSBWCDEF","Cumulative defoliation:", - fvsRun$uiCustomRunOps$uiAcadianSBWCDEF), - myInlineTextInput("uiAcadianSBW.YR","Defoliation start year:", - fvsRun$uiCustomRunOps$uiAcadianSBW.YR), - myInlineTextInput("uiAcadianSBW.DUR","Defoliation duration (years):", - fvsRun$uiCustomRunOps$uiAcadianSBW.DUR) - ) -} + +unlink("Acadian.log") + +# Note: The form of the function call is very carefully coded. Make sure +# "runOps" exists if you want them to be used. +fvsRunAcadian <- function(runOps,logfile="Acadian.log") +{ + + if (!is.null(logfile) && !interactive()) + { + sink() + sink(logfile,append=TRUE) + } + + #load the growth model R code + rFn="AcadianGY.R" + if (file.exists(rFn)) source(rFn) else + { + rFn = system.file("extdata", rFn, package="fvsOL") + if (! file.exists(rFn)) stop("can not find and load model code") + source(rFn) + } + cat ("\nSource file for this fvsRunAcadian=\n",rFn,"\n") + cat ("*** in fvsRunAcadian",date()," AcadianVersionTag=",AcadianVersionTag,"\n") + cat ("\nrunOps=\n") + print (runOps) + + # process the ops. + INGROWTH = if (is.null(runOps$uiAcadianIngrowth)) "N" else + runOps$uiAcadianIngrowth + MinDBH = as.numeric(if (is.null(runOps$uiAcadianMinDBH)) "3.0" else + runOps$uiAcadianMinDBH) + mortModel= if (is.null(runOps$uiAcadianMort)) "Acadian" else + runOps$uiAcadianMort + CutPoint = if (is.null(runOps$uiAcadianCutPoint)) 0.95 else + as.numeric(runOps$uiAcadianCutPoin) + volLogic = if (is.null(runOps$uiAcadianVolume)) "Base Model" else + runOps$uiAcadianVolume + wThinMod = if (is.null(runOps$uiAcadianTHIN)) FALSE else + runOps$uiAcadianTHIN == "Yes" + CDEF = if (is.null(runOps$uiAcadianSBWCDEF)) NA else + as.numeric(runOps$uiAcadianSBWCDEF) + SBW.YR = if (is.null(runOps$uiAcadianSBW.YR)) NA else + as.numeric(runOps$uiAcadianSBW.YR) + SBW.DUR = if (is.null(runOps$uiAcadianSBW.DUR)) NA else + as.numeric(runOps$uiAcadianSBW.DUR) + SBW = if (is.null(runOps$uiAcadianSBW)) NULL else + if (runOps$uiAcadianSBW == "No") NULL else + c(CDEF=CDEF,SBW.YR=SBW.YR,SBW.DUR=SBW.DUR) + if (!is.null(SBW) && any(is.na(SBW))) SBW=NULL + + cat ("fvsRunAcadian, options set\n") + + #load some handy conversion factors + CMtoIN = fvsUnitConversion("CMtoIN") + INtoCM = fvsUnitConversion("INtoCM") + FTtoM = fvsUnitConversion("FTtoM") + MtoFT = fvsUnitConversion("MtoFT") + M3toFT3 = fvsUnitConversion("M3toFT3") + ACRtoHA = fvsUnitConversion("ACRtoHA") + HAtoACR = fvsUnitConversion("HAtoACR") + spcodes = fvsGetSpeciesCodes() + + #initialize THINMOD + THINMOD = NULL + + incr = list() + # define the acadian height function + calc_acd_ht=function(tree=orgtree){ + tree=tree %>% + dplyr::rowwise() %>% + dplyr::mutate(mcw=mcw(sp=SP, dbh=DBH), # Max crown width + MCA=100*((pi*(mcw/2)^2)/10000)*EXPF) %>% + dplyr::group_by(PLOT) %>% + dplyr::mutate(CCF=sum(MCA)) %>% # Plot crown competition factor + dplyr::ungroup() %>% + dplyr::rowwise() %>% + dplyr::mutate(pHT= HTPred(SPP=SP, DBH=DBH, CSI=CSI, CCF=CCF, BAL=BAL), # Predicted height + HT= case_when(HT == 0 | HT>100 ~pHT, # Use predicted height where value is missing or in excess of 100 + TRUE ~ HT), + HCB= HCBPred(SPP=SP, DBH=DBH, HT=pHT,CCF=CCF, BAL=BAL)) %>% + dplyr::ungroup() %>% + dplyr::mutate(pCR= (HT-HCB)/HT, # predicted crown ratio + CR= case_when(CR == 0 ~pCR, # use predicted crown ratio where value is missing + TRUE ~ CR)) + tree + } + + # start FVS but return prior to dubbing and calibration to dub in missing + # heights and crown ratios +# This code is commented out because at stoppoint 7, +# fvsGetEventMonitorVariables("csi") does not yet return the csi. +# fvsRun(7,0) +# CSI = fvsGetEventMonitorVariables("csi") +# cat("stoppoint 7,CSI=",CSI,"\n") +# if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM +# CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) +# orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio")) +# names(orgtree) = toupper(names(orgtree)) +# orgtree$TREE= 1:nrow(orgtree) +# names(orgtree)[match("SPECIES",names(orgtree))] = "SP" +# names(orgtree)[match("TPA",names(orgtree))] = "EXPF" +# orgtree$SP = spcodes[orgtree$SP,1] +# #change CR to a proportion and take abs; note that in FVS a negative CR +# #signals that CR change has been computed by the fire or insect/disease model +# orgtree$CR = abs(orgtree$CRATIO) * .01 +# orgtree$ba = orgtree$DBH * orgtree$DBH * 0.005454 * orgtree$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") +# orgtree$DBH = orgtree$DBH * INtoCM +# orgtree$HT = orgtree$HT * FTtoM +# orgtree$EXPF = orgtree$EXPF * HAtoACR +# orgtree = dplyr::arrange(orgtree, PLOT, desc(DBH)) +# temp = unlist(by(orgtree$ba,INDICES=orgtree$PLOT,FUN=cumsum)) +# orgtree$BAL = temp-orgtree$ba +# orgtree = dplyr::arrange(orgtree, TREE) +# newtree = calc_acd_ht(tree=orgtree) +# fvsSetTreeAttrs(list(ht =as.numeric(newtree$HT*MtoFT), +# cratio=round(as.numeric(newtree$CR)*100,2))) + + cat ("Starting repeat loop\n") + + repeat + { + #stopPointCode 5 (after growth and mortality, before it is added) + #stopPointCode 6 (just before estab, place to add new trees) + + #BE CAREFULL: the next few lines control when to exit the loop and + #the details are very important. It is easy to break this code! + rtn = fvsRun(stopPointCode=5,stopPointYear=-1) + if (rtn != 0) break + stopPoint <- fvsGetRestartcode() + # end of current stand? + cat ("first stopPoint code=",stopPoint,"\n") + if (stopPoint == 100) break + + cat ("fvsRunAcadian: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=", + mortModel,"\n volLogic=",volLogic," SBW=",SBW,"\n") + + # if there are no trees, this code does not work. + # NB: room is used below, so if this rule changes, move this code + room=fvsGetDims() + if (room["ntrees"] == 0) next + + #fetch some stand level information + stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear","elev")) + stdIds = fvsGetStandIDs() + cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 + attributes(cyclen) = NULL + CSI = fvsGetEventMonitorVariables("csi") + if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM + CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) + ELEV = as.numeric(stdInfo["elev"]) * FTtoM + cat ("fvsRunAcadian: CSI=",CSI," ELEV=",ELEV,"\n") + + #set/reset THINMOD based on pre and post event monitor variables + if (wThinMod) + { + thinning = fvsGetEventMonitorVariables(c("bba","aba","badbh","aadbh","rtpa")) + if (thinning["rtpa"] > 0) + { + THINMOD = c(stdInfo["year"], + (1-(thinning["aba"]/thinning["bba"]))*100., + thinning["bba"]*fvsUnitConversion("FT2pACRtoM2pHA"), + if (thinning["aadbh"]>=1) + thinning["badbh"]/thinning["aadbh"] else NA) + names(THINMOD) = c("YEAR_CT","pBArm","BApre","QMDratio") + } else if (!is.null(THINMOD) && + stdInfo["year"]-THINMOD["YEAR_CT"] > 20) THINMOD=NULL + } + + #fetch the fvs trees and form the AcadianGY "tree" dataframe + orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special")) + names(orgtree) = toupper(names(orgtree)) + orgtree$TREE= 1:nrow(orgtree) + names(orgtree)[match("SPECIES",names(orgtree))] = "SP" + names(orgtree)[match("TPA",names(orgtree))] = "EXPF" + orgtree$SP = spcodes[orgtree$SP,1] + #change CR to a proportion and take abs; note that in FVS a negative CR + #signals that CR change has been computed by the fire or insect/disease model + orgtree$CR = abs(orgtree$CRATIO) * .01 + orgtree$DBH = orgtree$DBH * INtoCM + orgtree$HT = orgtree$HT * FTtoM + orgtree$EXPF = orgtree$EXPF * HAtoACR + + #load the form and risk class data using FVS variable ISPECL loaded using "special" + + orgtree$Form = rep(" ",nrow(orgtree)) + orgtree$Risk = rep(" ",nrow(orgtree)) + tmpset = orgtree$SPECIAL > 0 & orgtree$SPECIAL < 85 + orgtree$Form[tmpset] = paste0("F",as.integer(orgtree$SPECIAL[tmpset] %/% 10)) + orgtree$Risk[tmpset] = paste0("R",as.integer(orgtree$SPECIAL[tmpset] %% 10)) + + stand = list(CSI=CSI,ELEV=ELEV) + ops = list(verbose=TRUE,INGROWTH=INGROWTH,MinDBH=MinDBH, + CutPoint=0.5, # >0 uses threshold probability (>0-1). + mortType="continuous", #mortType="discrete", + SBW=SBW,THINMOD=THINMOD,verbose=TRUE, + rtnVars = c("PLOT","SP","DBH","EXPF","TREE","HT","HCB","Form","Risk")) + + tree=orgtree + + for (year in stdInfo["year"]:stdInfo["cendyear"]) + { + tree$YEAR = year + cat ("fvsRunAcadian: calling AcadianGY, year=",year,"\n") + treeout = try(AcadianGYOneStand(tree,stand=stand,ops=ops)) + if (class(treeout)=="try-error" || any(is.na(treeout$DBH)) || + any(is.na(treeout$HT)) || any(is.na(treeout$EXPF))) + { + cat("AcadianGYOneStand failed in year=",year,"\n") + dmpFile=file.path(getwd(),paste0("AcadianGYOneStand.Failure.",year,".RData")) + if (class(treeout)!="try-error") treeout="critical result contains NA values" + cat ("dmpFile name=",dmpFile,"\n") + save(file=dmpFile,treeout,tree,stand,ops) + tree=NULL + break + } + tree=treeout + } + # if there was a failure, tree will be NULL, go on to the next stand cycle + if (is.null(tree)) next + # put the PLOT variable back to a character string (defactor it). + if (is.factor(tree$PLOT)) tree$PLOT = levels(tree$PLOT)[as.numeric(tree$PLOT)] + # restore the order of the trees + tree = tree[order(tree$TREE),] + + cat ("fvsRunAcadian: is.null(tree$dEXPF)=",is.null(tree$dEXPF),"\n") + cat ("fvsRunAcadian: cyclen=",cyclen,"sum1 EXPF=",sum(tree$EXPF), + " sum dEXPF=",if (is.null(tree$dEXPF)) NA else sum(tree$dEXPF),"\n") + + names(tree)[match("TPA",names(tree))] = "EXPF" + + tree$CR = round((1-(tree$HCB/tree$HT))*100,1) + + tofvs = data.frame( + dg=(tree$DBH[orgtree$TREE]-orgtree$DBH)*CMtoIN, + htg=(tree$HT[orgtree$TREE]-orgtree$HT)*MtoFT, + # set the crown ratio sign to negetive so that FVS + # doesn't change them. if already negetive, don't change them. + cratio=ifelse(orgtree$CRATIO < 0, orgtree$CRATIO, + -tree$CR[orgtree$TREE])) + special=as.numeric(substr(tree$Form[orgtree$TREE],2,2))*10+ + as.numeric(substr(tree$Risk[orgtree$TREE],2,2)) + + if (mortModel == "Acadian") tofvs$mort=(orgtree$EXPF- + tree$EXPF[orgtree$TREE])*ACRtoHA + fvsSetTreeAttrs(tofvs) + + atstop6 = FALSE + + # adding regeneration? + newTrees = nrow(tree) - nrow(orgtree) + cat ("fvsRunAcadian: num newtrees=",newTrees,"\n") + if (newTrees) + { + if (newTrees < room["maxtrees"] - room["ntrees"]) + { + newTrees = (nrow(orgtree)+1):nrow(tree) + toadd = data.frame(dbh =tree$DBH[newTrees]*CMtoIN, + species=match(tree$SP[newTrees],spcodes[,"fvs"]), + ht =tree$HT[newTrees]*MtoFT, + cratio =-tree$CR[newTrees], + plot =as.numeric(tree$PLOT[newTrees]), + tpa =tree$EXPF[newTrees]*ACRtoHA) + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + fvsAddTrees(toadd) + } else cat ("fvsRunAcadian: Not enough room for",newTrees, + "new trees; Year=",year,"\n") + } + + # modifying volume? + if (volLogic == "Acadian") + { + cat ("fvsRunAcadian: Applying Acadian volume logic\n") + + mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) + vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) + vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], + mapply(KozakTreeVol,Bark="ob",Planted=0, + DBH=vols$dbh * INtoCM, + HT =vols$ht * FTtoM, + SPP=spcodes[vols$species,1], + stump=mcstds$mcstmp[vols$species] * FTtoM, + topD =mcstds$mctopd[vols$species] * INtoCM), 0) + + if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * + (1-(((vols$defect %% 10000) %/% 100) * .01)) + vols$mcuft = vols$mcuft * M3toFT3 + vols$species=NULL + vols$ht =NULL + vols$dbh =NULL + vols$defect =NULL + if (!atstop6) + { + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + } + fvsSetTreeAttrs(vols) + } + } + cat ("rtn=",rtn,"\n") + rtn +} + +# NOTE: I (NLCrookston) tried various ways of building these elements. Setting the +# initial value to the saved value when the elements are created seems to work well. +# What did not work was setting the initial value to some default and then +# changing it using an update call in the server code. + +uiAcadian <- function(fvsRun) +{ +cat ("in uiAcadian uiAcadianVolume=", + if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) "NULL" else + fvsRun$uiCustomRunOps$uiAcadianVolume,"\n") + + if (is.null(fvsRun$uiCustomRunOps$uiAcadianIngrowth)) + fvsRun$uiCustomRunOps$uiAcadianIngrowth = "No" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianMinDBH)) + fvsRun$uiCustomRunOps$uiAcadianMinDBH = "3.0" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianMort)) + fvsRun$uiCustomRunOps$uiAcadianMort = "Acadian" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianCutPoint)) + fvsRun$uiCustomRunOps$uiAcadianCutPoint = "0.95" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) + fvsRun$uiCustomRunOps$uiAcadianVolume = "Acadian" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianTHIN)) + fvsRun$uiCustomRunOps$uiAcadianTHIN = "Yes" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW)) + fvsRun$uiCustomRunOps$uiAcadianSBW = "No" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBWCDEF)) + fvsRun$uiCustomRunOps$uiAcadianSBWCDEF = "100" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.YR)) + fvsRun$uiCustomRunOps$uiAcadianSBW.YR = "2020" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.DUR)) + fvsRun$uiCustomRunOps$uiAcadianSBW.DUR = "10" + list( + myRadioGroup("uiAcadianIngrowth", "Simulate ingrowth:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianIngrowth), + myInlineTextInput("uiAcadianMinDBH","Minimum DBH for ingrowth", + fvsRun$uiCustomRunOps$uiAcadianMinDBH), + myRadioGroup("uiAcadianMort", "Mortality model:", + c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianMort), + myInlineTextInput("uiAcadianCutPoint","CutPoint", + fvsRun$uiCustomRunOps$uiAcadianCutPoint), + myRadioGroup("uiAcadianVolume", "Merchantable volume logic:", + c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianVolume), + myRadioGroup("uiAcadianTHIN", "Run with thinning modifiers:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianTHIN), + myRadioGroup("uiAcadianSBW", "Run with Spruce Budworm modifiers:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianSBW), + myInlineTextInput("uiAcadianSBWCDEF","Cumulative defoliation:", + fvsRun$uiCustomRunOps$uiAcadianSBWCDEF), + myInlineTextInput("uiAcadianSBW.YR","Defoliation start year:", + fvsRun$uiCustomRunOps$uiAcadianSBW.YR), + myInlineTextInput("uiAcadianSBW.DUR","Defoliation duration (years):", + fvsRun$uiCustomRunOps$uiAcadianSBW.DUR) + ) +} diff --git a/fvsOL/makefile b/fvsOL/makefile index 2b3b8c2..0d4a737 100644 --- a/fvsOL/makefile +++ b/fvsOL/makefile @@ -9,7 +9,7 @@ data/fvsOnlineHelpRender.RData: inst/extdata/mkhelp.R inst/extdata/fvsOnlineHelp fvsOLmadeTag: makefile DESCRIPTION R/* inst/extdata/* inst/extdata/www/* data/* cd .. && Rscript --default-packages=devtools -e "devtools::document(pkg='fvsOL')" cd .. && Rscript --default-packages=devtools -e "devtools::build(pkg='fvsOL')" - cd .. && Rscript --default-packages=devtools -e ".libPaths('~/R-dev');devtools::install(pkg='fvsOL',type='source')" + cd .. && Rscript --default-packages=devtools -e "devtools::install(pkg='fvsOL',type='source')" touch fvsOLmadeTag clean: diff --git a/fvsOL/parms/ardwrd3.kwd b/fvsOL/parms/ardwrd3.kwd index 4e86c4f..cb6ff62 100644 --- a/fvsOL/parms/ardwrd3.kwd +++ b/fvsOL/parms/ardwrd3.kwd @@ -1,7 +1,6 @@ //start keyword.ardwrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -645,8 +644,7 @@ RRMinK !1,10!!2,10!} //start keyword.ardwrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.ardwrd3.RRTreIn diff --git a/fvsOL/parms/armwrd3.kwd b/fvsOL/parms/armwrd3.kwd index ffe9680..0e61048 100644 --- a/fvsOL/parms/armwrd3.kwd +++ b/fvsOL/parms/armwrd3.kwd @@ -1,7 +1,6 @@ //start keyword.armwrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -580,8 +579,7 @@ parmsForm=answerForm //start keyword.armwrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.armwrd3.RRTreIn diff --git a/fvsOL/parms/basekeys.kwd b/fvsOL/parms/basekeys.kwd index f3cd594..75fe271 100644 --- a/fvsOL/parms/basekeys.kwd +++ b/fvsOL/parms/basekeys.kwd @@ -608,7 +608,7 @@ description: {Alters the change in crown by a specified proportion, or in the case of dubbing adjusts the dubbed crown by the specified proportion. -This keyword not applicable in NI, IE, CI, and KT variants. +This keyword not applicable in IE, CI, and KT variants. Once keyword is in effect, it remains in effect until replaced by another multiplier. @@ -4966,8 +4966,7 @@ automatically computed by the program). If the target relative is nonzero and the cutting control flag is nonzero, then the cutting efficiency parameter is used.} -description: -{This keyword can only be used in the Northeast variant.} +f1:{noInput This keyword can only be used in the Northeast variant.} f1{ne}:{scheduleBox} f2{ne}:{numberBox Residual Relative Density (within specified DBH range)} diff --git a/fvsOL/parms/dbs.kwd b/fvsOL/parms/dbs.kwd index 76ae255..3864f8c 100644 --- a/fvsOL/parms/dbs.kwd +++ b/fvsOL/parms/dbs.kwd @@ -15,16 +15,16 @@ ATRTLiDB !1,10!!2,10!} //end keyword.dbs.ATRTLiDB -//start keyword.dbs.BurnRept +//start keyword.dbs.BurnReDB f1:{listButtonString Build FVS_BurnReport table} f1v:{1 = Both database and standard output. >2 = Database table only.} parmsForm:{ -BurnRept !1,10!} +BurnReDB !1,10!} -//end keyword.dbs.BurnRept +//end keyword.dbs.BurnReDB //start keyword.dbs.CalbStDB @@ -407,3 +407,17 @@ description: output database. Table is written to main output file by default.} //end keyword.dbs.RDSum + +//start keyword.dbs.InvStats + +f1: +{noInput Build the FVS_Stats_Stand and FVS_Stats_Species tables.} + +//end keyword.dbs.InvStats + +//start keyword.dbs.RegRepts + +f1: +{noInput Build the regeneration establishment tables.} + +//end keyword.dbs.RegRepts diff --git a/fvsOL/parms/keylist.prm b/fvsOL/parms/keylist.prm index 777c92d..84d0270 100644 --- a/fvsOL/parms/keylist.prm +++ b/fvsOL/parms/keylist.prm @@ -10,7 +10,7 @@ AddFile {base io}: {Permits addition of a file containing keywords.} ATRTList {base io}: -{Prints a list of tree records representing stand conditions after a +{Prints a list of tree records representing stand conditions after a scheduled treatment to an output treelist file} BAIMult {base modifier}: @@ -20,11 +20,11 @@ BAMax {base modifier}: {Modifies maximum density for the stand and the mortality distribution pattern.} BFDefect {base vol}: -{Specifies species specific board-foot volume defect corrections for board foot +{Specifies species specific board-foot volume defect corrections for board foot volume estimates.} BFFDLN {base vol}: -{Enters species specific parameters for log-linear form and defect correction for +{Enters species specific parameters for log-linear form and defect correction for board-foot volume estimates.} BFVolEqu {base vol modifier}: @@ -37,7 +37,7 @@ CalbStat {base io}: {Specify the minimum number of observations required for calibration.} CCAdj {base modifier silv}: -{Adjusts the percent canopy cover (%CC) overlap assumption for clumpy or +{Adjusts the percent canopy cover (%CC) overlap assumption for clumpy or uniform stands. Can be used with THINCC to change the %CC target calculation.} Close {base io}: @@ -59,14 +59,14 @@ Compute {base io}: {Defines a user specified variable used by the Event Monitor.} CrnMult {base modifier silv}: -{Alters the change in crown by a specified proportion, or in the case of dubbing +{Alters the change in crown by a specified proportion, or in the case of dubbing adjusts the dubbed crown by the specified proportion.} CutEff {base thin silv}: {Changes the cutting efficiency for all thinnings.} CutList {base io thin}: -{Print a list of all harvested tree records or place a copy in a retrievable +{Print a list of all harvested tree records or place a copy in a retrievable mass storage file.} CWEqn {base modifier}: @@ -88,7 +88,7 @@ Design {base stdtre inventory}: {Specify information about the sampling design used to collect tree data.} DgStDev {base modifier}: -{Change the limits of the normal distribution from which random errors are +{Change the limits of the normal distribution from which random errors are drawn for diameter increment predictions.} Echo {base control}: @@ -142,7 +142,7 @@ MgmtId {base stdtre silv}: {4-character alphanumeric code identifying the projected silvicultural treatment.} MinHarv {base thin vol}: -{Specify minimum acceptable harvest standards for board-foot volume, +{Specify minimum acceptable harvest standards for board-foot volume, merchantable cubic-foot volume, or basal area per acre by cycle.} ModType {base inventory}: @@ -159,14 +159,14 @@ NoAutoES {base control regen}: {Suppresses all natural regeneration and ingrowth features.} NoCalib {base modifier inventory}: -{Suppress calculation of scale factors for large tree diameter increment model +{Suppress calculation of scale factors for large tree diameter increment model and small tree height increment model.} NoEcho {base control}: {Suppresses keyword echo to the Options Selected by Input in the Main Output file.} NoHtDReg {base modifier inventory}: -{Suppress the calculation of parameters for a local height-diameter equation for +{Suppress the calculation of parameters for a local height-diameter equation for use in dubbing the heights of trees which have missing recorded heights.} NoScreen {base io}: @@ -187,14 +187,14 @@ NumTrip {base control}: {Change the number of times tree records will be tripled.} Open {base io}: -{Request for an input or output file. A supplement record is required to specify a +{Request for an input or output file. A supplement record is required to specify a filename for the unit that is to be opened.} PointGrp {base thin silv stdtre}: {Defines a group of points referenced by a single name or number.} PointRef {base thin silv}: -{Specifies whether the point number entered on a keyword or Event Monitor function, +{Specifies whether the point number entered on a keyword or Event Monitor function, refers to the inventory point number or FVS sequential point number.} PrmFrost {base modifier}: @@ -227,7 +227,7 @@ ResetAge {base control silv}: {Resets the stand age to make output correspond to the age of the stand.} Screen {base io}: -{Allows printing of the summary output table to the terminal during program +{Allows printing of the summary output table to the terminal during program execution.} SDICalc {base modifier stdtre}: @@ -262,18 +262,18 @@ SpecPref {base thin silv}: {Change the species preference for removal.} StrClass {base control io}: -{Calculates structural class values and defines related Event Monitor +{Calculates structural class values and defines related Event Monitor structural class variables.} StandCN {base io}: {Enter stand_CN} Stats {base control io}: -{Optional table showing a statistical description of the input data for a +{Optional table showing a statistical description of the input data for a projection.} StdIdent {base stdtre io}: -{Specify a stand identification code and descriptive title to label output tables, +{Specify a stand identification code and descriptive title to label output tables, use the Suppose Current Subset Window to identify your stands.} StdInfo {base inventory stdtre}: @@ -313,7 +313,7 @@ ThinMist {base thin silv}: {Schedule the removal of trees with Dwarf Mistletoe Rating} ThinPRSC {base thin silv}: -{Schedule prescription thinning, harvesting trees that were marked for removal +{Schedule prescription thinning, harvesting trees that were marked for removal on the input tree records.} ThinPt {base thin silv}: @@ -332,7 +332,7 @@ ThinSDI {base thin silv}: {Schedule a thinning with a residual stand density index target.} TimeInt {base control}: -{Specify the length, in years, of any or all projection cycles. It is best to let +{Specify the length, in years, of any or all projection cycles. It is best to let Suppose set the cycle lengths.} TopKill {base modifier thin}: @@ -349,14 +349,14 @@ TreeList {base io}: file.} TreeSzCp {base modifier}: -{Sets limits for maximum tree diameter and height for a given species, and specifies +{Sets limits for maximum tree diameter and height for a given species, and specifies a minimum mortality rate when tree diameter exceeds the specified limit.} VolEqNum {base vol modifier}: {Changes the Volume Equation number used to calculate volume} Volume {base vol modifier}: -{Redefine merchantability limits for the merchantable cubic-foot volume +{Redefine merchantability limits for the merchantable cubic-foot volume equation.} YardLoss {base silv thin}: @@ -389,11 +389,11 @@ ShrbLayr {cover calib understory}: {Provides field data with which to calibrate shrub predictions.} ShrubHt {cover calib understory}: -{Supply calibration information where height in feet measurements have been +{Supply calibration information where height in feet measurements have been gathered for individual species.} ShrubPC {cover calib understory}: -{Supply calibration information where percent cover measurements have been +{Supply calibration information where percent cover measurements have been gathered for individual species.} Shrubs {cover control understory}: @@ -438,7 +438,7 @@ MistPrt {mist io}: ClimData {climate}: -{Signifies that the climate and species-viability data be read from an external file +{Signifies that the climate and species-viability data be read from an external file and specifies which Global Circulation Model/Scenario desired.} ClimRept {climate}: @@ -469,32 +469,32 @@ AuTally {estb modifier control inventory}: {Generates automatic tallies following thinnings.} BudWorm {estb stdtre silv regen}: -{Input defoliation histories for western spruce budworm and simulate the effects +{Input defoliation histories for western spruce budworm and simulate the effects of budworm defoliation on regeneration success.} BurnPrep {estb strp silv inventory}: {Enter the percentage of plots receiving a site preparation by burning.} Estab {estb strp control}: -{Enters the year of disturbance and signal that keywords following are for the +{Enters the year of disturbance and signal that keywords following are for the Regeneration Establishment extension.} EZCruise {estb strp silv inventory}: -{Predict the small tree component at the time of the inventory if the inventory +{Predict the small tree component at the time of the inventory if the inventory data does not include small trees.} HabGroup {estb io silv stdtre regen}: {Prints a table showing habitat types by habitat type group.} HtAdj {estb strp modifier io stdtre regen}: -{Enter a species specific initial height modifier for newly established trees before +{Enter a species specific initial height modifier for newly established trees before the tree records are passed to the FVS model.} Ingrow {estb stdtre regen}: {Toggles on the simulation of ingrowth.} MechPrep {estb strp silv inventory}: -{Enter the percentage of regeneration plots receiving a site preparation by +{Enter the percentage of regeneration plots receiving a site preparation by mechanical scarification.} MinPlots {estb strp inventory}: @@ -516,14 +516,14 @@ Output {estb strp io control}: {Control the kind of printed output described for this extension.} PassAll {estb io modifier control}: -{Specifies the number of "acceptable" predicted seedlings to be passed from the +{Specifies the number of "acceptable" predicted seedlings to be passed from the regeneration model to the FVS tree list during the tally.} Plant {estb strp silv regen}: {Specify that planting is to be simulated} PlotInfo {estb strp inventory stdtre silv}: -{Specify plot specific values for slope, aspect, habitat type, topographic position, +{Specify plot specific values for slope, aspect, habitat type, topographic position, and site preparation.} ESRanSd {estb strp modifier}: @@ -533,14 +533,14 @@ ResetAge {estb strp control silv}: {Resets the stand age to make output correspond to the age of the stand.} SpecMult {estb modifier stdtre regen}: -{Enter a species specific multiplier that adjusts the probability of a species' +{Enter a species specific multiplier that adjusts the probability of a species' occurrence in natural regeneration.} Sprout {estb strp stdtre regen}: {Turn on/or change the simulation of sprouting} StockAdj {estb modifier inventory regen}: -{Enter a multiplier to adjust the probability of natural regeneration stocking for +{Enter a multiplier to adjust the probability of natural regeneration stocking for individual plots.} Tally {estb strp control silv inventory}: @@ -550,7 +550,7 @@ TallyOne {estb strp inventory}: {Schedule the first regeneration tally in a specific year.} TallyTwo {estb strp inventory}: -{Schedule the second regeneration tally at any time after the first tally and up to +{Schedule the second regeneration tally at any time after the first tally and up to 20 years after a disturbance.} Thrshold {estb modifier inventory}: @@ -580,7 +580,7 @@ BBType4 {armwrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} DNSCalc {armwrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {armwrd3 modifier}: @@ -593,11 +593,11 @@ InfMult {armwrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {armwrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {armwrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {armwrd3 modifier}: @@ -616,7 +616,7 @@ RRComp {armwrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {armwrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {armwrd3 control io}: @@ -627,11 +627,11 @@ RRInit {armwrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {armwrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {armwrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {armwrd3 inventory}: @@ -647,7 +647,7 @@ SDIRMult {armwrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {armwrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spread {armwrd3 modifier}: @@ -660,7 +660,7 @@ TDistn {armwrd3 modifier}: {Specify the type of spatial distribution of trees in disease centers.} TimeDead {armwrd3 inventory}: -{Change the time since death for dead infected trees and stumps in the +{Change the time since death for dead infected trees and stumps in the inventory.} TTDMult {armwrd3 modifier}: @@ -693,7 +693,7 @@ BBType4 {phewrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} DNSCalc {phewrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {phewrd3 modifier}: @@ -706,11 +706,11 @@ InfMult {phewrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {phewrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {phewrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {phewrd3 modifier}: @@ -729,7 +729,7 @@ RRComp {phewrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {phewrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {phewrd3 control io}: @@ -740,11 +740,11 @@ RRInit {phewrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {phewrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {phewrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {phewrd3 inventory}: @@ -760,7 +760,7 @@ SDIRMult {phewrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {phewrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spread {phewrd3 modifier}: @@ -773,7 +773,7 @@ TDistn {phewrd3 modifier}: {Specify the type of spatial distribution of trees in disease centers.} TimeDead {phewrd3 inventory}: -{Change the time since death for dead infected trees and stumps in the +{Change the time since death for dead infected trees and stumps in the inventory.} TTDMult {phewrd3 modifier}: @@ -805,11 +805,11 @@ BBType4 {ardwrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} Borate {ardwrd3 mgmt}: -{Simulate the application of borax to stumps (to prevent the +{Simulate the application of borax to stumps (to prevent the colonization by spores) after each harvest.} DNSCalc {ardwrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {ardwrd3 modifier}: @@ -822,11 +822,11 @@ InfMult {ardwrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {ardwrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {ardwrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {ardwrd3 modifier}: @@ -845,11 +845,11 @@ RRComp {ardwrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {ardwrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {ardwrd3 control io}: -{Instruct the model to write the disease summary table +{Instruct the model to write the disease summary table to a seperate file.} RRHosts {ardwrd3 modifier}: @@ -859,11 +859,11 @@ RRInit {ardwrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {ardwrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {ardwrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {ardwrd3 inventory}: @@ -882,7 +882,7 @@ SDIRMult {ardwrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {ardwrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spore {ardwrd3 modifier}: @@ -947,15 +947,15 @@ DWDVlOut {fire io}: {Request the down wood volume report.} FireCalc {fire control modifier}: -{Adjust the fuel model selection logic used or select the option of using +{Adjust the fuel model selection logic used or select the option of using modelled fuel loads directly to predict fire behavior.} FlameAdj {fire control modifier}: -{Modify or set the flame length for a fire simulated using the +{Modify or set the flame length for a fire simulated using the SIMFIRE keyword scheduled for the same year.} FModList {fire control modifier}: -{Adjust the fuel models available for selection in conjuction with the new +{Adjust the fuel models available for selection in conjuction with the new fuel model logic (see FireCalc keyword).} FMortMlt {fire modifier}: @@ -987,33 +987,33 @@ FuelPool {fire modifier}: {Set the decay rate (very slow, slow, medium, fast) for each tree species.} FuelRept {fire io}: -{Request a fuel consumption and physical effects report be generated +{Request a fuel consumption and physical effects report be generated when a fire occurs.} FuelSoft {fire inventory modifier}: {Set the initial soft/rotten fuel loads for each fuel size class.} FuelTret {fire mgmt modifier}: -{Set the fuel treatment (lopping, chopping, etc) and harvest type +{Set the fuel treatment (lopping, chopping, etc) and harvest type (skidding, high lead, etc) so as to modify the fuel depth.} Moisture {fire modifier}: {Set the fuel moisture conditions for each fuel category.} MortClas {fire io modifier}: -{Set the lower bounds for the seven classes used in reporting +{Set the lower bounds for the seven classes used in reporting fire-caused mortality.} MortRept {fire io}: -{Request that a fire-caused tree mortality report be generated when a +{Request that a fire-caused tree mortality report be generated when a fire occurs.} PileBurn {fire mgmt modifier}: -{Schedule a pile or jackpot burn and modify tree mortality rates +{Schedule a pile or jackpot burn and modify tree mortality rates resulting from this fuel treatment.} PotFire {fire io}: -{Request that a report on potential fires under nominal burn +{Request that a report on potential fires under nominal burn conditions be generated.} PotFMois {fire modifier}: @@ -1044,7 +1044,7 @@ SnagBrk {fire modifier}: {Set the parameters for breaking (cause height loss) of standing snags.} SnagClas {fire io modifier}: -{Set the dbh size class boundaries for the snag report (see SnagOut +{Set the dbh size class boundaries for the snag report (see SnagOut and SnagSum).} SnagDCay {fire modifier}: @@ -1054,7 +1054,7 @@ SnagFall {fire modifier}: {Modify the snag fall rate by tree species.} SnagInit {fire inventory}: -{Add a snag record of a given species, size, height, age, and density +{Add a snag record of a given species, size, height, age, and density to the snag list.} SnagOut {fire io}: @@ -1083,14 +1083,14 @@ StatFuel {fire modifier}: ATRTLiDB {dbs}: {Requests the FVS_ATRTList table be created and populated.} -BurnRept {dbs}: +BurnReDB {dbs}: {Requests the FVS_BurnReport table be created and populated.} CalbStDB {dbs}: {Requests the FVS_CalbStat table be created and populated.} CarbReDB {dbs}: -{Requests the FVS_Carbon and FVS_Hrv_Carbon tables be +{Requests the FVS_Carbon and FVS_Hrv_Carbon tables be created and populated.} ClimReDB {dbs}: @@ -1117,6 +1117,10 @@ FuelReDB {dbs}: FuelsOut {dbs}: {Requests the FVS_Fuels table be created and populated.} +InvStats {dbs}: +{Requests the FVS_Stats_Stand and FVS_Stats_Species tables be +created and populated.} + MisRpts {dbs}: {Requests the FVS_DM_Spp_Sum, FVS_DM_Stnd_Sum, and FVS_DM_Sz_Sum dwarf mistletoe tables be created and populated.} @@ -1136,6 +1140,9 @@ RDDetail {dbs}: RDSum {dbs}: {Requests the FVS_RD_Sum table be created and populated.} +RegRepts {dbs}: +{Requests regeneration establishment table(s) be created and populated.} + SnagOuDB {dbs}: {Requests the FVS_SnagDet table be created and populated.} @@ -1143,15 +1150,15 @@ SnagSuDB {dbs}: {Requests the FVS_SnagSum table be created and populated.} StandSQL {dbs}: -{Specify an SQL statement that from which stand-level +{Specify an SQL statement that from which stand-level FVS variables are initialized.} SQLIn {dbs}: -{Requests that an SQL statement be run on the input +{Requests that an SQL statement be run on the input database connection (DSNIN).} SQLOut {dbs}: -{Requests that an SQL statement be run on the output +{Requests that an SQL statement be run on the output database connection (DSNIN).} StrClsDB {dbs}: @@ -1160,11 +1167,11 @@ StrClsDB {dbs}: Summary {dbs}: {Requests the FVS_Summary table be created and populated.} -TreeList {dbs}: +TreeLiDB {dbs}: {Requests the FVS_Treelist table be created and populated.} -TreeLiDB {dbs}: -{Specify an SQL statement that from which tree-level +TreeSQL {dbs}: +{Specify an SQL statement that from which tree-level FVS variables are initialized.} ! --------------------------------------- @@ -1187,7 +1194,7 @@ HrvVrCst {econ}: {Specifies commercial thinning or harvest cost by unit-of-measure and tree DBH.} HrvRvn {econ}: -{Specifies commercial thinning or harvest price by unit-of-measure by species +{Specifies commercial thinning or harvest price by unit-of-measure by species by diameter-class.} LbsCfv {econ}: @@ -1203,7 +1210,7 @@ PctFxCst {econ}: {Specifies per acre pre-commercial thinning cost.} PctSpec {econ}: -{Specifies removal parameters differentiating pre-commercial +{Specifies removal parameters differentiating pre-commercial thinning from commercial thinning or harvest.} PctVrCst {econ}: @@ -1213,7 +1220,7 @@ PlantCst {econ}: {Specifies planting cost.} Pretend {econ}: -{Requests that economic benefits and costs be calculated +{Requests that economic benefits and costs be calculated for a hypothetical stand harvest.} SpecCst {econ}: diff --git a/fvsOL/parms/phewrd3.kwd b/fvsOL/parms/phewrd3.kwd index 6159d6c..01a9936 100644 --- a/fvsOL/parms/phewrd3.kwd +++ b/fvsOL/parms/phewrd3.kwd @@ -1,7 +1,6 @@ //start keyword.phewrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -581,8 +580,7 @@ parmsForm=answerForm //start keyword.phewrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.phewrd3.RRTreIn diff --git a/rFVS/DESCRIPTION b/rFVS/DESCRIPTION index 61ba832..7ce7c12 100644 --- a/rFVS/DESCRIPTION +++ b/rFVS/DESCRIPTION @@ -1,11 +1,11 @@ -Package: rFVS -Title: Interface functions for the Forest Vegetation Simulator -Version: 2021.05.11 -Authors@R: person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", - role = c("aut", "cre")) -Description: Provides a set of R functions that interface with the - Forest Vegetation Simulator when it is run as a shared libray. -Depends: R (>= 4.0.0) -License: MIT -Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +Package: rFVS +Title: Interface functions for the Forest Vegetation Simulator +Version: 2023.02.01 +Authors@R: person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", + role = c("aut", "cre")) +Description: Provides a set of R functions that interface with the + Forest Vegetation Simulator when it is run as a shared libray. +Depends: R (>= 4.0.0) +License: MIT +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.2.1 diff --git a/rFVS/NAMESPACE b/rFVS/NAMESPACE deleted file mode 100644 index ef49812..0000000 --- a/rFVS/NAMESPACE +++ /dev/null @@ -1,24 +0,0 @@ -# Generated by roxygen2: do not edit by hand - -export(fvsAddActivity) -export(fvsAddTrees) -export(fvsCompositeSum) -export(fvsGetDims) -export(fvsGetEventMonitorVariables) -export(fvsGetRestartcode) -export(fvsGetSVSDims) -export(fvsGetSVSObjectSet) -export(fvsGetSpeciesAttrs) -export(fvsGetSpeciesCodes) -export(fvsGetStandIDs) -export(fvsGetSummary) -export(fvsGetTreeAttrs) -export(fvsInteractRun) -export(fvsLoad) -export(fvsRun) -export(fvsSetCmdLine) -export(fvsSetEventMonitorVariables) -export(fvsSetSpeciesAttrs) -export(fvsSetTreeAttrs) -export(fvsSetupSummary) -export(fvsUnitConversion) diff --git a/rFVS/R/fvsCutNow.R b/rFVS/R/fvsCutNow.R new file mode 100644 index 0000000..790ec7c --- /dev/null +++ b/rFVS/R/fvsCutNow.R @@ -0,0 +1,27 @@ +#' Specify a thinning/harvest by setting the proportion of each tree record's +#' sampling weight (trees/acre) that will be "cut" in the current cycle. +#' +#' This function can only be called at stoppoint 2, just after the first call +#' to the Event Monitor. The memory used to store the proportions in FVS is volatile +#' in that it is used for other purposes after the cut is simulated. The +#' specification of thinning/harvest using this option can be combined with other +#' other FVS thining options including the MinHarv and YardLoss keywords. This +#' feature is implemented using the ThinPrsc keyword. +#' +#' @param propcut a numeric vector holding the proportions of each tree. If a single value +#' is entered, it is replicated once of each sample tree in the simulation. +#' @return return code with the value 0 if OK, and non-zero otherwise +#' @export +fvsCutNow <- +function(propcut) +{ + if (fvsGetRestartcode() != 2) stop("function can only be used at stoppoint 2.") + if (missing(propcut)) stop("propcut is required.") + ntrees=fvsGetDims()[["ntrees"]] + if (length(propcut) == 1) propcut=rep(propcut,ntrees) + if (length(propcut) != ntrees) stop("a propcut for each tree record is required.") + r=fvsAddActivity(fvsGetEventMonitorVariables("Year"),"base_thinprsc",c(1.,-1)) + if (r != 0) return(r) + fvsSetTreeAttrs(list(wk6=propcut)) +} + \ No newline at end of file diff --git a/rFVS/R/fvsGetSpeciesAttrs.R b/rFVS/R/fvsGetSpeciesAttrs.R index ae3ae7b..f888385 100644 --- a/rFVS/R/fvsGetSpeciesAttrs.R +++ b/rFVS/R/fvsGetSpeciesAttrs.R @@ -1,30 +1,48 @@ -#' Return the values of species-specific data -#' -#' @param vars a character vector of species-level attributes desired: -#' \tabular{cl}{ -#' spccf \tab CCF for each species, recomputed in FVS so setting will likely have no effect\cr -#' spsdi \tab SDI maximums for each species \cr -#' spsiteindx \tab Species site indices\cr} -#' @return a data.frame where the columns are attributes and the rows are species. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetSpeciesAttrs(vars=c("spccf","spsiteindx")) -#' @export -fvsGetSpeciesAttrs <- -function(vars) -{ - maxspecies = fvsGetDims()["maxspecies"] - atr = vector("numeric",maxspecies) - action="get" - all = list() - for (name in vars) - { - nch =nchar(name) - ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[5]] == 0) all[[name]] = ans[[4]] - } - as.data.frame(all) -} - +#' Return the values of species-specific data +#' +#' @param vars a character vector of species-level attributes desired. See +#' \url{https://www.fs.usda.gov/fmsc/ftp/fvs/docs/gtr/EssentialFVS.pdf} for related details. +#' The attributes can be any of the following: +#' \tabular{cl}{ +#' spccf \tab CCF for each species, recomputed in FVS so setting may have no effect (depending on variant)\cr +#' spsdi \tab SDI maximums for each species \cr +#' spsiteindx \tab Species site indices\cr +#' bfmind \tab board foot minimum dbh for each species \cr +#' bftopd \tab board foot top diameter for each species \cr +#' bfstmp \tab board foot stump height for each species \cr +#' frmcls \tab board foot form class for each species \cr +#' bfmeth \tab board foot calculation method for each species \cr +#' mcmind \tab murchantable cubic volume minimum dbh for each species \cr +#' mctopd \tab murchantable cubic volume top diameter for each species \cr +#' mcstmp \tab murchantable cubic volume stump height for each species \cr +#' mcmeth \tab murchantable cubic volume calculation method for each species \cr +#' baimult \tab basal area increment multiplier for each species \cr +#' htgmult \tab height growth multiplier for each species \cr +#' mortmult \tab mortality rate multiplier for each species \cr +#' mortdia1 \tab lower diameter limit to apply the multiplier for each species \cr +#' mortdia2 \tab upper diameter limit to apply the multiplier for each species \cr +#' regdmult \tab multiplier for diameter growth of regeneration for each species \cr +#' reghmult \tab multiplier for height growth of regeneration for each species} +#' @return a data.frame where the columns are attributes and the rows are species. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetSpeciesAttrs(vars=c("spccf","spsiteindx")) +#' @export +fvsGetSpeciesAttrs <- +function(vars) +{ + maxspecies = fvsGetDims()["maxspecies"] + atr = vector("numeric",maxspecies) + action="get" + all = list() + for (name in vars) + { + nch =nchar(name) + ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[5]] == 0) all[[name]] = ans[[4]] + } + as.data.frame(all) +} + diff --git a/rFVS/R/fvsMakeyFile.R b/rFVS/R/fvsMakeyFile.R new file mode 100644 index 0000000..5fb7011 --- /dev/null +++ b/rFVS/R/fvsMakeyFile.R @@ -0,0 +1,81 @@ +#' Make an FVS keyword file suitable for running FVS using fvsLoad, fvsSetCmdLine and fvsRun +#' +#' Pass basic parameters needed to create an FVS input keyword file and this function will +#' generate the file. +#' +#' @param keyFileName the keyword file name, if not specified unique name is created and used as the +#' file name (the file name is returned). +#' @param runTitle the name of the run +#' @param standIDs A character vector of one or more standIDs, keywords are generated for each. +#' @param inDataBase The name of the input database, default is FVS_Data.db +#' @param outDataBase The name of the output database, default is FVSOut.db +#' @param ncycles The number of FVS cycles, default is 10. +#' @param moreKeywords One of the following: A character vector of properly formatted keyword records +#' that will be added to each stand, OR +#' A data.frame where the first column is a keyword and subsequent columns are "keyword" fields +#' that are added to the keywords. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsMakeKeyFile(runTitle="Test",standIDs=c("01100202010142","01100201010056")) +#' @export + +fvsMakeKeyFile <- function (keyFileName=NULL,runTitle=NULL,standIDs=NULL, + inDataBase="FVS_Data.db",outDataBase="FVSOut.db",ncycles=10,moreKeywords=NULL) +{ + trim <- function (x) gsub("^\\s+|\\s+$","",x) + if (is.null(standIDs)) stop("standIds must be specified.") + + if (is.null(keyFileName)) keyFileName=tempfile(pattern="fvs",fileext=".key",tmpdir=getwd()) + if (file.exists(keyFileName)) unlink(keyFileName) + fc = file(description=keyFileName,open="wt") + cat ("!!title:",runTitle,"\n",file=fc) + cat ("!!built:",format(Sys.time(), + "%Y-%m-%d_%H:%M:%S"),"\n",file=fc) + for (sid in standIDs) + { + sid = trim(sid) + cat ("\nStdIdent\n",sprintf("%-26s%s\n",sid,runTitle),sep="",file=fc) + cat (sprintf("%-10s%10s\n","NumCycle",as.character(ncycles)),sep="",file=fc) + if (!is.null(inDataBase)) + { + cat ("DataBase\nDSNin\n",inDataBase,"\nStandSQL\n",sep="",file=fc) + cat ("SELECT * FROM FVS_StandInit WHERE Stand_ID = '%StandID%'\n",sep="",file=fc) + cat ("EndSQL\nTreeSQL\n",sep="",file=fc) + cat ("SELECT * FROM FVS_TreeInit WHERE Stand_ID = '%StandID%'\n",sep="",file=fc) + cat ("EndSQL\nEND\n",sep="",file=fc) + } + if (!is.null(outDataBase)) + { + cat ("DataBase\nDSNOut\n",outDataBase, + "\nSummary 2\nComputdb 0 1\nEnd\n", + sep="",file=fc) + } + if (is.null(moreKeywords)) + cat("DelOTab 1\nDelOTab 2\nDelOTab 4\n",sep="",file=fc) + if (class(moreKeywords)=="character") + { + for (kw in moreKeywords) cat(kw,"\n",file=fc) + } else if (class(moreKeywords)=="data.frame") + { + if (class(moreKeywords) == "data.frame") for (row in 1:nrow(moreKeywords)) + { + if (nchar(moreKeywords[row,1])==0) next + kw=sprintf("%-10s",trim(moreKeywords[row,1]),file=fc) + if (ncol(morekeywords)>1) + { + for (col in 2:ncol(moreKeywords)) + kw=paste0(kw,sprintf("%10s",trim(as.character(moreKeywords[row,col])))) + } + } + cat(kw,"\n",file=fc) + } + cat ("\nProcess\n",sep="",file=fc) + } + cat ("Stop\n",sep="",file=fc) + close(fc) + keyFileName +} + + + diff --git a/rFVS/R/fvsSetSpeciesAttr.R b/rFVS/R/fvsSetSpeciesAttr.R index 4750c20..849b1cb 100644 --- a/rFVS/R/fvsSetSpeciesAttr.R +++ b/rFVS/R/fvsSetSpeciesAttr.R @@ -1,49 +1,67 @@ -#' Set the values of species-specific data -#' -#' @param vars a named list of numeric vectors where the name corresponds to an attribute and -#' the vector contains values for each species (in order). The attributes can be any of these: -#' \tabular{cl}{ -#' spccf \tab CCF for each species, recomputed in FVS so setting will likely have no effect\cr -#' spsdi \tab SDI maximums for each species \cr -#' spsiteindx \tab Species site indices\cr} -#' @return scalar integer 0 signals OK and 1 signals an error. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' vars = fvsGetSpeciesAttrs(vars=c("spccf","spsdi","spsiteindx")) -#' fvsSetSpeciesAttrs(vars=vars) -#' @export -fvsSetSpeciesAttrs <- -function(vars) -{ - maxspecies = fvsGetDims()["maxspecies"] - action = "set" - if (!is.list(vars)) stop("vars must be a list") - if (is.null(names(vars))) stop ("vars must have names") - rtn = 0 - for (name in names(vars)) - { - atr = as.numeric(vars[[name]]) - if (length(atr) != maxspecies) - { - warning("Length of '",name,"' must be ",maxspecies) - next - } - if (any(is.na(atr))) - { - warning ("NA(s) found for variable '",name,"'") - next - } - nch =nchar(name) - ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[5]] != 0) - { - rtn = if (ans[[5]] > rtn) ans[[5]] else rtn - warning ("error assigning variable '",name,"'") - next - } - } - invisible(rtn) -} - +#' Set the values of species-specific data +#' +#' @param vars a named list of numeric vectors where the name corresponds to an attribute and +#' the vector contains values for each species (in order). See +#' \url{https://www.fs.usda.gov/fmsc/ftp/fvs/docs/gtr/EssentialFVS.pdf} for related details. +#' The attrubytes can be any of the following: +#' \tabular{cl}{ +#' spccf \tab CCF for each species, recomputed in FVS so setting may have no effect (depending on variant)\cr +#' spsdi \tab SDI maximums for each species \cr +#' spsiteindx \tab Species site indices\cr +#' bfmind \tab board foot minimum dbh for each species \cr +#' bftopd \tab board foot top diameter for each species \cr +#' bfstmp \tab board foot stump height for each species \cr +#' frmcls \tab board foot form class for each species \cr +#' bfmeth \tab board foot calculation method for each species \cr +#' mcmind \tab murchantable cubic volume minimum dbh for each species \cr +#' mctopd \tab murchantable cubic volume top diameter for each species \cr +#' mcstmp \tab murchantable cubic volume stump height for each species \cr +#' mcmeth \tab murchantable cubic volume calculation method for each species \cr +#' baimult \tab basal area increment multiplier for each species \cr +#' htgmult \tab height growth multiplier for each species \cr +#' mortmult \tab mortality rate multiplier for each species \cr +#' mortdia1 \tab lower diameter limit to apply the multiplier for each species \cr +#' mortdia2 \tab upper diameter limit to apply the multiplier for each species \cr +#' regdmult \tab multiplier for diameter growth of regeneration for each species \cr +#' reghmult \tab multiplier for height growth of regeneration for each species} +#' @return scalar integer 0 signals OK and 1 signals an error. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' vars = fvsGetSpeciesAttrs(vars=c("spccf","spsdi","spsiteindx")) +#' fvsSetSpeciesAttrs(vars=vars) +#' @export +fvsSetSpeciesAttrs <- +function(vars) +{ + maxspecies = fvsGetDims()["maxspecies"] + action = "set" + if (!is.list(vars)) stop("vars must be a list") + if (is.null(names(vars))) stop ("vars must have names") + rtn = 0 + for (name in names(vars)) + { + atr = as.numeric(vars[[name]]) + if (length(atr) != maxspecies) + { + warning("Length of '",name,"' must be ",maxspecies) + next + } + if (any(is.na(atr))) + { + warning ("NA(s) found for variable '",name,"'") + next + } + nch =nchar(name) + ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[5]] != 0) + { + rtn = if (ans[[5]] > rtn) ans[[5]] else rtn + warning ("error assigning variable '",name,"'") + next + } + } + invisible(rtn) +} + diff --git a/rFVS/makefile b/rFVS/makefile index f5e6869..ca3fcec 100644 --- a/rFVS/makefile +++ b/rFVS/makefile @@ -3,7 +3,7 @@ all: rFVSmadeTag rFVSmadeTag: makefile DESCRIPTION R/* cd .. && Rscript --default-packages=devtools -e "devtools::document(pkg='rFVS')" cd .. && Rscript --default-packages=devtools -e "devtools::build(pkg='rFVS')" - cd .. && Rscript --default-packages=devtools -e ".libPaths('~/R-dev');devtools::install(pkg='rFVS',type='source',repos=NULL)" + cd .. && Rscript --default-packages=devtools -e "devtools::install(pkg='rFVS',type='source',repos=NULL)" touch rFVSmadeTag clean: From 4c47074f783edfe4f320ca01f7fdb8aecee96d0f Mon Sep 17 00:00:00 2001 From: wagnerds <100228553+wagnerds@users.noreply.github.com> Date: Mon, 22 May 2023 11:23:25 -0400 Subject: [PATCH 2/3] Bringing Main up to 2023 Q2 Status (#17) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). * Started process of adding support of package sf * Rmeoved "NAMESPACE" from management by the repository * Finished changes to convert from package sp to sf for spatial data * Commented out the ability to specify "development" code in new projects. * Fixed a bug I just introduced. * Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. * rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION * fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION * Pull Request #14 Updates from NCrookston * 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. * Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. * 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list * Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) * Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. * Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. * 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable --------- Co-authored-by: Nicholas Crookston Co-authored-by: MICHAEL A. SHETTLES --- FVSPrjBldr/server.R | 6 +- FVSPrjBldr/ui.R | 8 +- fvsOL/DESCRIPTION | 5 +- fvsOL/NAMESPACE | 21 - fvsOL/R/componentWins.R | 47 +- fvsOL/R/externalCallable.R | 45 +- fvsOL/R/fvsRunUtilities.R | 6 +- fvsOL/R/mkInputElements.R | 4 +- fvsOL/R/server.R | 324 ++++----- fvsOL/R/ui.R | 8 +- fvsOL/R/writeKeyFile.R | 30 +- fvsOL/inst/extdata/customRun_fvsRunAcadian.R | 714 ++++++++++--------- fvsOL/makefile | 2 +- fvsOL/parms/ardwrd3.kwd | 6 +- fvsOL/parms/armwrd3.kwd | 6 +- fvsOL/parms/basekeys.kwd | 5 +- fvsOL/parms/dbs.kwd | 20 +- fvsOL/parms/keylist.prm | 167 ++--- fvsOL/parms/phewrd3.kwd | 6 +- rFVS/DESCRIPTION | 22 +- rFVS/NAMESPACE | 24 - rFVS/R/fvsCutNow.R | 27 + rFVS/R/fvsGetSpeciesAttrs.R | 78 +- rFVS/R/fvsMakeyFile.R | 81 +++ rFVS/R/fvsSetSpeciesAttr.R | 116 +-- rFVS/makefile | 2 +- 26 files changed, 972 insertions(+), 808 deletions(-) delete mode 100644 fvsOL/NAMESPACE delete mode 100644 rFVS/NAMESPACE create mode 100644 rFVS/R/fvsCutNow.R create mode 100644 rFVS/R/fvsMakeyFile.R diff --git a/FVSPrjBldr/server.R b/FVSPrjBldr/server.R index 9f96522..2f438d3 100644 --- a/FVSPrjBldr/server.R +++ b/FVSPrjBldr/server.R @@ -29,10 +29,10 @@ shinyServer(function(input, output, session) { workDir = paste0("/home/shiny/FVSwork/",uuid) cat("workDir=",workDir,"\n") dir.create(workDir) - if (input$version == "production") +# if (input$version == "production") cat ('library(fvsOL)\nfvsOL(fvsBin="/home/shiny/FVS/bin")\n',file=paste0(workDir,"/app.R")) - if (input$version == "development") - cat ('library(fvsOLdev)\nfvsOL(fvsBin="/home/shiny/FVSdev/bin")\n',file=paste0(workDir,"/app.R")) +# if (input$version == "development") +# cat ('library(fvsOLdev)\nfvsOL(fvsBin="/home/shiny/FVSdev/bin")\n',file=paste0(workDir,"/app.R")) # projectId file... cat("email=",emailnew,"\ntitle=",input$title,"\n") cat(file=paste0(workDir,"/projectId.txt"), diff --git a/FVSPrjBldr/ui.R b/FVSPrjBldr/ui.R index c97af24..1d3d369 100644 --- a/FVSPrjBldr/ui.R +++ b/FVSPrjBldr/ui.R @@ -20,10 +20,10 @@ shinyUI(fluidPage( textInput("title", "Your new project title"), textInput("emailnew", "Your Email address"), textInput("emaildup", "Your Email address again"), - radioButtons("version",NULL,choices=list( - "Use the production version of the software"="production", - "Use the development version"="development"), - selected="production"), +# radioButtons("version",NULL,choices=list( +# "Use the production version of the software"="production", +# "Use the development version"="development"), +# selected="production"), p("By pressing submit you are certifying that you agree to the Notice posted below."), actionButton("submitnew","Submit"), tags$style(type="text/css","#actionMsg{color:darkred;}"), diff --git a/fvsOL/DESCRIPTION b/fvsOL/DESCRIPTION index 0cd66ee..216ab85 100644 --- a/fvsOL/DESCRIPTION +++ b/fvsOL/DESCRIPTION @@ -1,6 +1,6 @@ Package: fvsOL Title: Forest Vegetation Simulator -Version: 2023.01.06 +Version: 2023.05.18 Authors@R: c(person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", role = c("aut")), person("Michael", "Shettles", email = "michael.a.shettles@usda.gov", @@ -14,4 +14,5 @@ Depends: R (>= 4.0.0), rFVS (>= 2021.03.15), shiny (>= 1.6.0), Cairo (>= 1.5.11) Suggests: rgdal (>= 1.5-23), nlme (>= 3.1-140) License: MIT Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 +Encoding: UTF-8 diff --git a/fvsOL/NAMESPACE b/fvsOL/NAMESPACE deleted file mode 100644 index f411e61..0000000 --- a/fvsOL/NAMESPACE +++ /dev/null @@ -1,21 +0,0 @@ -# Generated by roxygen2: do not edit by hand - -export(addNewRun2DB) -export(extnAddComponentKwds) -export(extnAddStands) -export(extnDeleteComponents) -export(extnDeleteRuns) -export(extnDuplicateRun) -export(extnErrorScan) -export(extnFromRaw) -export(extnGetComponentKwds) -export(extnListRuns) -export(extnListStands) -export(extnLoadFVSRun) -export(extnMakeKeyfile) -export(extnMakeRun) -export(extnSetRunOptions) -export(extnSimulateRun) -export(extnStoreFVSRun) -export(extnToRaw) -export(fvsOL) diff --git a/fvsOL/R/componentWins.R b/fvsOL/R/componentWins.R index 024012e..c6c0aeb 100644 --- a/fvsOL/R/componentWins.R +++ b/fvsOL/R/componentWins.R @@ -53,7 +53,7 @@ keyword.dbs.StandSQL.Win <- function(title, prms, globals, input, output) } keyword.dbs.StandSQL.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0("StandSQL\n",input$freeEdit,"\nEndSQL\n"), reopn = c(freeEdit=input$freeEdit) ) @@ -82,14 +82,12 @@ keyword.dbs.TreeSQL.Win <- function(title, prms, globals, input, output) } keyword.dbs.TreeSQL.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0("TreeSQL\n",input$freeEdit,"\nEndSQL\n"), reopn = c(freeEdit=input$freeEdit) ) } - - keyword.dbs.SQLIn.Win <- function(title, prms, globals, input, output) { globals$currentCmdDefs <- c(f1=" ",freeEdit="") @@ -99,22 +97,29 @@ keyword.dbs.SQLIn.Win <- function(title, prms, globals, input, output) ans = list( list ( mkScheduleBox("f1",prms,NULL,globals,input,output), + tags$style(type="text/css", + "#freeEditCols{font-family:monospace;font-size:90%;width:95%;}"), + tags$p(id="freeEditCols", + HTML(paste0(" ",paste0("....+....",1:8,collapse="")))), tags$style(type="text/css", "#freeEdit{font-family:monospace;font-size:90%;width:95%;}"), tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"]), tags$p(id="instruct",HTML(paste0( - "Run an query on the DSNIn connection. If the query is a SELECT, ", - "then the last row of the result table will define the values of ", - "variables in the Event Monitor. The variables will have the column names.
", - "Example:
Select Inv_Year as MyYear from FVS_StandInit ", - "where Stand_ID = '%StandID%';
will define MyYear in the Event Monitor") - )) + "Run a query on the DSNIn connection. If the query is a SELECT, ", + "the column names from the table are compared to the names of ", + "user-defined Event Monitor variables. For any matching variable, ", + "the value in the last row of the result table will define the values of ", + "variables in the Event Monitor.
", + "Example:
SELECT Inv_Year as MyYear
FROM FVS_StandInit
", + "WHERE Stand_ID = '%StandID%'
will define ", + "MyYear as a variable in the Event Monitor") + )) ),list()) ans } keyword.dbs.SQLIn.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0(sprintf("SQLIn %10s\n",input$f1),input$freeEdit,"\nEndSQL\n"), reopn = c(f1=input$f1,freeEdit=input$freeEdit) ) @@ -130,15 +135,29 @@ keyword.dbs.SQLOut.Win <- function(title, prms, globals, input, output) ans = list( list ( mkScheduleBox("f1",prms,NULL,globals,input,output), + tags$style(type="text/css", + "#freeEditCols{font-family:monospace;font-size:90%;width:95%;}"), + tags$p(id="freeEditCols", + HTML(paste0(" ",paste0("....+....",1:8,collapse="")))), tags$style(type="text/css", "#freeEdit{font-family:monospace;font-size:90%;width:95%;}"), - tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"])), - list()) + tags$textarea(id="freeEdit", rows=10, globals$currentCmdDefs["freeEdit"]), + tags$p(id="instruct",HTML(paste0( + "Run a query on the DSNOut connection. If the query is a SELECT, ", + "the column names from the table are compared to the names of ", + "user-defined Event Monitor variables. For any matching variable, ", + "the value in the last row of the result table will define the values of ", + "variables in the Event Monitor.
", + "Example:
SELECT SDI as MySDI
FROM FVS_Summary2
", + "WHERE StandID = '%StandID%'
will define ", + "MySDI as a variable in the Event Monitor") + )) + ),list()) ans } keyword.dbs.SQLOut.Win.mkKeyWrd <- function(input,output) { - list(ex="base", + list(ex="dbs", kwds = paste0(sprintf("SQLOut %10s\n",input$f1),input$freeEdit,"\nEndSQL\n"), reopn = c(f1=input$f1,freeEdit=input$freeEdit) ) diff --git a/fvsOL/R/externalCallable.R b/fvsOL/R/externalCallable.R index a119675..67e0bdd 100644 --- a/fvsOL/R/externalCallable.R +++ b/fvsOL/R/externalCallable.R @@ -679,7 +679,7 @@ extnMakeKeyfile <- function(prjDir=getwd(),runUUID,fvsBin="FVSBin", #' @param prjDir is the path name to the project directory, if null the #' current directory is the project directory. #' @param runUUID a character string of the run uuid that is processed -#' @return a vector of stand ids that are in the run. +#' @return data.frame of stand ids and corresponding uuids that are in the run. #' @examples #' runID <- extnMakeRun(title="Make a run, list the stands", #' standIDs=c("01100202010068","01100205010076","01100202010146"), @@ -693,9 +693,42 @@ extnListStands <- function(prjDir=getwd(),runUUID) on.exit(dbDisconnect(db)) fvsRun = loadFVSRun(db,runUUID) if (!exists("fvsRun")) stop("runUUID run data not loaded") - stands = c() - for (std in fvsRun$stands) stands=c(stands,std$sid) - return(stands) + return(data.frame(uuid= unlist(lapply(fvsRun$stands,function(x) x$uuid)), + stand=unlist(lapply(fvsRun$stands,function(x) x$sid )))) +} + +#' Given a project directory a run uuid, this function deletes stands using +#' the stand's UUIDs. +#' +#' @param prjDir is the path name to the project directory, if null the +#' current directory is the project directory. +#' @param runUUID a character string of the run uuid that is processed +#' @param a vector of stand UUIDs that are in the run that you want deleted. +#' @return the number of stands deleted. +#' @examples +#' runID <- extnMakeRun(title="Make a run, list the stands", +#' standIDs=c("01100202010068","01100205010076","01100202010146"), +#' variant="ie") +#' thestands <- extnListStands(runUUID=runID) +#' todel <- thestands[1,2] # delete the second stand +#' extnDeleteStands(prjDir=getwd(),runUUID,todel) +#' @export +extnDeleteStands <- function(prjDir=getwd(),runUUID,deleteStandUUIDs) +{ + if (missing(runUUID)) stop("runUUID required") + if (missing(deleteStandUUIDs)) stop("deleteStandUUIDs required") + db = connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(db)) + fvsRun = loadFVSRun(db,runUUID) + if (!exists("fvsRun")) stop("runUUID run data not loaded") + uuids=unlist(lapply(fvsRun$stands,function(x) x$uuid)) + del=na.omit(match(deleteStandUUIDs,uuids)) + if (length(del)) + { + fvsRun$stands[del]=NULL + storeFVSRun(db,fvsRun) + } + return(length(del)) } #' Fetch a run @@ -810,8 +843,6 @@ extnAddStands <- function(prjDir=getwd(),runUUID,stands, } allNeed = c("Groups","Inv_Year","AddFiles","FVSKeywords","Sam_Wt",needFs) fields = intersect(toupper(fields),toupper(allNeed)) - if (length(fields) < length(allNeed)) stop("required db fields are missing") - getStds = data.frame(getStds=if (addStandReps) stands else setdiff(stands, unlist(lapply(fvsRun$stands,function(x) x$sid)))) if (nrow(getStds) == 0) return(nadd) @@ -842,7 +873,7 @@ extnAddStands <- function(prjDir=getwd(),runUUID,stands, newstd <- mkfvsStd(sid=sid,uuid=uuidgen(),rep=0,repwt=1,invyr=as.character(invyr)) addfiles = fvsInit[row,"ADDFILES"] - if (!is.na(addfiles)) for (addf in names(addfiles)) + if (!is.null(addfiles)) for (addf in names(addfiles)) { nadd$ncmps=nadd$ncmps+1 newstd$cmps <- append(newstd$cmps, diff --git a/fvsOL/R/fvsRunUtilities.R b/fvsOL/R/fvsRunUtilities.R index 995e636..33eaff7 100644 --- a/fvsOL/R/fvsRunUtilities.R +++ b/fvsOL/R/fvsRunUtilities.R @@ -442,8 +442,8 @@ resetActiveFVS <- function(globals) "ls: Lake States"="ls", "ne: Northeast"="ne", "sn: Southern"="sn") - keep=match(globals$activeVariants,vars) - globals$activeVariants = if (length(keep) && !is.na(keep)) vars[keep] else character(0) + keep=na.omit(match(globals$activeVariants,vars)) + globals$activeVariants = if (length(keep)) vars[keep] else character(0) globals$activeExtens=character(0) } @@ -616,6 +616,7 @@ mkKeyWrd = function (ansFrm,input,pkeys,variant) cat("mkKeyWrd, ansFrm=\n",ansFrm,"\ninput=",input,"\n") state=0 out = NULL + if(variant!="ne" && length(grep("ThinRDSL",ansFrm))>0) out="ThinRDSL" if (is.null(pkeys) || is.null(input) || is.null(ansFrm)) return(out) for (i in 1:length(input)){ if(!is.null(input) && input[i]==" ") next @@ -927,6 +928,7 @@ moveToPaste <- function(item,globals,fvsRun,atag=NULL) names(globals$pastelistShadow)[1] = toRm$title } } + if(length(fvsRun$stands)==1)fvsRun$grps = list() fvsRun$stands[[i]] = NULL return(TRUE) } diff --git a/fvsOL/R/mkInputElements.R b/fvsOL/R/mkInputElements.R index 63a4120..da87788 100644 --- a/fvsOL/R/mkInputElements.R +++ b/fvsOL/R/mkInputElements.R @@ -434,6 +434,7 @@ mkVarList <- function (globals) "BCanCov: Before thin percent canopy cover (StrClass keyword required)"="BCanCov", "BCCF: Before thin CCF"="BCCF", "BDBHwtBA: Before thin average DBH weighted by stand basal area"="BDBHwtBA", + "BHTWTBA: Before thin average height weighted by stand basal area"="BHTWTBA", "BMaxHS: Before thin height of tallest tree in uppermost stratum (StrClass keyword required)"="BMaxHS", "BMCuFt: Before thin merchantable (western variants) sawtimber (eastern variants) cubic foot volume"="BMCuFt", "BMinHS: Before thin height of shortest tree in uppermost stratum (StrClass keyword required)"="BMinHS", @@ -478,7 +479,8 @@ mkVarList <- function (globals) "ABdFt: After thin board foot (western variants) sawtimber (eastern variants) volume"="ABdFt", "ACanCov: After thin percent canopy cover (StrClass keyword required)"="ACanCov", "ACCF: After thin CCF"="ACCF", - "ADBHwtBA: After thin average DBH weighted by stand basal area"="ADBHwtBA", + "ADBHwtBA: After thin average DBH weighted by stand basal area"="ADBHwtBA", + "AHTWTBA: After thin average height weighted by stand basal area"="AHTWTBA", "AMaxHS: After thin height of tallest tree in uppermost stratum (StrClass keyword required)"="AMaxHS", "AMCuFt: After thin merchantable (western variants) sawtimber (eastern variants) cubic foot volume"="AMCuFt", "AMinHS: After thin height of shortest tree in uppermost stratum (StrClass keyword required)"="AMinHS", diff --git a/fvsOL/R/server.R b/fvsOL/R/server.R index acda2b9..f1e57a0 100644 --- a/fvsOL/R/server.R +++ b/fvsOL/R/server.R @@ -136,7 +136,7 @@ trim <- function (x) gsub("^\\s+|\\s+$","",x) defaultRun <- list("Default useful for all FVS variants"="fvsRun") -## used in Tools, dlZipSet +# used in Tools, dlZipSet zipList <- list( "FVSProject data base (Runs, Custom components (kcp), Custom queries, GraphSettings)" = "fvsProjdb", "Output data base for for all runs" = "outdb", @@ -410,6 +410,26 @@ cat ("exit now\n") } }) + ## changeind + observe({ + cat ("changeind=",globals$changeind,"\n") + if (globals$changeind == 0){ + output$contChange <- renderUI("Run") + output$srtYr <-renderUI({ + HTML(paste0("",input$startyr,"")) + }) + output$eYr <-renderUI({ + HTML(paste0("",input$endyr,"")) + }) + output$cyLen <-renderUI({ + HTML(paste0("",input$cyclelen,"")) + }) + output$cyAt <-renderUI({ + HTML(paste0("",input$cycleat,"")) + }) + } + }) + ## Load observe({ if (input$topPan == "View Outputs" && input$leftPan == "Load") @@ -536,8 +556,7 @@ cat ("tb=",tb," cnt=",cnt,"\n") setProgress(value = NULL) return() } - isolate(dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh)) - input$bldstdsk # force this section to be reactive to changing "bldstdsk" + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) if (!isMetric) { if ("FVS_Summary" %in% tbs && ncases > 1) @@ -788,24 +807,71 @@ cat ("tbs7=",tbs,"\n") } }) - ## changeind - observe({ - cat ("changeind=",globals$changeind,"\n") - if (globals$changeind == 0){ - output$contChange <- renderUI("Run") - output$srtYr <-renderUI({ - HTML(paste0("",input$startyr,"")) - }) - output$eYr <-renderUI({ - HTML(paste0("",input$endyr,"")) - }) - output$cyLen <-renderUI({ - HTML(paste0("",input$cyclelen,"")) - }) - output$cyAt <-renderUI({ - HTML(paste0("",input$cycleat,"")) - }) - } + ## bldstdsk + observeEvent(input$bldstdsk,{ + tbs <- myListTables(dbGlb$dbOcon) +cat ("tbs related to the run",tbs,"\n") + if (length(tbs) == 0) + { + updateSelectInput(session, "selectdbtables", choices=list()) + return() + } + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) + tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) + if (any(tlprocs)) + { + tlprocs = names(tlprocs)[tlprocs] + chtoEast = function(cmd) + { + cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) + cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) + cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) + gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) + } + for (tlp in tlprocs) + { + if (tlp == "tlwest") + { + C_StdStkDBHSp = Create_StdStkDBHSp + C_HrvStdStk = Create_HrvStdStk + C_StdStk1Hrv = Create_StdStk1Hrv + C_StdStk1NoHrv = Create_StdStk1NoHrv + C_StdStkFinal = Create_StdStkFinal + C_CmpStdStk = Create_CmpStdStk + detail = "Building StdStk from tree lists" + stdstk = "StdStk" + clname = "FVS_CutList" + } else { + C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) + C_HrvStdStk = chtoEast(Create_HrvStdStk ) + C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) + C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) + C_StdStkFinal = chtoEast(Create_StdStkFinal ) + C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) + C_CmpStdStk = chtoEast(Create_CmpStdStk ) + C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) + C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) + detail = "Building StdStk_East from tree lists" + stdstk = "StdStk_East" + clname = "FVS_CutList_East" + } + exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + if (clname %in% tbs) + { + exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } else { + exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } + exqury(dbGlb$dbOcon,C_StdStkFinal) + ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] + if (ncases > 1) exqury(dbGlb$dbOcon,C_CmpStdStk) + } + } }) ## selectdbtables @@ -1067,8 +1133,9 @@ cat ("sqlSel input$sqlSel=",input$sqlSel," isnull=", if (!is.null(input$sqlSel)) { sel = as.numeric(input$sqlSel) + if(is.na(sel)) sel = as.numeric(match(input$sqlSel,names(globals$customQueries))) cat ("sqlSel sel=",sel,"\n") - if (length(globals$customQueries) >= sel) + if (length(globals$customQueries) >= sel || !is.null(sel)) { updateTextInput(session=session, inputId="sqlTitle", value=names(globals$customQueries)[sel]) @@ -1501,7 +1568,7 @@ cat("filterRows and/or pivot\n") output$table <- renderTable(dat) }) - ## Graphs + ##Graphs observe({ if (input$leftPan == "Explore" && input$outputRightPan == "Graphs") { @@ -1875,10 +1942,11 @@ cat ("vf test hit, nlevels(dat[,vf])=",nlevels(dat[,vf]),"\n") nlv = 1 + (!is.null(pb)) + (!is.null(vf)) + (!is.null(hf)) vars = c(input$xaxis, vf, hf, pb, input$yaxis) nd = NULL - sumOnSpecies = !"Species" %in% vars && "Species" %in% names(dat) && - nlevels(dat$Species)>1 - sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && - nlevels(dat$DBHClass)>1 + specOpts <- c("Species","SpeciesFVS","SpeciesPLANTS","SpeciesFIA") + sumOnSpecies= (all(!specOpts %in% vars) && any(specOpts %in% names(dat)) && + nlevels(dat$Species)>1) + sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && + nlevels(dat$DBHClass)>1 for (v in vars[(nlv+1):length(vars)]) { if (is.na(v) || !v %in% names(dat)) return(nullPlot()) @@ -1899,7 +1967,7 @@ cat("sumOnSpecies=",sumOnSpecies," sumOnDBHClass=",sumOnDBHClass,"\n") nd=subset(nd,DBHClass!="All") nd$DBHClass="Sum" } - if (sumOnSpecies||sumOnDBHClass) + if (sumOnSpecies || sumOnDBHClass) { nd=ddply(nd,setdiff(names(nd),"Y"),.fun=function (x) sum(x$Y)) names(nd)[ncol(nd)]="Y" @@ -2301,7 +2369,6 @@ cat ("Stands\n") cat ("inTabs\n") }) - ## inVars has changed observe({ if (is.null(input$inVars)) return() @@ -2318,8 +2385,10 @@ cat ("inVars globals$activeVariants=",globals$activeVariants, cat ("in reloadStandSelection\n") if (is.null(input$inTabs) || is.null(input$inVars)) return() sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) "StandPlot_ID" else "Stand_ID" - grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups from ",input$inTabs, + grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups, INV_YEAR from ",input$inTabs, ' where lower(variant) like "%',tolower(input$inVars),'%"'))) + grps <- subset(grps, !is.na(grps[grep("inv_year",tolower(names(grps)))])) + grps <- subset(grps, grps[grep("inv_year",tolower(names(grps)))] !="") if (class(grps) == "try-error" || is.null(grps) || nrow(grps) == 0) { dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") @@ -3748,7 +3817,7 @@ cat ("in buildKeywords, oReopn=",oReopn," kwPname=",kwPname,"\n") ans } ## Save in run - observe({ + observe({ if (length(input$cmdSaveInRun) && input$cmdSaveInRun == 0) return() isolate ({ if (identical(globals$currentEditCmp,globals$NULLfvsCmp) && @@ -3828,7 +3897,7 @@ cat ("Editing as freeform\n") } } cat ("Building a component: kwPname=",kwPname,"\n") - ans = if (kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), + ans = if (length(kwPname)==1 && kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), reopn=NULL,kwds=input$freeEdit) else buildKeywords(oReopn,pkeys, kwPname,globals) gensps <- grep("SpGroup", ans$kwds) if(length(gensps)) @@ -3944,26 +4013,6 @@ cat ("saving, kwds=",ans$kwds," title=",input$cmdTitle," reopn=",ans$reopn,"\n") globals$schedBoxPkey <- character(0) }) }) - - ## changeind - observe({ -cat ("changeind=",globals$changeind,"\n") - if (globals$changeind == 0){ - output$contChange <- renderUI("Run") - output$srtYr <-renderUI({ - HTML(paste0("",input$startyr,"")) - }) - output$eYr <-renderUI({ - HTML(paste0("",input$endyr,"")) - }) - output$cyLen <-renderUI({ - HTML(paste0("",input$cyclelen,"")) - }) - output$cyAt <-renderUI({ - HTML(paste0("",input$cycleat,"")) - }) - } - }) ## time--start year observe({ @@ -4766,6 +4815,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") if(length(globals$customCmps)==1){ customCmps=NULL removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() updateSelectInput(session=session, inputId="kcpSel", choices=list()) updateTextInput(session=session, inputId="kcpTitle", value="") updateTextInput(session=session, inputId="kcpEdit", value="") @@ -4786,6 +4836,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") } else { customCmps=NULL removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() updateSelectInput(session=session, inputId="kcpSel", choices=list()) updateTextInput(session=session, inputId="kcpTitle", value="") updateTextInput(session=session, inputId="kcpEdit", value="") @@ -4796,7 +4847,7 @@ cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") ## Download KCP output$kcpDownload <- downloadHandler(filename=function () - paste0(input$kcpSel,".kcp"), + paste0(input$kcpTitle,".kcp"), content=function (tf = tempfile()) { write(input$kcpEdit,tf) @@ -5310,7 +5361,7 @@ cat ("mapDsRunList input$mapDsTable=",isolate(input$mapDsTable), cat ("length(uidsToGet)=",length(uidsToGet),"\n") if (!length(uidsToGet)) return() uidsFound = NULL - library(rgdal) + library(sf) spatdat = "SpatialData.RData" if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && file.exists(spatdat)) load(spatdat,envir=dbGlb) @@ -5332,16 +5383,21 @@ cat ("1 matchVar=",matchVar,"\n") if (!length(uidsToGet)) break matchVar = attr(map,"MatchesStandID") cat ("2 matchVar=",matchVar,"\n") - uids=intersect(uidsToGet, map@data[,matchVar]) + # if the map has class sp, it needs to be converted. This code was added in Nov 2022 + # and can be removed once all the map data is converted to package sf. Note that + # this code allows for some members of the SpatialData to be sf and others sp. + qsp = attr(class(map),"package") + if (!is.null(qsp) && qsp == "sp") map=st_as_sf(map) + uids=intersect(uidsToGet, map[[matchVar]]) if (length(uids) == 0) next uidsFound = c(uidsFound,uids) - pp = spTransform(map[match(uids,map@data[,matchVar]),],CRS("+init=epsg:4326")) - if (class(pp)=="SpatialPolygonsDataFrame") + pp = st_transform(map[match(uids,map[[matchVar]]),],st_crs("epsg:4326")) + if (length(grep("POLYGON",st_geometry_type(pp)[1]))) { polys = if (is.null(polys)) pp else rbind(polys,pp) polyLbs= if (is.null(polyLbs)) uids else rbind(polyLbs,uids) } - if (class(pp)=="SpatialPointsDataFrame") + if (length(grep("POINT",st_geometry_type(pp)[1]))) { pts = if (is.null(pts)) pp else rbind(pts,pp) ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) @@ -5440,19 +5496,15 @@ cat ("rows to keep=",length(keep),"\n") } uids = latLng[,"Stand_ID"] uidsFound = c(uidsFound,uids) - coordinates(latLng) <- ~Longitude+Latitude - setProj <- function (obj) - { - proj4string(obj) <- CRS("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs") - obj - } - latLng <- try(setProj(latLng)) - if (class(latLng)=="try-error") + latLng = st_as_sf(latLng, coords = c("Longitude","Latitude")) + latLng <- try(st_set_crs(latLng, + st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))) + if ("try-error" %in% class(latLng)) { output$leafletMessage=renderText("Error setting projection in location data.") return() } - pp = spTransform(latLng,CRS("+init=epsg:4326")) + pp = st_transform(latLng,st_crs("epsg:4326")) pts= if (is.null(pts)) pp else rbind(pts,pp) ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) } @@ -7559,7 +7611,7 @@ cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) rownames(dbGlb$tbl) = dbGlb$tbl$rowid for (col in 2:ncol(dbGlb$tbl)) - if (class(dbGlb$tbl[[col]]) != "character") + if (class(dbGlb$tbl[[col]])[1] != "character") dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else { @@ -7587,6 +7639,7 @@ cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), message = "Are you sure you want to delete all rows from this database table?")) } }) + observe({ if(input$clearTableDlgBtn == 0) return() cat ("clearTable, tbl=",dbGlb$tblName,"\n") @@ -7617,47 +7670,10 @@ cat ("clearTable, tbl=",dbGlb$tblName,"\n") if(input$inputDBPan == "Upload Map data") { cat ("Map data hit.\n") - require(rgdal) - progress <- shiny::Progress$new(session,min=1,max=3) - progress$set(message = "Preparing projection library",value = 2) - updateSelectInput(session=session, inputId="mapUpIDMatch",choices=list()) - if (!exists("prjs",envir=dbGlb,inherit=FALSE)) - { - dbGlb$prjs = make_EPSG() - delList = c("Unknown","deprecated","Unable to","Unspecified","Paris","China", - "Oslo","NZGD","Kalianpur","Hartebeesth","ELD79","Sierra Le","Locodjo","ETRS89", - "Xian 1980","Italy","GDM2000","KKJ ","Karbala","North Pole","LGD2006","JAD2","GDA94", - "HTRS96","Bermuda","Pitcairn","Cuba ","Kertau","Portug","Brunei","Jakarta","Abidjan", - "Chile","Russia","Japan","Israel","Nahrwan","Fiji","Viti L","PRS92","MAGNA-","Banglade", - "Minna","poraloko","Sahara","Zanderij","MGI","Ain el","Afgooye","Barbados","Carthage", - "Luzon","Maroc","Massawa","Schwarzeck","Tanana","Timbalai","OSNI","Irish","Trinidad", - "Voirol","Yoff","Belge ","Tokyo","British","Amersfoort","Lao ","Yemen ","Brazil", - "Indian","Indonesia","Garoua","Fahud","Egypt","Deir ez","Corrego","Cape /","Hong Kong", - "Bogota","Camacupa","Beijing","Batavia","Aratu","Adindan","Pulkovo","Lisbon","Hanoi", - "Macedonia","Cayman","Arctic","Europe","Krovak","Panama","Sibun G","Ocotepeque", - "Peru","DRUKREF","TUREF","Korea","Spain","Congo","Katanga","Manoca","LKS9","Tahiti", - "Argentina","Iraq","Slovenia","Naparima","Mauritania","Maupiti","Martinique","Estonian", - "Qatar","Doulas","Easter","Qornoq","Rassad","Miquelon","Segara","Tahhaa","Singapore") - dbGlb$prjs <- dbGlb$prjs[!is.na(dbGlb$prjs[,3]),] - for (del in delList) - { - tod = grep(del,dbGlb$prjs[,2],ignore.case=TRUE) -# cat ("del=",del," len=",length(tod)," nrow=",nrow(dbGlb$prjs),"\n") - if (length(tod)) dbGlb$prjs = dbGlb$prjs[-tod,] - } - } - dbGlb$prjs = dbGlb$prjs[order(dbGlb$prjs[,2]),] - grp = c(grep ("NAD",dbGlb$prjs[,2],fixed=TRUE),grep("WGS",dbGlb$prjs[,2],fixed=TRUE)) - dbGlb$prjs = rbind(dbGlb$prjs[grp,],dbGlb$prjs[-grp,]) + library(sf) updateSelectInput(session=session, inputId="mapUpLayers", choices=list(), selected=0) - epsg = as.character(1:nrow(dbGlb$prjs)) - names(epsg) = paste0("epsg:",dbGlb$prjs$code," ",dbGlb$prjs$note) - updateSelectInput(session=session, inputId="mapUpSelectEPSG", choices=epsg, - selected=0) - updateTextInput(session=session, inputId="mapUpProjection",value="") output$mapActionMsg = renderText(" ") - progress$close() } }) ## mapUpload @@ -7691,18 +7707,16 @@ cat ("mapUpload, filename=",input$mapUpload$datapath," ending=",fileEnding,"\n") progress$set(message = "Getting layers",value = 2) if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) setwd(mapDir) - lyrs = try(ogrListLayers(dir(mapDir))) + lyrs = try(sf::st_layers(dir(mapDir))) setwd(curdir) cat ("mapUpload, class(lyrs)=",class(lyrs),"\n") - if (class(lyrs) == "try-error" || length(lyrs) == 0) + if ("try-error" %in% class(lyrs) || length(lyrs$name)==0) { output$mapActionMsg = renderText("Can not find layers in data") progress$close() return() } - attributes(lyrs) = NULL - lyrs = as.list(lyrs) - names(lyrs) = unlist(lyrs) + lyrs = as.list(lyrs$name) if (length(lyrs) > 1) { lyr = grep ("poly",names(lyrs),ignore.case=TRUE) @@ -7729,38 +7743,33 @@ cat ("input$mapUpLayers =",input$mapUpLayers,"\n") if (length(dir(datadir)) == 1) setwd(datadir) progress <- shiny::Progress$new(session,min=1,max=3) progress$set(message = paste0("Loading map: ",datadir," Layer: ",input$mapUpLayers),value=2) - txtoutput = capture.output(dbGlb$spd <- try(readOGR(dir(),input$mapUpLayers, - drop_unsupported_fields=TRUE))) + txtoutput = capture.output(dbGlb$spd <- try(st_read(dir(),input$mapUpLayers))) setwd(curdir) - if (class(dbGlb$spd) == "try-error") + if ("try-error" %in% class(dbGlb$spd)) { output$mapActionMsg = renderText(paste0("Map read error: ",dbGlb$spd)) progress$close() setwd(curdir) return() } - for (col in colnames(dbGlb$spd@data)) - { - if (is.factor(dbGlb$spd@data[,col])) - dbGlb$spd@data[,col]=levels(dbGlb$spd@data[,col])[as.numeric(dbGlb$spd@data[,col])] - } txtoutput = paste0(txtoutput,collapse="\n") output$mapActionMsg = renderText(txtoutput) progress$set(message = txtoutput,value=3) - choices = as.list(names(dbGlb$spd@data)) - names(choices) = choices stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") ids = try(dbGetQuery(dbGlb$dbIcon,paste0('select Stand_ID from ',stdInit))) cat ("length(ids)=",length(ids),"\n") - if (class(ids) == "try-error" || nrow(ids) == 0) + choices = setdiff(names(dbGlb$spd),"geometry") + names(choices) = choices + if ("try-error" %in% class(ids) || nrow(ids) == 0) { - selected = grep("ID",names(dbGlb$spd@data),ignore.case=TRUE)[1] - selected = if (is.na(selected)) 0 else names(dbGlb$spd@data)[selected] + selected = grep("ID",choices,ignore.case=TRUE)[1] + if (is.na(selected)) selected=0 } else { ids = unlist(ids) + names(ids) = NULL cnts = NULL - for (col in colnames(dbGlb$spd@data)) - cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd@data[,col])))) + for (col in choices) + cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd[,col][[col]])))) cnts = cnts/length(ids)*100 choices = paste0(choices," ",format(cnts,digits=3),"%") selected = choices[which.max(cnts)] @@ -7768,48 +7777,9 @@ cat ("length(ids)=",length(ids),"\n") cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected=",selected,"\n") updateSelectInput(session=session, inputId="mapUpIDMatch", choices=choices,selected=selected) - prj = proj4string(dbGlb$spd) - if (!is.na(prj)) - { - updateTextInput(session=session, inputId="mapUpProjection",value=prj) - i = grep (prj,dbGlb$prjs$prj4,fixed=TRUE) - if(length(i) && !is.na(i)) - updateSelectInput(session=session, inputId="mapUpSelectEPSG",selected=i) - } progress$close() }) - ## mapUpSelectEPSG - observe({ - if(length(input$mapUpSelectEPSG)) - updateTextInput(session=session, inputId="mapUpProjection", - value=dbGlb$prjs[as.numeric(input$mapUpSelectEPSG),"prj4"]) - }) - ## mapUpSetPrj - observe({ - if(input$mapUpSetPrj > 0) - { - if (!exists("spd",envir=dbGlb,inherit=FALSE)) - { - output$mapActionMsg = renderText("No map, upload one then set projection") - return() - } - prjstring = trim(isolate(input$mapUpProjection)) - if (nchar(prjstring) == 0) - { - output$mapActionMsg = renderText("proj4 string is empty") - return() - } - prj = try(CRS(prjstring)) - if (class(prj) == "try-error") - { - output$mapActionMsg = renderText("proj4 string is not valid") - } else { - proj4string(dbGlb$spd) = prjstring - output$mapActionMsg = renderText("proj4 set/reset") - } - } - }) - ## prepSpatialData + prepSpatialData = function(dbGlb) { if (!exists("spd",envir=dbGlb,inherit=FALSE)) return(NULL) @@ -7817,18 +7787,22 @@ cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected ids1 = try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct Stand_ID from ',stdInit))) ids1 = if (class(ids1)=="try-error") list() else unlist(ids1) names(ids1) = NULL - ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) - ids2 = if (class(ids2)=="try-error") list() else unlist(ids2) - names(ids2) = NULL - keep=union(ids1,ids2) + if ("FVS_Cases" %in% + dbGetQuery(dbGlb$dbOcon,"SELECT * FROM sqlite_master where type='table'")$name) + { + ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) + ids2 = if ("try-error" %in% class(ids2)) list() else unlist(ids2) + names(ids2) = NULL + keep=union(ids1,ids2) + } else keep=ids1 matID = unlist(strsplit(input$mapUpIDMatch," "))[1] - keep=na.omit(charmatch(keep,dbGlb$spd@data[,matID])) + keep=na.omit(charmatch(keep,dbGlb$spd[,matID][[matID]])) if (length(keep)) { SpatialData=dbGlb$spd[keep,] attr(SpatialData,"MatchesStandID") = matID output$mapActionMsg = renderText(paste0("Map saved for this project, StandID match=", - matID,", Number of objects kept=",nrow(SpatialData@data))) + matID,", Number of objects kept=",nrow(SpatialData))) } else { SpatialData=NULL output$mapActionMsg = renderText("No map or data to save.") @@ -8112,15 +8086,17 @@ cat("unload zip had ",length(uz),"items. ml[[2]]=",ml[[2]],"\n") } else{ customQueries = list() newtitle = mkNameUnique(curTitle,customQueries) - } + } + globals$customQueries[newtitle]= source[curTitle] customQueries[newtitle] = source[curTitle] storeOrUpdateObject(dbGlb$prjDB,customQueries) output$impCustomQueriesMsg = renderText(paste0('Query "',curTitle,'" imported and ', ' is named "',newtitle,'" in your current project.')) updateSelectInput(session=session,inputId="sqlSel",choices=as.list(names(customQueries)), - selected=names(customQueries)[1]) + selected="") })} }) + ## impFVS_Data observe({ if (input$impFVS_Data > 0) diff --git a/fvsOL/R/ui.R b/fvsOL/R/ui.R index 4e62ce2..9271b80 100644 --- a/fvsOL/R/ui.R +++ b/fvsOL/R/ui.R @@ -672,18 +672,14 @@ FVSOnlineUI <- fixedPage( ), tabPanel("Upload Map data", h4('Upload a stand layer to use in the "View On Maps" feature.'), - h5("Note: Only spatial data found to have corresponding inventory data are stored (so load it first)."), + h5("Note: Only spatial data found to have corresponding inventory data are stored (so load your inventory data first)."), fileInput("mapUpload","Step 1: Upload polygon or point data (.zip that contains spatial data)", width="90%"), h6(), selectInput("mapUpLayers", label="Layer", choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), selectInput("mapUpIDMatch", label="Variable that matches StandID", choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), - selectInput("mapUpSelectEPSG", label="Projection library (abridged)", - choices = list(), selected = NULL, multiple = FALSE, selectize=FALSE), - textInput("mapUpProjection", label="proj4 projection string",width="70%"), - actionButton("mapUpSetPrj","Set/Reset proj4 projection (does not reproject uploaded data)"),h6(), - p(strong("Step 2: Do one of the following:")), + p(strong("Step 2: Do one of the following:")), tags$style(type="text/css","#mapUpSave{font-size: 120%; color:green;}"), tags$style(type="text/css","#mapUpAdd{font-size: 120%; color:green;}"), actionButton("mapUpSave","Install imported spatial data"), diff --git a/fvsOL/R/writeKeyFile.R b/fvsOL/R/writeKeyFile.R index bbac7db..c448840 100644 --- a/fvsOL/R/writeKeyFile.R +++ b/fvsOL/R/writeKeyFile.R @@ -483,6 +483,7 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) for (std in globals$fvsRun$stands) { RepsDesign=FALSE + EndPrev=FALSE names(fvsInit) <- toupper(names(fvsInit)) sRows = match (std$sid, fvsInit$STAND_ID) sRowp = match (std$sid, fvsInit$STANDPLOT_ID) @@ -548,6 +549,14 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) { if(lastExt != "base") cat ("End\n",file=fc,sep="") cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE + lastCnd = NULL + } + if (cmp$atag == "c" && (cmp$uuid != lastCnd && !is.null(lastCnd))) + { + if(lastExt != "base") cat ("End\n",file=fc,sep="") + cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE lastCnd = NULL } if (cmp$atag == "c") lastCnd = cmp$uuid @@ -557,7 +566,8 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) if (lastExt != exten && lastExt != "base") { lastExt = "base" - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE } naughty <- "Econ_reports" if (lastExt != exten && !any(!is.na(match(naughty,cmp$kwdName)))) @@ -612,6 +622,7 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) cmp$kwds,"\n",file=fc,sep="") if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE } + EndPrev=FALSE } } if (length(std$cmps)) for (cmp in std$cmps) @@ -621,15 +632,24 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) { if(lastExt != "base") cat ("End\n",file=fc,sep="") cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE lastCnd = NULL } + if (cmp$atag == "c" && (cmp$uuid != lastCnd && !is.null(lastCnd))) + { + if(lastExt != "base") cat ("End\n",file=fc,sep="") + cat ("EndIf\n",file=fc,sep="") + EndPrev=TRUE + lastCnd = NULL + } if (cmp$atag == "c") lastCnd = cmp$uuid exten= if (length(grep("&",cmp$exten,fixed=TRUE))) unlist(strsplit(cmp$exten,"&"))[1] else cmp$exten if (lastExt != exten && lastExt != "base") { lastExt = "base" - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE } naughty <- "Econ_reports" if (lastExt != exten && !any(!is.na(match(naughty,cmp$kwdName)))) @@ -668,13 +688,15 @@ writeKeyFile <- function (globals,dbIcon,keyFileName=NULL,verbose=TRUE) cmp$kwds,"\n",file=fc,sep="") } if(substr(cmp$kwds,1,6) == "Design")RepsDesign=TRUE + EndPrev=FALSE } if (!is.null(lastCnd) && lastExt != "base") { - cat ("End\n",file=fc,sep="") + if(!EndPrev) cat ("End\n",file=fc,sep="") + EndPrev=TRUE lastExt = "base" } if (!is.null(lastCnd) && lastExt == "base") cat ("EndIf\n",file=fc,sep="") - if (is.null(lastCnd) && lastExt != "base") cat ("End\n",file=fc,sep="") + if (is.null(lastCnd) && lastExt != "base" && !EndPrev) cat ("End\n",file=fc,sep="") # insert modified sampling weight if needed. if (!is.null(wtofix[[std$sid]]) && !RepsDesign) { diff --git a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R index 5a9e57c..13d6435 100644 --- a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R +++ b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R @@ -1,356 +1,358 @@ - -unlink("Acadian.log") - -# Note: The form of the function call is very carefully coded. Make sure -# "runOps" exists if you want them to be used. -fvsRunAcadian <- function(runOps,logfile="Acadian.log") -{ - - if (!is.null(logfile) && !interactive()) - { - sink() - sink(logfile,append=TRUE) - } - - #load the growth model R code - rFn="AcadianGY.R" - if (file.exists(rFn)) source(rFn) else - { - rFn = system.file("extdata", rFn, package="fvsOL") - if (! file.exists(rFn)) stop("can not find and load model code") - source(rFn) - } - cat ("\nSource file for this fvsRunAcadian=\n",rFn,"\n") - cat ("*** in fvsRunAcadian",date()," AcadianVersionTag=",AcadianVersionTag,"\n") - cat ("\nrunOps=\n") - print (runOps) - - # process the ops. - INGROWTH = if (is.null(runOps$uiAcadianIngrowth)) "N" else - runOps$uiAcadianIngrowth - MinDBH = as.numeric(if (is.null(runOps$uiAcadianMinDBH)) "3.0" else - runOps$uiAcadianMinDBH) - mortModel= if (is.null(runOps$uiAcadianMort)) "Acadian" else - runOps$uiAcadianMort - CutPoint = if (is.null(runOps$uiAcadianCutPoint)) 0.95 else - as.numeric(runOps$uiAcadianCutPoin) - volLogic = if (is.null(runOps$uiAcadianVolume)) "Base Model" else - runOps$uiAcadianVolume - wThinMod = if (is.null(runOps$uiAcadianTHIN)) FALSE else - runOps$uiAcadianTHIN == "Yes" - CDEF = if (is.null(runOps$uiAcadianSBWCDEF)) NA else - as.numeric(runOps$uiAcadianSBWCDEF) - SBW.YR = if (is.null(runOps$uiAcadianSBW.YR)) NA else - as.numeric(runOps$uiAcadianSBW.YR) - SBW.DUR = if (is.null(runOps$uiAcadianSBW.DUR)) NA else - as.numeric(runOps$uiAcadianSBW.DUR) - SBW = if (is.null(runOps$uiAcadianSBW)) NULL else - if (runOps$uiAcadianSBW == "No") NULL else - c(CDEF=CDEF,SBW.YR=SBW.YR,SBW.DUR=SBW.DUR) - if (!is.null(SBW) && any(is.na(SBW))) SBW=NULL - - cat ("fvsRunAcadian, options set\n") - - #load some handy conversion factors - CMtoIN = fvsUnitConversion("CMtoIN") - INtoCM = fvsUnitConversion("INtoCM") - FTtoM = fvsUnitConversion("FTtoM") - MtoFT = fvsUnitConversion("MtoFT") - M3toFT3 = fvsUnitConversion("M3toFT3") - ACRtoHA = fvsUnitConversion("ACRtoHA") - HAtoACR = fvsUnitConversion("HAtoACR") - spcodes = fvsGetSpeciesCodes() - - #initialize THINMOD - THINMOD = NULL - - incr = list() - # define the acadian height function - calc_acd_ht=function(tree=orgtree){ - tree=tree %>% - dplyr::rowwise() %>% - dplyr::mutate(mcw=mcw(sp=SP, dbh=DBH), # Max crown width - MCA=100*((pi*(mcw/2)^2)/10000)*EXPF) %>% - dplyr::group_by(PLOT) %>% - dplyr::mutate(CCF=sum(MCA)) %>% # Plot crown competition factor - dplyr::ungroup() %>% - dplyr::rowwise() %>% - dplyr::mutate(pHT= HTPred(SPP=SP, DBH=DBH, CSI=CSI, CCF=CCF, BAL=BAL), # Predicted height - HT= case_when(HT == 0 | HT>100 ~pHT, # Use predicted height where value is missing or in excess of 100 - TRUE ~ HT), - HCB= HCBPred(SPP=SP, DBH=DBH, HT=pHT,CCF=CCF, BAL=BAL)) %>% - dplyr::ungroup() %>% - dplyr::mutate(pCR= (HT-HCB)/HT, # predicted crown ratio - CR= case_when(CR == 0 ~pCR, # use predicted crown ratio where value is missing - TRUE ~ CR)) - tree - } - - # start FVS but return prior to dubbing and calibration to dub in missing - # heights and crown ratios - - fvsRun(7,0) - CSI = fvsGetEventMonitorVariables("csi") - if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM - CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) - orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio")) - names(orgtree) = toupper(names(orgtree)) - orgtree$TREE= 1:nrow(orgtree) - names(orgtree)[match("SPECIES",names(orgtree))] = "SP" - names(orgtree)[match("TPA",names(orgtree))] = "EXPF" - orgtree$SP = spcodes[orgtree$SP,1] - #change CR to a proportion and take abs; note that in FVS a negative CR - #signals that CR change has been computed by the fire or insect/disease model - orgtree$CR = abs(orgtree$CRATIO) * .01 - orgtree$ba = orgtree$DBH * orgtree$DBH * 0.005454 * orgtree$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") - orgtree$DBH = orgtree$DBH * INtoCM - orgtree$HT = orgtree$HT * FTtoM - orgtree$EXPF = orgtree$EXPF * HAtoACR - orgtree = dplyr::arrange(orgtree, PLOT, desc(DBH)) - temp = unlist(by(orgtree$ba,INDICES=orgtree$PLOT,FUN=cumsum)) - orgtree$BAL = temp-orgtree$ba - orgtree = dplyr::arrange(orgtree, TREE) - newtree = calc_acd_ht(tree=orgtree) - fvsSetTreeAttrs(list(ht =as.numeric(newtree$HT*MtoFT), - cratio=round(as.numeric(newtree$CR)*100,2))) - - cat ("Starting repeat loop\n") - - repeat - { - #stopPointCode 5 (after growth and mortality, before it is added) - #stopPointCode 6 (just before estab, place to add new trees) - - #BE CAREFULL: the next few lines control when to exit the loop and - #the details are very important. It is easy to break this code! - rtn = fvsRun(stopPointCode=5,stopPointYear=-1) - if (rtn != 0) break - stopPoint <- fvsGetRestartcode() - # end of current stand? - cat ("first stopPoint code=",stopPoint,"\n") - if (stopPoint == 100) break - - cat ("fvsRunAcadian: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=", - mortModel,"\n volLogic=",volLogic," SBW=",SBW,"\n") - - # if there are no trees, this code does not work. - # NB: room is used below, so if this rule changes, move this code - room=fvsGetDims() - if (room["ntrees"] == 0) next - - #fetch some stand level information - stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear","elev")) - stdIds = fvsGetStandIDs() - cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 - attributes(cyclen) = NULL - CSI = fvsGetEventMonitorVariables("csi") - if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM - CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) - ELEV = as.numeric(stdInfo["elev"]) * FTtoM - cat ("fvsRunAcadian: CSI=",CSI," ELEV=",ELEV,"\n") - - #set/reset THINMOD based on pre and post event monitor variables - if (wThinMod) - { - thinning = fvsGetEventMonitorVariables(c("bba","aba","badbh","aadbh","rtpa")) - if (thinning["rtpa"] > 0) - { - THINMOD = c(stdInfo["year"], - (1-(thinning["aba"]/thinning["bba"]))*100., - thinning["bba"]*fvsUnitConversion("FT2pACRtoM2pHA"), - if (thinning["aadbh"]>=1) - thinning["badbh"]/thinning["aadbh"] else NA) - names(THINMOD) = c("YEAR_CT","pBArm","BApre","QMDratio") - } else if (!is.null(THINMOD) && - stdInfo["year"]-THINMOD["YEAR_CT"] > 20) THINMOD=NULL - } - - #fetch the fvs trees and form the AcadianGY "tree" dataframe - orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special")) - names(orgtree) = toupper(names(orgtree)) - orgtree$TREE= 1:nrow(orgtree) - names(orgtree)[match("SPECIES",names(orgtree))] = "SP" - names(orgtree)[match("TPA",names(orgtree))] = "EXPF" - orgtree$SP = spcodes[orgtree$SP,1] - #change CR to a proportion and take abs; note that in FVS a negative CR - #signals that CR change has been computed by the fire or insect/disease model - orgtree$CR = abs(orgtree$CRATIO) * .01 - orgtree$DBH = orgtree$DBH * INtoCM - orgtree$HT = orgtree$HT * FTtoM - orgtree$EXPF = orgtree$EXPF * HAtoACR - - #load the form and risk class data using FVS variable ISPECL loaded using "special" - - orgtree$Form = rep(" ",nrow(orgtree)) - orgtree$Risk = rep(" ",nrow(orgtree)) - tmpset = orgtree$SPECIAL > 0 & orgtree$SPECIAL < 85 - orgtree$Form[tmpset] = paste0("F",as.integer(orgtree$SPECIAL[tmpset] %/% 10)) - orgtree$Risk[tmpset] = paste0("R",as.integer(orgtree$SPECIAL[tmpset] %% 10)) - - stand = list(CSI=CSI,ELEV=ELEV) - ops = list(verbose=TRUE,INGROWTH=INGROWTH,MinDBH=MinDBH, - CutPoint=0.5, # >0 uses threshold probability (>0-1). - mortType="continuous", #mortType="discrete", - SBW=SBW,THINMOD=THINMOD,verbose=TRUE, - rtnVars = c("PLOT","SP","DBH","EXPF","TREE","HT","HCB","Form","Risk")) - - tree=orgtree - - for (year in stdInfo["year"]:stdInfo["cendyear"]) - { - tree$YEAR = year - cat ("fvsRunAcadian: calling AcadianGY, year=",year,"\n") - treeout = try(AcadianGYOneStand(tree,stand=stand,ops=ops)) - if (class(treeout)=="try-error" || any(is.na(treeout$DBH)) || - any(is.na(treeout$HT)) || any(is.na(treeout$EXPF))) - { - cat("AcadianGYOneStand failed in year=",year,"\n") - dmpFile=file.path(getwd(),paste0("AcadianGYOneStand.Failure.",year,".RData")) - if (class(treeout)!="try-error") treeout="critical result contains NA values" - cat ("dmpFile name=",dmpFile,"\n") - save(file=dmpFile,treeout,tree,stand,ops) - tree=NULL - break - } - tree=treeout - } - # if there was a failure, tree will be NULL, go on to the next stand cycle - if (is.null(tree)) next - # put the PLOT variable back to a character string (defactor it). - if (is.factor(tree$PLOT)) tree$PLOT = levels(tree$PLOT)[as.numeric(tree$PLOT)] - # restore the order of the trees - tree = tree[order(tree$TREE),] - - cat ("fvsRunAcadian: is.null(tree$dEXPF)=",is.null(tree$dEXPF),"\n") - cat ("fvsRunAcadian: cyclen=",cyclen,"sum1 EXPF=",sum(tree$EXPF), - " sum dEXPF=",if (is.null(tree$dEXPF)) NA else sum(tree$dEXPF),"\n") - - names(tree)[match("TPA",names(tree))] = "EXPF" - - tree$CR = round((1-(tree$HCB/tree$HT))*100,1) - tofvs = data.frame(id=orgtree$TREE, - dg=(tree$DBH[orgtree$TREE]-orgtree$DBH)*CMtoIN, - htg=(tree$HT[orgtree$TREE]-orgtree$HT)*MtoFT, - # set the crown ratio sign to negetive so that FVS - # doesn't change them. if already negetive, don't change them. - cratio=ifelse(orgtree$CRATIO < 0, orgtree$CRATIO, - -tree$CR[orgtree$TREE])) - special=as.numeric(substr(tree$Form[orgtree$TREE],2,2))*10+ - as.numeric(substr(tree$Risk[orgtree$TREE],2,2)) - - if (mortModel == "Acadian") tofvs$mort=(orgtree$EXPF- - tree$EXPF[orgtree$TREE])*ACRtoHA - fvsSetTreeAttrs(tofvs) - - atstop6 = FALSE - - # adding regeneration? - newTrees = nrow(tree) - nrow(orgtree) - cat ("fvsRunAcadian: num newtrees=",newTrees,"\n") - if (newTrees) - { - if (newTrees < room["maxtrees"] - room["ntrees"]) - { - newTrees = (nrow(orgtree)+1):nrow(tree) - toadd = data.frame(dbh =tree$DBH[newTrees]*CMtoIN, - species=match(tree$SP[newTrees],spcodes[,"fvs"]), - ht =tree$HT[newTrees]*MtoFT, - cratio =-tree$CR[newTrees], - plot =as.numeric(tree$PLOT[newTrees]), - tpa =tree$EXPF[newTrees]*ACRtoHA) - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - fvsAddTrees(toadd) - } else cat ("fvsRunAcadian: Not enough room for",newTrees, - "new trees. Stand=",fvsGetStandIDs()["standid"],"; Year=", - stdInfo["year"],"\n") - } - - # modifying volume? - if (volLogic == "Acadian") - { - cat ("fvsRunAcadian: Applying Acadian volume logic\n") - - mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) - vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) - vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], - mapply(KozakTreeVol,Bark="ob",Planted=0, - DBH=vols$dbh * INtoCM, - HT =vols$ht * FTtoM, - SPP=spcodes[vols$species,1], - stump=mcstds$mcstmp[vols$species] * FTtoM, - topD =mcstds$mctopd[vols$species] * INtoCM), 0) - - if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * - (1-(((vols$defect %% 10000) %/% 100) * .01)) - vols$mcuft = vols$mcuft * M3toFT3 - vols$species=NULL - vols$ht =NULL - vols$dbh =NULL - vols$defect =NULL - if (!atstop6) - { - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - } - fvsSetTreeAttrs(vols) - } - } - cat ("rtn=",rtn,"\n") - rtn -} - -# NOTE: I (NLCrookston) tried various ways of building these elements. Setting the -# initial value to the saved value when the elements are created seems to work well. -# What did not work was setting the initial value to some default and then -# changing it using an update call in the server code. - -uiAcadian <- function(fvsRun) -{ -cat ("in uiAcadian uiAcadianVolume=", - if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) "NULL" else - fvsRun$uiCustomRunOps$uiAcadianVolume,"\n") - - if (is.null(fvsRun$uiCustomRunOps$uiAcadianIngrowth)) - fvsRun$uiCustomRunOps$uiAcadianIngrowth = "No" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianMinDBH)) - fvsRun$uiCustomRunOps$uiAcadianMinDBH = "3.0" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianMort)) - fvsRun$uiCustomRunOps$uiAcadianMort = "Acadian" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianCutPoint)) - fvsRun$uiCustomRunOps$uiAcadianCutPoint = "0.95" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) - fvsRun$uiCustomRunOps$uiAcadianVolume = "Acadian" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianTHIN)) - fvsRun$uiCustomRunOps$uiAcadianTHIN = "Yes" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW)) - fvsRun$uiCustomRunOps$uiAcadianSBW = "No" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBWCDEF)) - fvsRun$uiCustomRunOps$uiAcadianSBWCDEF = "100" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.YR)) - fvsRun$uiCustomRunOps$uiAcadianSBW.YR = "2020" - if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.DUR)) - fvsRun$uiCustomRunOps$uiAcadianSBW.DUR = "10" - list( - myRadioGroup("uiAcadianIngrowth", "Simulate ingrowth:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianIngrowth), - myInlineTextInput("uiAcadianMinDBH","Minimum DBH for ingrowth", - fvsRun$uiCustomRunOps$uiAcadianMinDBH), - myRadioGroup("uiAcadianMort", "Mortality model:", - c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianMort), - myInlineTextInput("uiAcadianCutPoint","CutPoint", - fvsRun$uiCustomRunOps$uiAcadianCutPoint), - myRadioGroup("uiAcadianVolume", "Merchantable volume logic:", - c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianVolume), - myRadioGroup("uiAcadianTHIN", "Run with thinning modifiers:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianTHIN), - myRadioGroup("uiAcadianSBW", "Run with Spruce Budworm modifiers:", - c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianSBW), - myInlineTextInput("uiAcadianSBWCDEF","Cumulative defoliation:", - fvsRun$uiCustomRunOps$uiAcadianSBWCDEF), - myInlineTextInput("uiAcadianSBW.YR","Defoliation start year:", - fvsRun$uiCustomRunOps$uiAcadianSBW.YR), - myInlineTextInput("uiAcadianSBW.DUR","Defoliation duration (years):", - fvsRun$uiCustomRunOps$uiAcadianSBW.DUR) - ) -} + +unlink("Acadian.log") + +# Note: The form of the function call is very carefully coded. Make sure +# "runOps" exists if you want them to be used. +fvsRunAcadian <- function(runOps,logfile="Acadian.log") +{ + + if (!is.null(logfile) && !interactive()) + { + sink() + sink(logfile,append=TRUE) + } + + #load the growth model R code + rFn="AcadianGY.R" + if (file.exists(rFn)) source(rFn) else + { + rFn = system.file("extdata", rFn, package="fvsOL") + if (! file.exists(rFn)) stop("can not find and load model code") + source(rFn) + } + cat ("\nSource file for this fvsRunAcadian=\n",rFn,"\n") + cat ("*** in fvsRunAcadian",date()," AcadianVersionTag=",AcadianVersionTag,"\n") + cat ("\nrunOps=\n") + print (runOps) + + # process the ops. + INGROWTH = if (is.null(runOps$uiAcadianIngrowth)) "N" else + runOps$uiAcadianIngrowth + MinDBH = as.numeric(if (is.null(runOps$uiAcadianMinDBH)) "3.0" else + runOps$uiAcadianMinDBH) + mortModel= if (is.null(runOps$uiAcadianMort)) "Acadian" else + runOps$uiAcadianMort + CutPoint = if (is.null(runOps$uiAcadianCutPoint)) 0.95 else + as.numeric(runOps$uiAcadianCutPoin) + volLogic = if (is.null(runOps$uiAcadianVolume)) "Base Model" else + runOps$uiAcadianVolume + wThinMod = if (is.null(runOps$uiAcadianTHIN)) FALSE else + runOps$uiAcadianTHIN == "Yes" + CDEF = if (is.null(runOps$uiAcadianSBWCDEF)) NA else + as.numeric(runOps$uiAcadianSBWCDEF) + SBW.YR = if (is.null(runOps$uiAcadianSBW.YR)) NA else + as.numeric(runOps$uiAcadianSBW.YR) + SBW.DUR = if (is.null(runOps$uiAcadianSBW.DUR)) NA else + as.numeric(runOps$uiAcadianSBW.DUR) + SBW = if (is.null(runOps$uiAcadianSBW)) NULL else + if (runOps$uiAcadianSBW == "No") NULL else + c(CDEF=CDEF,SBW.YR=SBW.YR,SBW.DUR=SBW.DUR) + if (!is.null(SBW) && any(is.na(SBW))) SBW=NULL + + cat ("fvsRunAcadian, options set\n") + + #load some handy conversion factors + CMtoIN = fvsUnitConversion("CMtoIN") + INtoCM = fvsUnitConversion("INtoCM") + FTtoM = fvsUnitConversion("FTtoM") + MtoFT = fvsUnitConversion("MtoFT") + M3toFT3 = fvsUnitConversion("M3toFT3") + ACRtoHA = fvsUnitConversion("ACRtoHA") + HAtoACR = fvsUnitConversion("HAtoACR") + spcodes = fvsGetSpeciesCodes() + + #initialize THINMOD + THINMOD = NULL + + incr = list() + # define the acadian height function + calc_acd_ht=function(tree=orgtree){ + tree=tree %>% + dplyr::rowwise() %>% + dplyr::mutate(mcw=mcw(sp=SP, dbh=DBH), # Max crown width + MCA=100*((pi*(mcw/2)^2)/10000)*EXPF) %>% + dplyr::group_by(PLOT) %>% + dplyr::mutate(CCF=sum(MCA)) %>% # Plot crown competition factor + dplyr::ungroup() %>% + dplyr::rowwise() %>% + dplyr::mutate(pHT= HTPred(SPP=SP, DBH=DBH, CSI=CSI, CCF=CCF, BAL=BAL), # Predicted height + HT= case_when(HT == 0 | HT>100 ~pHT, # Use predicted height where value is missing or in excess of 100 + TRUE ~ HT), + HCB= HCBPred(SPP=SP, DBH=DBH, HT=pHT,CCF=CCF, BAL=BAL)) %>% + dplyr::ungroup() %>% + dplyr::mutate(pCR= (HT-HCB)/HT, # predicted crown ratio + CR= case_when(CR == 0 ~pCR, # use predicted crown ratio where value is missing + TRUE ~ CR)) + tree + } + + # start FVS but return prior to dubbing and calibration to dub in missing + # heights and crown ratios +# This code is commented out because at stoppoint 7, +# fvsGetEventMonitorVariables("csi") does not yet return the csi. +# fvsRun(7,0) +# CSI = fvsGetEventMonitorVariables("csi") +# cat("stoppoint 7,CSI=",CSI,"\n") +# if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM +# CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) +# orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio")) +# names(orgtree) = toupper(names(orgtree)) +# orgtree$TREE= 1:nrow(orgtree) +# names(orgtree)[match("SPECIES",names(orgtree))] = "SP" +# names(orgtree)[match("TPA",names(orgtree))] = "EXPF" +# orgtree$SP = spcodes[orgtree$SP,1] +# #change CR to a proportion and take abs; note that in FVS a negative CR +# #signals that CR change has been computed by the fire or insect/disease model +# orgtree$CR = abs(orgtree$CRATIO) * .01 +# orgtree$ba = orgtree$DBH * orgtree$DBH * 0.005454 * orgtree$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") +# orgtree$DBH = orgtree$DBH * INtoCM +# orgtree$HT = orgtree$HT * FTtoM +# orgtree$EXPF = orgtree$EXPF * HAtoACR +# orgtree = dplyr::arrange(orgtree, PLOT, desc(DBH)) +# temp = unlist(by(orgtree$ba,INDICES=orgtree$PLOT,FUN=cumsum)) +# orgtree$BAL = temp-orgtree$ba +# orgtree = dplyr::arrange(orgtree, TREE) +# newtree = calc_acd_ht(tree=orgtree) +# fvsSetTreeAttrs(list(ht =as.numeric(newtree$HT*MtoFT), +# cratio=round(as.numeric(newtree$CR)*100,2))) + + cat ("Starting repeat loop\n") + + repeat + { + #stopPointCode 5 (after growth and mortality, before it is added) + #stopPointCode 6 (just before estab, place to add new trees) + + #BE CAREFULL: the next few lines control when to exit the loop and + #the details are very important. It is easy to break this code! + rtn = fvsRun(stopPointCode=5,stopPointYear=-1) + if (rtn != 0) break + stopPoint <- fvsGetRestartcode() + # end of current stand? + cat ("first stopPoint code=",stopPoint,"\n") + if (stopPoint == 100) break + + cat ("fvsRunAcadian: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=", + mortModel,"\n volLogic=",volLogic," SBW=",SBW,"\n") + + # if there are no trees, this code does not work. + # NB: room is used below, so if this rule changes, move this code + room=fvsGetDims() + if (room["ntrees"] == 0) next + + #fetch some stand level information + stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear","elev")) + stdIds = fvsGetStandIDs() + cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 + attributes(cyclen) = NULL + CSI = fvsGetEventMonitorVariables("csi") + if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM + CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) + ELEV = as.numeric(stdInfo["elev"]) * FTtoM + cat ("fvsRunAcadian: CSI=",CSI," ELEV=",ELEV,"\n") + + #set/reset THINMOD based on pre and post event monitor variables + if (wThinMod) + { + thinning = fvsGetEventMonitorVariables(c("bba","aba","badbh","aadbh","rtpa")) + if (thinning["rtpa"] > 0) + { + THINMOD = c(stdInfo["year"], + (1-(thinning["aba"]/thinning["bba"]))*100., + thinning["bba"]*fvsUnitConversion("FT2pACRtoM2pHA"), + if (thinning["aadbh"]>=1) + thinning["badbh"]/thinning["aadbh"] else NA) + names(THINMOD) = c("YEAR_CT","pBArm","BApre","QMDratio") + } else if (!is.null(THINMOD) && + stdInfo["year"]-THINMOD["YEAR_CT"] > 20) THINMOD=NULL + } + + #fetch the fvs trees and form the AcadianGY "tree" dataframe + orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special")) + names(orgtree) = toupper(names(orgtree)) + orgtree$TREE= 1:nrow(orgtree) + names(orgtree)[match("SPECIES",names(orgtree))] = "SP" + names(orgtree)[match("TPA",names(orgtree))] = "EXPF" + orgtree$SP = spcodes[orgtree$SP,1] + #change CR to a proportion and take abs; note that in FVS a negative CR + #signals that CR change has been computed by the fire or insect/disease model + orgtree$CR = abs(orgtree$CRATIO) * .01 + orgtree$DBH = orgtree$DBH * INtoCM + orgtree$HT = orgtree$HT * FTtoM + orgtree$EXPF = orgtree$EXPF * HAtoACR + + #load the form and risk class data using FVS variable ISPECL loaded using "special" + + orgtree$Form = rep(" ",nrow(orgtree)) + orgtree$Risk = rep(" ",nrow(orgtree)) + tmpset = orgtree$SPECIAL > 0 & orgtree$SPECIAL < 85 + orgtree$Form[tmpset] = paste0("F",as.integer(orgtree$SPECIAL[tmpset] %/% 10)) + orgtree$Risk[tmpset] = paste0("R",as.integer(orgtree$SPECIAL[tmpset] %% 10)) + + stand = list(CSI=CSI,ELEV=ELEV) + ops = list(verbose=TRUE,INGROWTH=INGROWTH,MinDBH=MinDBH, + CutPoint=0.5, # >0 uses threshold probability (>0-1). + mortType="continuous", #mortType="discrete", + SBW=SBW,THINMOD=THINMOD,verbose=TRUE, + rtnVars = c("PLOT","SP","DBH","EXPF","TREE","HT","HCB","Form","Risk")) + + tree=orgtree + + for (year in stdInfo["year"]:stdInfo["cendyear"]) + { + tree$YEAR = year + cat ("fvsRunAcadian: calling AcadianGY, year=",year,"\n") + treeout = try(AcadianGYOneStand(tree,stand=stand,ops=ops)) + if (class(treeout)=="try-error" || any(is.na(treeout$DBH)) || + any(is.na(treeout$HT)) || any(is.na(treeout$EXPF))) + { + cat("AcadianGYOneStand failed in year=",year,"\n") + dmpFile=file.path(getwd(),paste0("AcadianGYOneStand.Failure.",year,".RData")) + if (class(treeout)!="try-error") treeout="critical result contains NA values" + cat ("dmpFile name=",dmpFile,"\n") + save(file=dmpFile,treeout,tree,stand,ops) + tree=NULL + break + } + tree=treeout + } + # if there was a failure, tree will be NULL, go on to the next stand cycle + if (is.null(tree)) next + # put the PLOT variable back to a character string (defactor it). + if (is.factor(tree$PLOT)) tree$PLOT = levels(tree$PLOT)[as.numeric(tree$PLOT)] + # restore the order of the trees + tree = tree[order(tree$TREE),] + + cat ("fvsRunAcadian: is.null(tree$dEXPF)=",is.null(tree$dEXPF),"\n") + cat ("fvsRunAcadian: cyclen=",cyclen,"sum1 EXPF=",sum(tree$EXPF), + " sum dEXPF=",if (is.null(tree$dEXPF)) NA else sum(tree$dEXPF),"\n") + + names(tree)[match("TPA",names(tree))] = "EXPF" + + tree$CR = round((1-(tree$HCB/tree$HT))*100,1) + + tofvs = data.frame( + dg=(tree$DBH[orgtree$TREE]-orgtree$DBH)*CMtoIN, + htg=(tree$HT[orgtree$TREE]-orgtree$HT)*MtoFT, + # set the crown ratio sign to negetive so that FVS + # doesn't change them. if already negetive, don't change them. + cratio=ifelse(orgtree$CRATIO < 0, orgtree$CRATIO, + -tree$CR[orgtree$TREE])) + special=as.numeric(substr(tree$Form[orgtree$TREE],2,2))*10+ + as.numeric(substr(tree$Risk[orgtree$TREE],2,2)) + + if (mortModel == "Acadian") tofvs$mort=(orgtree$EXPF- + tree$EXPF[orgtree$TREE])*ACRtoHA + fvsSetTreeAttrs(tofvs) + + atstop6 = FALSE + + # adding regeneration? + newTrees = nrow(tree) - nrow(orgtree) + cat ("fvsRunAcadian: num newtrees=",newTrees,"\n") + if (newTrees) + { + if (newTrees < room["maxtrees"] - room["ntrees"]) + { + newTrees = (nrow(orgtree)+1):nrow(tree) + toadd = data.frame(dbh =tree$DBH[newTrees]*CMtoIN, + species=match(tree$SP[newTrees],spcodes[,"fvs"]), + ht =tree$HT[newTrees]*MtoFT, + cratio =-tree$CR[newTrees], + plot =as.numeric(tree$PLOT[newTrees]), + tpa =tree$EXPF[newTrees]*ACRtoHA) + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + fvsAddTrees(toadd) + } else cat ("fvsRunAcadian: Not enough room for",newTrees, + "new trees; Year=",year,"\n") + } + + # modifying volume? + if (volLogic == "Acadian") + { + cat ("fvsRunAcadian: Applying Acadian volume logic\n") + + mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) + vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) + vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], + mapply(KozakTreeVol,Bark="ob",Planted=0, + DBH=vols$dbh * INtoCM, + HT =vols$ht * FTtoM, + SPP=spcodes[vols$species,1], + stump=mcstds$mcstmp[vols$species] * FTtoM, + topD =mcstds$mctopd[vols$species] * INtoCM), 0) + + if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * + (1-(((vols$defect %% 10000) %/% 100) * .01)) + vols$mcuft = vols$mcuft * M3toFT3 + vols$species=NULL + vols$ht =NULL + vols$dbh =NULL + vols$defect =NULL + if (!atstop6) + { + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + } + fvsSetTreeAttrs(vols) + } + } + cat ("rtn=",rtn,"\n") + rtn +} + +# NOTE: I (NLCrookston) tried various ways of building these elements. Setting the +# initial value to the saved value when the elements are created seems to work well. +# What did not work was setting the initial value to some default and then +# changing it using an update call in the server code. + +uiAcadian <- function(fvsRun) +{ +cat ("in uiAcadian uiAcadianVolume=", + if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) "NULL" else + fvsRun$uiCustomRunOps$uiAcadianVolume,"\n") + + if (is.null(fvsRun$uiCustomRunOps$uiAcadianIngrowth)) + fvsRun$uiCustomRunOps$uiAcadianIngrowth = "No" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianMinDBH)) + fvsRun$uiCustomRunOps$uiAcadianMinDBH = "3.0" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianMort)) + fvsRun$uiCustomRunOps$uiAcadianMort = "Acadian" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianCutPoint)) + fvsRun$uiCustomRunOps$uiAcadianCutPoint = "0.95" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianVolume)) + fvsRun$uiCustomRunOps$uiAcadianVolume = "Acadian" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianTHIN)) + fvsRun$uiCustomRunOps$uiAcadianTHIN = "Yes" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW)) + fvsRun$uiCustomRunOps$uiAcadianSBW = "No" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBWCDEF)) + fvsRun$uiCustomRunOps$uiAcadianSBWCDEF = "100" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.YR)) + fvsRun$uiCustomRunOps$uiAcadianSBW.YR = "2020" + if (is.null(fvsRun$uiCustomRunOps$uiAcadianSBW.DUR)) + fvsRun$uiCustomRunOps$uiAcadianSBW.DUR = "10" + list( + myRadioGroup("uiAcadianIngrowth", "Simulate ingrowth:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianIngrowth), + myInlineTextInput("uiAcadianMinDBH","Minimum DBH for ingrowth", + fvsRun$uiCustomRunOps$uiAcadianMinDBH), + myRadioGroup("uiAcadianMort", "Mortality model:", + c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianMort), + myInlineTextInput("uiAcadianCutPoint","CutPoint", + fvsRun$uiCustomRunOps$uiAcadianCutPoint), + myRadioGroup("uiAcadianVolume", "Merchantable volume logic:", + c("Acadian","Base Model"),selected=fvsRun$uiCustomRunOps$uiAcadianVolume), + myRadioGroup("uiAcadianTHIN", "Run with thinning modifiers:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianTHIN), + myRadioGroup("uiAcadianSBW", "Run with Spruce Budworm modifiers:", + c("Yes","No"),selected=fvsRun$uiCustomRunOps$uiAcadianSBW), + myInlineTextInput("uiAcadianSBWCDEF","Cumulative defoliation:", + fvsRun$uiCustomRunOps$uiAcadianSBWCDEF), + myInlineTextInput("uiAcadianSBW.YR","Defoliation start year:", + fvsRun$uiCustomRunOps$uiAcadianSBW.YR), + myInlineTextInput("uiAcadianSBW.DUR","Defoliation duration (years):", + fvsRun$uiCustomRunOps$uiAcadianSBW.DUR) + ) +} diff --git a/fvsOL/makefile b/fvsOL/makefile index 2b3b8c2..0d4a737 100644 --- a/fvsOL/makefile +++ b/fvsOL/makefile @@ -9,7 +9,7 @@ data/fvsOnlineHelpRender.RData: inst/extdata/mkhelp.R inst/extdata/fvsOnlineHelp fvsOLmadeTag: makefile DESCRIPTION R/* inst/extdata/* inst/extdata/www/* data/* cd .. && Rscript --default-packages=devtools -e "devtools::document(pkg='fvsOL')" cd .. && Rscript --default-packages=devtools -e "devtools::build(pkg='fvsOL')" - cd .. && Rscript --default-packages=devtools -e ".libPaths('~/R-dev');devtools::install(pkg='fvsOL',type='source')" + cd .. && Rscript --default-packages=devtools -e "devtools::install(pkg='fvsOL',type='source')" touch fvsOLmadeTag clean: diff --git a/fvsOL/parms/ardwrd3.kwd b/fvsOL/parms/ardwrd3.kwd index 4e86c4f..cb6ff62 100644 --- a/fvsOL/parms/ardwrd3.kwd +++ b/fvsOL/parms/ardwrd3.kwd @@ -1,7 +1,6 @@ //start keyword.ardwrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -645,8 +644,7 @@ RRMinK !1,10!!2,10!} //start keyword.ardwrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.ardwrd3.RRTreIn diff --git a/fvsOL/parms/armwrd3.kwd b/fvsOL/parms/armwrd3.kwd index ffe9680..0e61048 100644 --- a/fvsOL/parms/armwrd3.kwd +++ b/fvsOL/parms/armwrd3.kwd @@ -1,7 +1,6 @@ //start keyword.armwrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -580,8 +579,7 @@ parmsForm=answerForm //start keyword.armwrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.armwrd3.RRTreIn diff --git a/fvsOL/parms/basekeys.kwd b/fvsOL/parms/basekeys.kwd index f3cd594..75fe271 100644 --- a/fvsOL/parms/basekeys.kwd +++ b/fvsOL/parms/basekeys.kwd @@ -608,7 +608,7 @@ description: {Alters the change in crown by a specified proportion, or in the case of dubbing adjusts the dubbed crown by the specified proportion. -This keyword not applicable in NI, IE, CI, and KT variants. +This keyword not applicable in IE, CI, and KT variants. Once keyword is in effect, it remains in effect until replaced by another multiplier. @@ -4966,8 +4966,7 @@ automatically computed by the program). If the target relative is nonzero and the cutting control flag is nonzero, then the cutting efficiency parameter is used.} -description: -{This keyword can only be used in the Northeast variant.} +f1:{noInput This keyword can only be used in the Northeast variant.} f1{ne}:{scheduleBox} f2{ne}:{numberBox Residual Relative Density (within specified DBH range)} diff --git a/fvsOL/parms/dbs.kwd b/fvsOL/parms/dbs.kwd index 76ae255..3864f8c 100644 --- a/fvsOL/parms/dbs.kwd +++ b/fvsOL/parms/dbs.kwd @@ -15,16 +15,16 @@ ATRTLiDB !1,10!!2,10!} //end keyword.dbs.ATRTLiDB -//start keyword.dbs.BurnRept +//start keyword.dbs.BurnReDB f1:{listButtonString Build FVS_BurnReport table} f1v:{1 = Both database and standard output. >2 = Database table only.} parmsForm:{ -BurnRept !1,10!} +BurnReDB !1,10!} -//end keyword.dbs.BurnRept +//end keyword.dbs.BurnReDB //start keyword.dbs.CalbStDB @@ -407,3 +407,17 @@ description: output database. Table is written to main output file by default.} //end keyword.dbs.RDSum + +//start keyword.dbs.InvStats + +f1: +{noInput Build the FVS_Stats_Stand and FVS_Stats_Species tables.} + +//end keyword.dbs.InvStats + +//start keyword.dbs.RegRepts + +f1: +{noInput Build the regeneration establishment tables.} + +//end keyword.dbs.RegRepts diff --git a/fvsOL/parms/keylist.prm b/fvsOL/parms/keylist.prm index 777c92d..84d0270 100644 --- a/fvsOL/parms/keylist.prm +++ b/fvsOL/parms/keylist.prm @@ -10,7 +10,7 @@ AddFile {base io}: {Permits addition of a file containing keywords.} ATRTList {base io}: -{Prints a list of tree records representing stand conditions after a +{Prints a list of tree records representing stand conditions after a scheduled treatment to an output treelist file} BAIMult {base modifier}: @@ -20,11 +20,11 @@ BAMax {base modifier}: {Modifies maximum density for the stand and the mortality distribution pattern.} BFDefect {base vol}: -{Specifies species specific board-foot volume defect corrections for board foot +{Specifies species specific board-foot volume defect corrections for board foot volume estimates.} BFFDLN {base vol}: -{Enters species specific parameters for log-linear form and defect correction for +{Enters species specific parameters for log-linear form and defect correction for board-foot volume estimates.} BFVolEqu {base vol modifier}: @@ -37,7 +37,7 @@ CalbStat {base io}: {Specify the minimum number of observations required for calibration.} CCAdj {base modifier silv}: -{Adjusts the percent canopy cover (%CC) overlap assumption for clumpy or +{Adjusts the percent canopy cover (%CC) overlap assumption for clumpy or uniform stands. Can be used with THINCC to change the %CC target calculation.} Close {base io}: @@ -59,14 +59,14 @@ Compute {base io}: {Defines a user specified variable used by the Event Monitor.} CrnMult {base modifier silv}: -{Alters the change in crown by a specified proportion, or in the case of dubbing +{Alters the change in crown by a specified proportion, or in the case of dubbing adjusts the dubbed crown by the specified proportion.} CutEff {base thin silv}: {Changes the cutting efficiency for all thinnings.} CutList {base io thin}: -{Print a list of all harvested tree records or place a copy in a retrievable +{Print a list of all harvested tree records or place a copy in a retrievable mass storage file.} CWEqn {base modifier}: @@ -88,7 +88,7 @@ Design {base stdtre inventory}: {Specify information about the sampling design used to collect tree data.} DgStDev {base modifier}: -{Change the limits of the normal distribution from which random errors are +{Change the limits of the normal distribution from which random errors are drawn for diameter increment predictions.} Echo {base control}: @@ -142,7 +142,7 @@ MgmtId {base stdtre silv}: {4-character alphanumeric code identifying the projected silvicultural treatment.} MinHarv {base thin vol}: -{Specify minimum acceptable harvest standards for board-foot volume, +{Specify minimum acceptable harvest standards for board-foot volume, merchantable cubic-foot volume, or basal area per acre by cycle.} ModType {base inventory}: @@ -159,14 +159,14 @@ NoAutoES {base control regen}: {Suppresses all natural regeneration and ingrowth features.} NoCalib {base modifier inventory}: -{Suppress calculation of scale factors for large tree diameter increment model +{Suppress calculation of scale factors for large tree diameter increment model and small tree height increment model.} NoEcho {base control}: {Suppresses keyword echo to the Options Selected by Input in the Main Output file.} NoHtDReg {base modifier inventory}: -{Suppress the calculation of parameters for a local height-diameter equation for +{Suppress the calculation of parameters for a local height-diameter equation for use in dubbing the heights of trees which have missing recorded heights.} NoScreen {base io}: @@ -187,14 +187,14 @@ NumTrip {base control}: {Change the number of times tree records will be tripled.} Open {base io}: -{Request for an input or output file. A supplement record is required to specify a +{Request for an input or output file. A supplement record is required to specify a filename for the unit that is to be opened.} PointGrp {base thin silv stdtre}: {Defines a group of points referenced by a single name or number.} PointRef {base thin silv}: -{Specifies whether the point number entered on a keyword or Event Monitor function, +{Specifies whether the point number entered on a keyword or Event Monitor function, refers to the inventory point number or FVS sequential point number.} PrmFrost {base modifier}: @@ -227,7 +227,7 @@ ResetAge {base control silv}: {Resets the stand age to make output correspond to the age of the stand.} Screen {base io}: -{Allows printing of the summary output table to the terminal during program +{Allows printing of the summary output table to the terminal during program execution.} SDICalc {base modifier stdtre}: @@ -262,18 +262,18 @@ SpecPref {base thin silv}: {Change the species preference for removal.} StrClass {base control io}: -{Calculates structural class values and defines related Event Monitor +{Calculates structural class values and defines related Event Monitor structural class variables.} StandCN {base io}: {Enter stand_CN} Stats {base control io}: -{Optional table showing a statistical description of the input data for a +{Optional table showing a statistical description of the input data for a projection.} StdIdent {base stdtre io}: -{Specify a stand identification code and descriptive title to label output tables, +{Specify a stand identification code and descriptive title to label output tables, use the Suppose Current Subset Window to identify your stands.} StdInfo {base inventory stdtre}: @@ -313,7 +313,7 @@ ThinMist {base thin silv}: {Schedule the removal of trees with Dwarf Mistletoe Rating} ThinPRSC {base thin silv}: -{Schedule prescription thinning, harvesting trees that were marked for removal +{Schedule prescription thinning, harvesting trees that were marked for removal on the input tree records.} ThinPt {base thin silv}: @@ -332,7 +332,7 @@ ThinSDI {base thin silv}: {Schedule a thinning with a residual stand density index target.} TimeInt {base control}: -{Specify the length, in years, of any or all projection cycles. It is best to let +{Specify the length, in years, of any or all projection cycles. It is best to let Suppose set the cycle lengths.} TopKill {base modifier thin}: @@ -349,14 +349,14 @@ TreeList {base io}: file.} TreeSzCp {base modifier}: -{Sets limits for maximum tree diameter and height for a given species, and specifies +{Sets limits for maximum tree diameter and height for a given species, and specifies a minimum mortality rate when tree diameter exceeds the specified limit.} VolEqNum {base vol modifier}: {Changes the Volume Equation number used to calculate volume} Volume {base vol modifier}: -{Redefine merchantability limits for the merchantable cubic-foot volume +{Redefine merchantability limits for the merchantable cubic-foot volume equation.} YardLoss {base silv thin}: @@ -389,11 +389,11 @@ ShrbLayr {cover calib understory}: {Provides field data with which to calibrate shrub predictions.} ShrubHt {cover calib understory}: -{Supply calibration information where height in feet measurements have been +{Supply calibration information where height in feet measurements have been gathered for individual species.} ShrubPC {cover calib understory}: -{Supply calibration information where percent cover measurements have been +{Supply calibration information where percent cover measurements have been gathered for individual species.} Shrubs {cover control understory}: @@ -438,7 +438,7 @@ MistPrt {mist io}: ClimData {climate}: -{Signifies that the climate and species-viability data be read from an external file +{Signifies that the climate and species-viability data be read from an external file and specifies which Global Circulation Model/Scenario desired.} ClimRept {climate}: @@ -469,32 +469,32 @@ AuTally {estb modifier control inventory}: {Generates automatic tallies following thinnings.} BudWorm {estb stdtre silv regen}: -{Input defoliation histories for western spruce budworm and simulate the effects +{Input defoliation histories for western spruce budworm and simulate the effects of budworm defoliation on regeneration success.} BurnPrep {estb strp silv inventory}: {Enter the percentage of plots receiving a site preparation by burning.} Estab {estb strp control}: -{Enters the year of disturbance and signal that keywords following are for the +{Enters the year of disturbance and signal that keywords following are for the Regeneration Establishment extension.} EZCruise {estb strp silv inventory}: -{Predict the small tree component at the time of the inventory if the inventory +{Predict the small tree component at the time of the inventory if the inventory data does not include small trees.} HabGroup {estb io silv stdtre regen}: {Prints a table showing habitat types by habitat type group.} HtAdj {estb strp modifier io stdtre regen}: -{Enter a species specific initial height modifier for newly established trees before +{Enter a species specific initial height modifier for newly established trees before the tree records are passed to the FVS model.} Ingrow {estb stdtre regen}: {Toggles on the simulation of ingrowth.} MechPrep {estb strp silv inventory}: -{Enter the percentage of regeneration plots receiving a site preparation by +{Enter the percentage of regeneration plots receiving a site preparation by mechanical scarification.} MinPlots {estb strp inventory}: @@ -516,14 +516,14 @@ Output {estb strp io control}: {Control the kind of printed output described for this extension.} PassAll {estb io modifier control}: -{Specifies the number of "acceptable" predicted seedlings to be passed from the +{Specifies the number of "acceptable" predicted seedlings to be passed from the regeneration model to the FVS tree list during the tally.} Plant {estb strp silv regen}: {Specify that planting is to be simulated} PlotInfo {estb strp inventory stdtre silv}: -{Specify plot specific values for slope, aspect, habitat type, topographic position, +{Specify plot specific values for slope, aspect, habitat type, topographic position, and site preparation.} ESRanSd {estb strp modifier}: @@ -533,14 +533,14 @@ ResetAge {estb strp control silv}: {Resets the stand age to make output correspond to the age of the stand.} SpecMult {estb modifier stdtre regen}: -{Enter a species specific multiplier that adjusts the probability of a species' +{Enter a species specific multiplier that adjusts the probability of a species' occurrence in natural regeneration.} Sprout {estb strp stdtre regen}: {Turn on/or change the simulation of sprouting} StockAdj {estb modifier inventory regen}: -{Enter a multiplier to adjust the probability of natural regeneration stocking for +{Enter a multiplier to adjust the probability of natural regeneration stocking for individual plots.} Tally {estb strp control silv inventory}: @@ -550,7 +550,7 @@ TallyOne {estb strp inventory}: {Schedule the first regeneration tally in a specific year.} TallyTwo {estb strp inventory}: -{Schedule the second regeneration tally at any time after the first tally and up to +{Schedule the second regeneration tally at any time after the first tally and up to 20 years after a disturbance.} Thrshold {estb modifier inventory}: @@ -580,7 +580,7 @@ BBType4 {armwrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} DNSCalc {armwrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {armwrd3 modifier}: @@ -593,11 +593,11 @@ InfMult {armwrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {armwrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {armwrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {armwrd3 modifier}: @@ -616,7 +616,7 @@ RRComp {armwrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {armwrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {armwrd3 control io}: @@ -627,11 +627,11 @@ RRInit {armwrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {armwrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {armwrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {armwrd3 inventory}: @@ -647,7 +647,7 @@ SDIRMult {armwrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {armwrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spread {armwrd3 modifier}: @@ -660,7 +660,7 @@ TDistn {armwrd3 modifier}: {Specify the type of spatial distribution of trees in disease centers.} TimeDead {armwrd3 inventory}: -{Change the time since death for dead infected trees and stumps in the +{Change the time since death for dead infected trees and stumps in the inventory.} TTDMult {armwrd3 modifier}: @@ -693,7 +693,7 @@ BBType4 {phewrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} DNSCalc {phewrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {phewrd3 modifier}: @@ -706,11 +706,11 @@ InfMult {phewrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {phewrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {phewrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {phewrd3 modifier}: @@ -729,7 +729,7 @@ RRComp {phewrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {phewrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {phewrd3 control io}: @@ -740,11 +740,11 @@ RRInit {phewrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {phewrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {phewrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {phewrd3 inventory}: @@ -760,7 +760,7 @@ SDIRMult {phewrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {phewrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spread {phewrd3 modifier}: @@ -773,7 +773,7 @@ TDistn {phewrd3 modifier}: {Specify the type of spatial distribution of trees in disease centers.} TimeDead {phewrd3 inventory}: -{Change the time since death for dead infected trees and stumps in the +{Change the time since death for dead infected trees and stumps in the inventory.} TTDMult {phewrd3 modifier}: @@ -805,11 +805,11 @@ BBType4 {ardwrd3 otherAgent}: {Include mountain pine beetle on ponderosa pine in the simulation.} Borate {ardwrd3 mgmt}: -{Simulate the application of borax to stumps (to prevent the +{Simulate the application of borax to stumps (to prevent the colonization by spores) after each harvest.} DNSCalc {ardwrd3 otherAgent}: -{Alter the method by which the outbreak stand density threshold +{Alter the method by which the outbreak stand density threshold is computed for bark beetle type 1.} InfColo {ardwrd3 modifier}: @@ -822,11 +822,11 @@ InfMult {ardwrd3 modifier}: {Modify the probability of root disease transmission.} InfSims {ardwrd3 io modifier}: -{Change the number of times to simulate the inside-center infection +{Change the number of times to simulate the inside-center infection dynamics. Print results of inside-center simulation.} InocLife {ardwrd3 modifier}: -{Modify the default rate and patterns of decay of the inoculum in the +{Modify the default rate and patterns of decay of the inoculum in the infected roots of dead stumps and trees.} InocSpan {ardwrd3 modifier}: @@ -845,11 +845,11 @@ RRComp {ardwrd3 modifier}: {Modify the maximum size of the tree list.} RRDOut {ardwrd3 control io}: -{Instruct the model to write a detailed root disease output table to the +{Instruct the model to write a detailed root disease output table to the main output file.} RREcho {ardwrd3 control io}: -{Instruct the model to write the disease summary table +{Instruct the model to write the disease summary table to a seperate file.} RRHosts {ardwrd3 modifier}: @@ -859,11 +859,11 @@ RRInit {ardwrd3 inventory}: {Specify the number, size, and distribution of disease centers.} RRJump {ardwrd3 modifier}: -{Specify the extent to which centers expand through uninfected trees +{Specify the extent to which centers expand through uninfected trees when the stand is thinned or clearcut.} RRMinK {ardwrd3 modifier}: -{Specify years-to-death below which the TTDMult keyword does not +{Specify years-to-death below which the TTDMult keyword does not influence mortality.} RRTreIn {ardwrd3 inventory}: @@ -882,7 +882,7 @@ SDIRMult {ardwrd3 modifier}: {Modify the calculation of root radius based on SDI.} SMCOut {ardwrd3 io}: -{Instruct the model to write a table of root disease center spread +{Instruct the model to write a table of root disease center spread rates from the Monte Carlo Simulation to a seperate file.} Spore {ardwrd3 modifier}: @@ -947,15 +947,15 @@ DWDVlOut {fire io}: {Request the down wood volume report.} FireCalc {fire control modifier}: -{Adjust the fuel model selection logic used or select the option of using +{Adjust the fuel model selection logic used or select the option of using modelled fuel loads directly to predict fire behavior.} FlameAdj {fire control modifier}: -{Modify or set the flame length for a fire simulated using the +{Modify or set the flame length for a fire simulated using the SIMFIRE keyword scheduled for the same year.} FModList {fire control modifier}: -{Adjust the fuel models available for selection in conjuction with the new +{Adjust the fuel models available for selection in conjuction with the new fuel model logic (see FireCalc keyword).} FMortMlt {fire modifier}: @@ -987,33 +987,33 @@ FuelPool {fire modifier}: {Set the decay rate (very slow, slow, medium, fast) for each tree species.} FuelRept {fire io}: -{Request a fuel consumption and physical effects report be generated +{Request a fuel consumption and physical effects report be generated when a fire occurs.} FuelSoft {fire inventory modifier}: {Set the initial soft/rotten fuel loads for each fuel size class.} FuelTret {fire mgmt modifier}: -{Set the fuel treatment (lopping, chopping, etc) and harvest type +{Set the fuel treatment (lopping, chopping, etc) and harvest type (skidding, high lead, etc) so as to modify the fuel depth.} Moisture {fire modifier}: {Set the fuel moisture conditions for each fuel category.} MortClas {fire io modifier}: -{Set the lower bounds for the seven classes used in reporting +{Set the lower bounds for the seven classes used in reporting fire-caused mortality.} MortRept {fire io}: -{Request that a fire-caused tree mortality report be generated when a +{Request that a fire-caused tree mortality report be generated when a fire occurs.} PileBurn {fire mgmt modifier}: -{Schedule a pile or jackpot burn and modify tree mortality rates +{Schedule a pile or jackpot burn and modify tree mortality rates resulting from this fuel treatment.} PotFire {fire io}: -{Request that a report on potential fires under nominal burn +{Request that a report on potential fires under nominal burn conditions be generated.} PotFMois {fire modifier}: @@ -1044,7 +1044,7 @@ SnagBrk {fire modifier}: {Set the parameters for breaking (cause height loss) of standing snags.} SnagClas {fire io modifier}: -{Set the dbh size class boundaries for the snag report (see SnagOut +{Set the dbh size class boundaries for the snag report (see SnagOut and SnagSum).} SnagDCay {fire modifier}: @@ -1054,7 +1054,7 @@ SnagFall {fire modifier}: {Modify the snag fall rate by tree species.} SnagInit {fire inventory}: -{Add a snag record of a given species, size, height, age, and density +{Add a snag record of a given species, size, height, age, and density to the snag list.} SnagOut {fire io}: @@ -1083,14 +1083,14 @@ StatFuel {fire modifier}: ATRTLiDB {dbs}: {Requests the FVS_ATRTList table be created and populated.} -BurnRept {dbs}: +BurnReDB {dbs}: {Requests the FVS_BurnReport table be created and populated.} CalbStDB {dbs}: {Requests the FVS_CalbStat table be created and populated.} CarbReDB {dbs}: -{Requests the FVS_Carbon and FVS_Hrv_Carbon tables be +{Requests the FVS_Carbon and FVS_Hrv_Carbon tables be created and populated.} ClimReDB {dbs}: @@ -1117,6 +1117,10 @@ FuelReDB {dbs}: FuelsOut {dbs}: {Requests the FVS_Fuels table be created and populated.} +InvStats {dbs}: +{Requests the FVS_Stats_Stand and FVS_Stats_Species tables be +created and populated.} + MisRpts {dbs}: {Requests the FVS_DM_Spp_Sum, FVS_DM_Stnd_Sum, and FVS_DM_Sz_Sum dwarf mistletoe tables be created and populated.} @@ -1136,6 +1140,9 @@ RDDetail {dbs}: RDSum {dbs}: {Requests the FVS_RD_Sum table be created and populated.} +RegRepts {dbs}: +{Requests regeneration establishment table(s) be created and populated.} + SnagOuDB {dbs}: {Requests the FVS_SnagDet table be created and populated.} @@ -1143,15 +1150,15 @@ SnagSuDB {dbs}: {Requests the FVS_SnagSum table be created and populated.} StandSQL {dbs}: -{Specify an SQL statement that from which stand-level +{Specify an SQL statement that from which stand-level FVS variables are initialized.} SQLIn {dbs}: -{Requests that an SQL statement be run on the input +{Requests that an SQL statement be run on the input database connection (DSNIN).} SQLOut {dbs}: -{Requests that an SQL statement be run on the output +{Requests that an SQL statement be run on the output database connection (DSNIN).} StrClsDB {dbs}: @@ -1160,11 +1167,11 @@ StrClsDB {dbs}: Summary {dbs}: {Requests the FVS_Summary table be created and populated.} -TreeList {dbs}: +TreeLiDB {dbs}: {Requests the FVS_Treelist table be created and populated.} -TreeLiDB {dbs}: -{Specify an SQL statement that from which tree-level +TreeSQL {dbs}: +{Specify an SQL statement that from which tree-level FVS variables are initialized.} ! --------------------------------------- @@ -1187,7 +1194,7 @@ HrvVrCst {econ}: {Specifies commercial thinning or harvest cost by unit-of-measure and tree DBH.} HrvRvn {econ}: -{Specifies commercial thinning or harvest price by unit-of-measure by species +{Specifies commercial thinning or harvest price by unit-of-measure by species by diameter-class.} LbsCfv {econ}: @@ -1203,7 +1210,7 @@ PctFxCst {econ}: {Specifies per acre pre-commercial thinning cost.} PctSpec {econ}: -{Specifies removal parameters differentiating pre-commercial +{Specifies removal parameters differentiating pre-commercial thinning from commercial thinning or harvest.} PctVrCst {econ}: @@ -1213,7 +1220,7 @@ PlantCst {econ}: {Specifies planting cost.} Pretend {econ}: -{Requests that economic benefits and costs be calculated +{Requests that economic benefits and costs be calculated for a hypothetical stand harvest.} SpecCst {econ}: diff --git a/fvsOL/parms/phewrd3.kwd b/fvsOL/parms/phewrd3.kwd index 6159d6c..01a9936 100644 --- a/fvsOL/parms/phewrd3.kwd +++ b/fvsOL/parms/phewrd3.kwd @@ -1,7 +1,6 @@ //start keyword.phewrd3.BBClear -description: -{Deactivate the default bark beetle events. The model will automatically +f1:{noInput Deactivate the default bark beetle events. The model will automatically schedule bark beetle events for bark beetle types 1, 3, and 4 using the default values unless BBClear, BBType1, BBType2, BBType3, or BBType4 are used.} @@ -581,8 +580,7 @@ parmsForm=answerForm //start keyword.phewrd3.RRTreIn -description: -{Indicates that root disease conditions will be initialized from the +f1:{noInput Indicates that root disease conditions will be initialized from the inventory tree list.} //end keyword.phewrd3.RRTreIn diff --git a/rFVS/DESCRIPTION b/rFVS/DESCRIPTION index 61ba832..7ce7c12 100644 --- a/rFVS/DESCRIPTION +++ b/rFVS/DESCRIPTION @@ -1,11 +1,11 @@ -Package: rFVS -Title: Interface functions for the Forest Vegetation Simulator -Version: 2021.05.11 -Authors@R: person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", - role = c("aut", "cre")) -Description: Provides a set of R functions that interface with the - Forest Vegetation Simulator when it is run as a shared libray. -Depends: R (>= 4.0.0) -License: MIT -Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +Package: rFVS +Title: Interface functions for the Forest Vegetation Simulator +Version: 2023.02.01 +Authors@R: person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", + role = c("aut", "cre")) +Description: Provides a set of R functions that interface with the + Forest Vegetation Simulator when it is run as a shared libray. +Depends: R (>= 4.0.0) +License: MIT +Roxygen: list(markdown = TRUE) +RoxygenNote: 7.2.1 diff --git a/rFVS/NAMESPACE b/rFVS/NAMESPACE deleted file mode 100644 index ef49812..0000000 --- a/rFVS/NAMESPACE +++ /dev/null @@ -1,24 +0,0 @@ -# Generated by roxygen2: do not edit by hand - -export(fvsAddActivity) -export(fvsAddTrees) -export(fvsCompositeSum) -export(fvsGetDims) -export(fvsGetEventMonitorVariables) -export(fvsGetRestartcode) -export(fvsGetSVSDims) -export(fvsGetSVSObjectSet) -export(fvsGetSpeciesAttrs) -export(fvsGetSpeciesCodes) -export(fvsGetStandIDs) -export(fvsGetSummary) -export(fvsGetTreeAttrs) -export(fvsInteractRun) -export(fvsLoad) -export(fvsRun) -export(fvsSetCmdLine) -export(fvsSetEventMonitorVariables) -export(fvsSetSpeciesAttrs) -export(fvsSetTreeAttrs) -export(fvsSetupSummary) -export(fvsUnitConversion) diff --git a/rFVS/R/fvsCutNow.R b/rFVS/R/fvsCutNow.R new file mode 100644 index 0000000..790ec7c --- /dev/null +++ b/rFVS/R/fvsCutNow.R @@ -0,0 +1,27 @@ +#' Specify a thinning/harvest by setting the proportion of each tree record's +#' sampling weight (trees/acre) that will be "cut" in the current cycle. +#' +#' This function can only be called at stoppoint 2, just after the first call +#' to the Event Monitor. The memory used to store the proportions in FVS is volatile +#' in that it is used for other purposes after the cut is simulated. The +#' specification of thinning/harvest using this option can be combined with other +#' other FVS thining options including the MinHarv and YardLoss keywords. This +#' feature is implemented using the ThinPrsc keyword. +#' +#' @param propcut a numeric vector holding the proportions of each tree. If a single value +#' is entered, it is replicated once of each sample tree in the simulation. +#' @return return code with the value 0 if OK, and non-zero otherwise +#' @export +fvsCutNow <- +function(propcut) +{ + if (fvsGetRestartcode() != 2) stop("function can only be used at stoppoint 2.") + if (missing(propcut)) stop("propcut is required.") + ntrees=fvsGetDims()[["ntrees"]] + if (length(propcut) == 1) propcut=rep(propcut,ntrees) + if (length(propcut) != ntrees) stop("a propcut for each tree record is required.") + r=fvsAddActivity(fvsGetEventMonitorVariables("Year"),"base_thinprsc",c(1.,-1)) + if (r != 0) return(r) + fvsSetTreeAttrs(list(wk6=propcut)) +} + \ No newline at end of file diff --git a/rFVS/R/fvsGetSpeciesAttrs.R b/rFVS/R/fvsGetSpeciesAttrs.R index ae3ae7b..f888385 100644 --- a/rFVS/R/fvsGetSpeciesAttrs.R +++ b/rFVS/R/fvsGetSpeciesAttrs.R @@ -1,30 +1,48 @@ -#' Return the values of species-specific data -#' -#' @param vars a character vector of species-level attributes desired: -#' \tabular{cl}{ -#' spccf \tab CCF for each species, recomputed in FVS so setting will likely have no effect\cr -#' spsdi \tab SDI maximums for each species \cr -#' spsiteindx \tab Species site indices\cr} -#' @return a data.frame where the columns are attributes and the rows are species. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetSpeciesAttrs(vars=c("spccf","spsiteindx")) -#' @export -fvsGetSpeciesAttrs <- -function(vars) -{ - maxspecies = fvsGetDims()["maxspecies"] - atr = vector("numeric",maxspecies) - action="get" - all = list() - for (name in vars) - { - nch =nchar(name) - ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[5]] == 0) all[[name]] = ans[[4]] - } - as.data.frame(all) -} - +#' Return the values of species-specific data +#' +#' @param vars a character vector of species-level attributes desired. See +#' \url{https://www.fs.usda.gov/fmsc/ftp/fvs/docs/gtr/EssentialFVS.pdf} for related details. +#' The attributes can be any of the following: +#' \tabular{cl}{ +#' spccf \tab CCF for each species, recomputed in FVS so setting may have no effect (depending on variant)\cr +#' spsdi \tab SDI maximums for each species \cr +#' spsiteindx \tab Species site indices\cr +#' bfmind \tab board foot minimum dbh for each species \cr +#' bftopd \tab board foot top diameter for each species \cr +#' bfstmp \tab board foot stump height for each species \cr +#' frmcls \tab board foot form class for each species \cr +#' bfmeth \tab board foot calculation method for each species \cr +#' mcmind \tab murchantable cubic volume minimum dbh for each species \cr +#' mctopd \tab murchantable cubic volume top diameter for each species \cr +#' mcstmp \tab murchantable cubic volume stump height for each species \cr +#' mcmeth \tab murchantable cubic volume calculation method for each species \cr +#' baimult \tab basal area increment multiplier for each species \cr +#' htgmult \tab height growth multiplier for each species \cr +#' mortmult \tab mortality rate multiplier for each species \cr +#' mortdia1 \tab lower diameter limit to apply the multiplier for each species \cr +#' mortdia2 \tab upper diameter limit to apply the multiplier for each species \cr +#' regdmult \tab multiplier for diameter growth of regeneration for each species \cr +#' reghmult \tab multiplier for height growth of regeneration for each species} +#' @return a data.frame where the columns are attributes and the rows are species. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetSpeciesAttrs(vars=c("spccf","spsiteindx")) +#' @export +fvsGetSpeciesAttrs <- +function(vars) +{ + maxspecies = fvsGetDims()["maxspecies"] + atr = vector("numeric",maxspecies) + action="get" + all = list() + for (name in vars) + { + nch =nchar(name) + ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[5]] == 0) all[[name]] = ans[[4]] + } + as.data.frame(all) +} + diff --git a/rFVS/R/fvsMakeyFile.R b/rFVS/R/fvsMakeyFile.R new file mode 100644 index 0000000..5fb7011 --- /dev/null +++ b/rFVS/R/fvsMakeyFile.R @@ -0,0 +1,81 @@ +#' Make an FVS keyword file suitable for running FVS using fvsLoad, fvsSetCmdLine and fvsRun +#' +#' Pass basic parameters needed to create an FVS input keyword file and this function will +#' generate the file. +#' +#' @param keyFileName the keyword file name, if not specified unique name is created and used as the +#' file name (the file name is returned). +#' @param runTitle the name of the run +#' @param standIDs A character vector of one or more standIDs, keywords are generated for each. +#' @param inDataBase The name of the input database, default is FVS_Data.db +#' @param outDataBase The name of the output database, default is FVSOut.db +#' @param ncycles The number of FVS cycles, default is 10. +#' @param moreKeywords One of the following: A character vector of properly formatted keyword records +#' that will be added to each stand, OR +#' A data.frame where the first column is a keyword and subsequent columns are "keyword" fields +#' that are added to the keywords. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsMakeKeyFile(runTitle="Test",standIDs=c("01100202010142","01100201010056")) +#' @export + +fvsMakeKeyFile <- function (keyFileName=NULL,runTitle=NULL,standIDs=NULL, + inDataBase="FVS_Data.db",outDataBase="FVSOut.db",ncycles=10,moreKeywords=NULL) +{ + trim <- function (x) gsub("^\\s+|\\s+$","",x) + if (is.null(standIDs)) stop("standIds must be specified.") + + if (is.null(keyFileName)) keyFileName=tempfile(pattern="fvs",fileext=".key",tmpdir=getwd()) + if (file.exists(keyFileName)) unlink(keyFileName) + fc = file(description=keyFileName,open="wt") + cat ("!!title:",runTitle,"\n",file=fc) + cat ("!!built:",format(Sys.time(), + "%Y-%m-%d_%H:%M:%S"),"\n",file=fc) + for (sid in standIDs) + { + sid = trim(sid) + cat ("\nStdIdent\n",sprintf("%-26s%s\n",sid,runTitle),sep="",file=fc) + cat (sprintf("%-10s%10s\n","NumCycle",as.character(ncycles)),sep="",file=fc) + if (!is.null(inDataBase)) + { + cat ("DataBase\nDSNin\n",inDataBase,"\nStandSQL\n",sep="",file=fc) + cat ("SELECT * FROM FVS_StandInit WHERE Stand_ID = '%StandID%'\n",sep="",file=fc) + cat ("EndSQL\nTreeSQL\n",sep="",file=fc) + cat ("SELECT * FROM FVS_TreeInit WHERE Stand_ID = '%StandID%'\n",sep="",file=fc) + cat ("EndSQL\nEND\n",sep="",file=fc) + } + if (!is.null(outDataBase)) + { + cat ("DataBase\nDSNOut\n",outDataBase, + "\nSummary 2\nComputdb 0 1\nEnd\n", + sep="",file=fc) + } + if (is.null(moreKeywords)) + cat("DelOTab 1\nDelOTab 2\nDelOTab 4\n",sep="",file=fc) + if (class(moreKeywords)=="character") + { + for (kw in moreKeywords) cat(kw,"\n",file=fc) + } else if (class(moreKeywords)=="data.frame") + { + if (class(moreKeywords) == "data.frame") for (row in 1:nrow(moreKeywords)) + { + if (nchar(moreKeywords[row,1])==0) next + kw=sprintf("%-10s",trim(moreKeywords[row,1]),file=fc) + if (ncol(morekeywords)>1) + { + for (col in 2:ncol(moreKeywords)) + kw=paste0(kw,sprintf("%10s",trim(as.character(moreKeywords[row,col])))) + } + } + cat(kw,"\n",file=fc) + } + cat ("\nProcess\n",sep="",file=fc) + } + cat ("Stop\n",sep="",file=fc) + close(fc) + keyFileName +} + + + diff --git a/rFVS/R/fvsSetSpeciesAttr.R b/rFVS/R/fvsSetSpeciesAttr.R index 4750c20..849b1cb 100644 --- a/rFVS/R/fvsSetSpeciesAttr.R +++ b/rFVS/R/fvsSetSpeciesAttr.R @@ -1,49 +1,67 @@ -#' Set the values of species-specific data -#' -#' @param vars a named list of numeric vectors where the name corresponds to an attribute and -#' the vector contains values for each species (in order). The attributes can be any of these: -#' \tabular{cl}{ -#' spccf \tab CCF for each species, recomputed in FVS so setting will likely have no effect\cr -#' spsdi \tab SDI maximums for each species \cr -#' spsiteindx \tab Species site indices\cr} -#' @return scalar integer 0 signals OK and 1 signals an error. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' vars = fvsGetSpeciesAttrs(vars=c("spccf","spsdi","spsiteindx")) -#' fvsSetSpeciesAttrs(vars=vars) -#' @export -fvsSetSpeciesAttrs <- -function(vars) -{ - maxspecies = fvsGetDims()["maxspecies"] - action = "set" - if (!is.list(vars)) stop("vars must be a list") - if (is.null(names(vars))) stop ("vars must have names") - rtn = 0 - for (name in names(vars)) - { - atr = as.numeric(vars[[name]]) - if (length(atr) != maxspecies) - { - warning("Length of '",name,"' must be ",maxspecies) - next - } - if (any(is.na(atr))) - { - warning ("NA(s) found for variable '",name,"'") - next - } - nch =nchar(name) - ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[5]] != 0) - { - rtn = if (ans[[5]] > rtn) ans[[5]] else rtn - warning ("error assigning variable '",name,"'") - next - } - } - invisible(rtn) -} - +#' Set the values of species-specific data +#' +#' @param vars a named list of numeric vectors where the name corresponds to an attribute and +#' the vector contains values for each species (in order). See +#' \url{https://www.fs.usda.gov/fmsc/ftp/fvs/docs/gtr/EssentialFVS.pdf} for related details. +#' The attrubytes can be any of the following: +#' \tabular{cl}{ +#' spccf \tab CCF for each species, recomputed in FVS so setting may have no effect (depending on variant)\cr +#' spsdi \tab SDI maximums for each species \cr +#' spsiteindx \tab Species site indices\cr +#' bfmind \tab board foot minimum dbh for each species \cr +#' bftopd \tab board foot top diameter for each species \cr +#' bfstmp \tab board foot stump height for each species \cr +#' frmcls \tab board foot form class for each species \cr +#' bfmeth \tab board foot calculation method for each species \cr +#' mcmind \tab murchantable cubic volume minimum dbh for each species \cr +#' mctopd \tab murchantable cubic volume top diameter for each species \cr +#' mcstmp \tab murchantable cubic volume stump height for each species \cr +#' mcmeth \tab murchantable cubic volume calculation method for each species \cr +#' baimult \tab basal area increment multiplier for each species \cr +#' htgmult \tab height growth multiplier for each species \cr +#' mortmult \tab mortality rate multiplier for each species \cr +#' mortdia1 \tab lower diameter limit to apply the multiplier for each species \cr +#' mortdia2 \tab upper diameter limit to apply the multiplier for each species \cr +#' regdmult \tab multiplier for diameter growth of regeneration for each species \cr +#' reghmult \tab multiplier for height growth of regeneration for each species} +#' @return scalar integer 0 signals OK and 1 signals an error. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' vars = fvsGetSpeciesAttrs(vars=c("spccf","spsdi","spsiteindx")) +#' fvsSetSpeciesAttrs(vars=vars) +#' @export +fvsSetSpeciesAttrs <- +function(vars) +{ + maxspecies = fvsGetDims()["maxspecies"] + action = "set" + if (!is.list(vars)) stop("vars must be a list") + if (is.null(names(vars))) stop ("vars must have names") + rtn = 0 + for (name in names(vars)) + { + atr = as.numeric(vars[[name]]) + if (length(atr) != maxspecies) + { + warning("Length of '",name,"' must be ",maxspecies) + next + } + if (any(is.na(atr))) + { + warning ("NA(s) found for variable '",name,"'") + next + } + nch =nchar(name) + ans = .C("CfvsSpeciesAttr",name,nch,action,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[5]] != 0) + { + rtn = if (ans[[5]] > rtn) ans[[5]] else rtn + warning ("error assigning variable '",name,"'") + next + } + } + invisible(rtn) +} + diff --git a/rFVS/makefile b/rFVS/makefile index f5e6869..ca3fcec 100644 --- a/rFVS/makefile +++ b/rFVS/makefile @@ -3,7 +3,7 @@ all: rFVSmadeTag rFVSmadeTag: makefile DESCRIPTION R/* cd .. && Rscript --default-packages=devtools -e "devtools::document(pkg='rFVS')" cd .. && Rscript --default-packages=devtools -e "devtools::build(pkg='rFVS')" - cd .. && Rscript --default-packages=devtools -e ".libPaths('~/R-dev');devtools::install(pkg='rFVS',type='source',repos=NULL)" + cd .. && Rscript --default-packages=devtools -e "devtools::install(pkg='rFVS',type='source',repos=NULL)" touch rFVSmadeTag clean: From 5a19bd47e59785699c3c03179d00a1d38bd782ae Mon Sep 17 00:00:00 2001 From: Daniel Wagner Date: Mon, 17 Jul 2023 13:53:49 -0400 Subject: [PATCH 3/3] Squashed commit of the following: MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit commit 5e0a6419cf21d10176339708aa99fc42814461ce Author: DANIEL S. WAGNER Date: Fri Jul 14 11:43:27 2023 -0400 Added TPA warning to exclusions (#33) extrnErrorScan: Added TPA warning regarding mathematical errors to display exclusions commit 4f16935ef71b4818aaf3e758d41b274d10061f58 Author: DANIEL S. WAGNER Date: Thu Jul 13 14:48:28 2023 -0400 Removal of change directory functionality for Q3 (#32) commit 1606bd39d9ba1982498303f33db7662eb656710d Author: DANIEL S. WAGNER Date: Thu Jul 6 16:03:15 2023 -0400 Acadian Update PR22 (#31) Incorporates pull request 22 from open-source repository. Contains no usernames, secrets, passwords, keys or other sensitive information. commit 57dba0314eaf1d7cced827b8dfc9edd937ff74af Author: DANIEL S. WAGNER Date: Wed Jul 5 17:43:32 2023 -0400 Acd update (#30) * externalCallable.R function extnSetRunOptions: slight reorganization and improved error messages fvsRunUtilities.R and server.R Improved error messages and standardized the code that changes a program shared library name to a variant tag. This fixes an error where FVSso.so was being changed to a nonsense code * Added a check in server.R on FVS_Data.db so that it is zero size it is the same as being not present at all. * server.R: If the uploaded data file is empty or does not exist, then it can not be "installed" * R/server.R: One line fixed an if statement as follows: - if (!file.exists(dbGlb$newFVSData)) || file.size(dbGlb$newFVSData) == 0) return() + if (!file.exists(dbGlb$newFVSData) || file.size(dbGlb$newFVSData) == 0) return() inst/extdata/AcadianGY.R and inst/extdata/customRun_fvsRunAcadian.R: Several updates from Ben Rice that fix outstanding issues with the Acadian code and update it to be more efficient. Tested by Ben. * Changes to AcadianGY and /customRun_fvsRunAcadian as sent by Ben Rice plus clean up of trailing white space and line endings. Also applied suggestion to use inherits() for checking for try errors. * ACD version 12.3.1 ACD 12.3.1 # dBA_plot_fun() modified to incorporate new stand basal area increment equation from Aaron Weiskittel # new functions: make_acd_tree(); make_fvs_tree(); make_fvs_regen() to facilitate reading and writing FVS tree lists * Improvements to ACD customRun # New approach to impute height and crown ratio values. # Application of height and diameter increment and mortality modifiers via the fvsGetSpeciesAttrs() function Co-authored-by: Nicholas Crookston Co-authored-by: MidgardNaturalResources commit b110f04c673cad759f10ebb7a626b7598df2d309 Author: DANIEL S. WAGNER Date: Wed Jul 5 16:58:33 2023 -0400 Update to release date in DESCRIPTION file (#29) Added CmpCalibStats filter to LOAD outputs window commit 5c19061f04185ffcda51c68b56f42fd5171a679a Author: DANIEL S. WAGNER Date: Fri Jun 30 08:41:16 2023 -0400 Added [1] to globals$currentEditCmp$reopn[1] to fix a long stand error (#28) in the logical test where globals$currentEditCmp$reopn could have several members. Co-authored-by: Nicholas Crookston commit 3f3b6690a307d29f2b99ff5fc2b488a583378230 Author: Daniel Wagner Date: Thu Jun 29 13:49:34 2023 -0400 Reincluding treeforms commit 4fe5954de4d5276969fa19c1cad77df09b10056a Author: Daniel Wagner Date: Fri Jun 23 08:02:29 2023 -0400 cmpCalibStats small fix Small correction to cmpCalibStats query, update to database description table, and inclusion of shinyFiles R package dependency for file input / output commit 0ed23238d1f3bb5800da415798a64445b2888df2 Author: MICHAEL A. SHETTLES Date: Fri Jun 16 10:11:06 2023 -0600 Cmp calib stats (#27) * Squashed commit of the following: commit 07a9aee26977a50643737ef6ceb0837a3d3dbb3f Merge: faf1542 c171a15 Author: Daniel Wagner Date: Wed May 3 12:18:32 2023 -0400 Merge branch 'development' into staging commit c171a1562c5843265d51666ed7143e38a40d8472 Author: MICHAEL A. SHETTLES Date: Thu Mar 30 05:23:28 2023 -0600 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable commit a91514066278e2136102d8a64ce66445d71fa0a3 Merge: 348cced dc70eb6 Author: MICHAEL A. SHETTLES Date: Wed Mar 29 17:39:37 2023 -0600 Merge pull request #20 from forest-service/_pr15CrookstonDevelopment Pr15 crookston development commit dc70eb67a8b49899afe2c817e15e9689bf8c96d8 Author: Nicholas Crookston Date: Mon Mar 13 16:56:06 2023 -0700 Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. commit ba451694feb15e78112f6a54b55ee95c1c563c52 Author: Nicholas Crookston Date: Mon Mar 13 16:45:59 2023 -0700 Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. commit 20d7e1c38a6aa408f1184ac79928e32c57125cac Merge: e5463fc 348cced Author: Daniel Wagner Date: Fri Feb 24 15:34:01 2023 -0500 Merge branch 'development' of https://code.fs.usda.gov/forest-service/ForestVegetationSimulator-Interface into development commit 348cced1ddce0eaad9ecc6243d58ef8c54c03777 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 13:33:24 2023 -0700 Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) commit e5463fc9801f9691c996ab926aab19ba3279d41f Merge: 18d4719 8e04abb Author: Daniel Wagner Date: Fri Feb 24 14:36:40 2023 -0500 Merge branch 'development' of https://github.com/USDAForestService/ForestVegetationSimulator-Interface into development commit 18d47196a9ae69c733631d11b6081dabe4096039 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 12:29:40 2023 -0700 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list commit 955d5a2ecad8a502f9ee4306e053b6c28d5133b6 Author: MICHAEL A. SHETTLES Date: Thu Feb 16 11:33:06 2023 -0700 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. commit 8e04abb647131018852cd24767a2ee22e109350a Author: Michael Shettles Date: Fri Feb 10 11:48:04 2023 -0700 Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). commit e1b9bfbf09f5417c9face3f63c2788ac9f9a57d3 Author: DANIEL S. WAGNER Date: Mon Feb 6 16:33:44 2023 -0500 Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests commit bee30907733ded48557983a0995f5ea3f69f17e6 Merge: f563c78 6879a78 Author: DANIEL S. WAGNER Date: Thu Feb 2 09:44:52 2023 -0500 Merge pull request #16 from forest-service/Q2FVSCHANGES Round 2 for the changes since Jan 30th. commit 6879a782f155518f7aae0f35f3cfa3776006f506 Author: Michael Shettles Date: Wed Feb 1 16:27:10 2023 -0700 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. commit f563c78550babcc2648522c8b8b99c310ecc1271 Merge: a7063a5 d7514de Author: MICHAEL A. SHETTLES Date: Wed Feb 1 13:13:25 2023 -0700 Merge pull request #14 from forest-service/pr/nickcrookston/14 Pr/nickcrookston/14 commit d7514deff88c951412827f829fc8b753682deb2a Author: Daniel Wagner Date: Wed Feb 1 14:18:01 2023 -0500 Pull Request #14 Updates from NCrookston commit 0b35e4ce5a2872639e2933e5f7dc0bcbced0c9d4 Author: Nicholas Crookston Date: Wed Feb 1 08:41:12 2023 -0800 fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION commit 3c202662c3c1119e626a63e24cb78bbc608c4d00 Author: Nicholas Crookston Date: Wed Feb 1 08:38:43 2023 -0800 rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION commit a7063a5b7905da507c5ff02fb41cdfcc02582aaa Author: Nicholas Crookston Date: Fri Jan 13 15:02:16 2023 -0800 Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. commit 18fa412541b775e4c4adbc64d073437e9a3da8d2 Author: Nicholas Crookston Date: Thu Jan 12 15:49:37 2023 -0800 Fixed a bug I just introduced. commit 3bc464d4fff160ff739173bfbc36ccc47b5b08d6 Author: Nicholas Crookston Date: Thu Jan 12 15:28:20 2023 -0800 Commented out the ability to specify "development" code in new projects. commit 2e84c7904f4efa48966407632d5b5956673eec0a Author: Nicholas Crookston Date: Wed Dec 14 13:25:16 2022 +0100 Finished changes to convert from package sp to sf for spatial data commit 67ac4d5c5c5ec4a8c0ffc5576d6584acb585df39 Author: Nicholas Crookston Date: Tue Dec 13 11:48:42 2022 +0100 Rmeoved "NAMESPACE" from management by the repository commit 96434c5c79990417260288ade4f4667f847047d8 Author: Nicholas Crookston Date: Tue Dec 13 11:46:05 2022 +0100 Started process of adding support of package sf commit 4563c6b81e8593b272e1e92a65195ee4bbfa43e4 Merge: 231904a b3f05a0 Author: Nicholas Crookston Date: Tue Dec 13 10:17:49 2022 +0100 Merge branch 'development' of github.com:USDAForestService/ForestVegetationSimulator-Interface into development Local development branch is out of date with what Mike has commit 231904ad39c2c80312c3ebf5c6be0ab8866f7413 Author: Nicholas Crookston Date: Tue Dec 13 10:08:13 2022 +0100 rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). * Addition of the cmpCalibStats table to the pool of composite tables. This is analogous to the lower table(s) in the legacy calibration statistics post processor that summarized calibration values across stands. The already-existing FVS_CalibStats table is analogous to the top half table of said post processor. sqlQueries.R: added the SQL query code to create the table. databaseDescription.xlsx: added the "cmpCalibStats" sheet for display in the Describe tables dropdown menu. Edited the OutputTableDescriptions" and "GuideLinks" tabs by adding in a line for this new table. server.R: added the code for the new table to show up in the "View outputs > Load > Runs to consider" window, and for it to be categorized correctly in the "Database tables to consider" window. * Updated the 2nd Author in the DESCRIPTION to "FVS Staff". Co-authored-by: mshettles <100229112+mshettles@users.noreply.github.com> Co-authored-by: Daniel Wagner commit bd83701da2cdd1b263ffbd5e7e1ed2f98ab1fea5 Author: Daniel Wagner Date: Fri Jun 16 10:51:08 2023 -0400 Minor updates to sleep timeers commit 4860be93211e328ff1d0fe3af373cf7370bb89b7 Author: DANIEL S. WAGNER Date: Tue Jun 13 16:49:38 2023 -0400 May april crookston updates (#26) * externalCallable.R function extnSetRunOptions: slight reorganization and improved error messages fvsRunUtilities.R and server.R Improved error messages and standardized the code that changes a program shared library name to a variant tag. This fixes an error where FVSso.so was being changed to a nonsense code * Added a check in server.R on FVS_Data.db so that it is zero size it is the same as being not present at all. * server.R: If the uploaded data file is empty or does not exist, then it can not be "installed" * R/server.R: One line fixed an if statement as follows: - if (!file.exists(dbGlb$newFVSData)) || file.size(dbGlb$newFVSData) == 0) return() + if (!file.exists(dbGlb$newFVSData) || file.size(dbGlb$newFVSData) == 0) return() inst/extdata/AcadianGY.R and inst/extdata/customRun_fvsRunAcadian.R: Several updates from Ben Rice that fix outstanding issues with the Acadian code and update it to be more efficient. Tested by Ben. * Changes to AcadianGY and /customRun_fvsRunAcadian as sent by Ben Rice plus clean up of trailing white space and line endings. Also applied suggestion to use inherits() for checking for try errors. Co-authored-by: Nicholas Crookston commit 14b8259be933161e260e583d3907c711f963ed55 Author: DANIEL S. WAGNER Date: Tue Jun 13 13:27:10 2023 -0400 Project directory selection (#25) * Work on adding project directory selection to project management for VDI usage * Update .gitignore * Bringing Main up to 2023 Q2 Status (#17) * rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). * Started process of adding support of package sf * Rmeoved "NAMESPACE" from management by the repository * Finished changes to convert from package sp to sf for spatial data * Commented out the ability to specify "development" code in new projects. * Fixed a bug I just introduced. * Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. * rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION * fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION * Pull Request #14 Updates from NCrookston * 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. * Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. * 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list * Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) * Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. * Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. * 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable --------- Co-authored-by: Nicholas Crookston Co-authored-by: MICHAEL A. SHETTLES * Squashed commit of the following: commit 153b56fc3c08eb79dfd8d0892fa7586bcdcbdb62 Merge: f027b52 e492a4c Author: LANCE R. DAVID Date: Fri Jun 9 12:48:24 2023 -0600 Merge pull request #23 from forest-service/initial-actionbtn-rethink Initial actionbtn rethink commit f027b52985da9ed7a11ae1f49c53492f65207755 Author: MICHAEL A. SHETTLES Date: Fri Jun 9 12:14:31 2023 -0600 Cmp calib stats (#22) * Squashed commit of the following: commit 07a9aee26977a50643737ef6ceb0837a3d3dbb3f Merge: faf1542 c171a15 Author: Daniel Wagner Date: Wed May 3 12:18:32 2023 -0400 Merge branch 'development' into staging commit c171a1562c5843265d51666ed7143e38a40d8472 Author: MICHAEL A. SHETTLES Date: Thu Mar 30 05:23:28 2023 -0600 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable commit a91514066278e2136102d8a64ce66445d71fa0a3 Merge: 348cced dc70eb6 Author: MICHAEL A. SHETTLES Date: Wed Mar 29 17:39:37 2023 -0600 Merge pull request #20 from forest-service/_pr15CrookstonDevelopment Pr15 crookston development commit dc70eb67a8b49899afe2c817e15e9689bf8c96d8 Author: Nicholas Crookston Date: Mon Mar 13 16:56:06 2023 -0700 Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. commit ba451694feb15e78112f6a54b55ee95c1c563c52 Author: Nicholas Crookston Date: Mon Mar 13 16:45:59 2023 -0700 Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. commit 20d7e1c38a6aa408f1184ac79928e32c57125cac Merge: e5463fc 348cced Author: Daniel Wagner Date: Fri Feb 24 15:34:01 2023 -0500 Merge branch 'development' of https://code.fs.usda.gov/forest-service/ForestVegetationSimulator-Interface into development commit 348cced1ddce0eaad9ecc6243d58ef8c54c03777 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 13:33:24 2023 -0700 Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) commit e5463fc9801f9691c996ab926aab19ba3279d41f Merge: 18d4719 8e04abb Author: Daniel Wagner Date: Fri Feb 24 14:36:40 2023 -0500 Merge branch 'development' of https://github.com/USDAForestService/ForestVegetationSimulator-Interface into development commit 18d47196a9ae69c733631d11b6081dabe4096039 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 12:29:40 2023 -0700 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list commit 955d5a2ecad8a502f9ee4306e053b6c28d5133b6 Author: MICHAEL A. SHETTLES Date: Thu Feb 16 11:33:06 2023 -0700 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. commit 8e04abb647131018852cd24767a2ee22e109350a Author: Michael Shettles Date: Fri Feb 10 11:48:04 2023 -0700 Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). commit e1b9bfbf09f5417c9face3f63c2788ac9f9a57d3 Author: DANIEL S. WAGNER Date: Mon Feb 6 16:33:44 2023 -0500 Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests commit bee30907733ded48557983a0995f5ea3f69f17e6 Merge: f563c78 6879a78 Author: DANIEL S. WAGNER Date: Thu Feb 2 09:44:52 2023 -0500 Merge pull request #16 from forest-service/Q2FVSCHANGES Round 2 for the changes since Jan 30th. commit 6879a782f155518f7aae0f35f3cfa3776006f506 Author: Michael Shettles Date: Wed Feb 1 16:27:10 2023 -0700 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. commit f563c78550babcc2648522c8b8b99c310ecc1271 Merge: a7063a5 d7514de Author: MICHAEL A. SHETTLES Date: Wed Feb 1 13:13:25 2023 -0700 Merge pull request #14 from forest-service/pr/nickcrookston/14 Pr/nickcrookston/14 commit d7514deff88c951412827f829fc8b753682deb2a Author: Daniel Wagner Date: Wed Feb 1 14:18:01 2023 -0500 Pull Request #14 Updates from NCrookston commit 0b35e4ce5a2872639e2933e5f7dc0bcbced0c9d4 Author: Nicholas Crookston Date: Wed Feb 1 08:41:12 2023 -0800 fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION commit 3c202662c3c1119e626a63e24cb78bbc608c4d00 Author: Nicholas Crookston Date: Wed Feb 1 08:38:43 2023 -0800 rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION commit a7063a5b7905da507c5ff02fb41cdfcc02582aaa Author: Nicholas Crookston Date: Fri Jan 13 15:02:16 2023 -0800 Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. commit 18fa412541b775e4c4adbc64d073437e9a3da8d2 Author: Nicholas Crookston Date: Thu Jan 12 15:49:37 2023 -0800 Fixed a bug I just introduced. commit 3bc464d4fff160ff739173bfbc36ccc47b5b08d6 Author: Nicholas Crookston Date: Thu Jan 12 15:28:20 2023 -0800 Commented out the ability to specify "development" code in new projects. commit 2e84c7904f4efa48966407632d5b5956673eec0a Author: Nicholas Crookston Date: Wed Dec 14 13:25:16 2022 +0100 Finished changes to convert from package sp to sf for spatial data commit 67ac4d5c5c5ec4a8c0ffc5576d6584acb585df39 Author: Nicholas Crookston Date: Tue Dec 13 11:48:42 2022 +0100 Rmeoved "NAMESPACE" from management by the repository commit 96434c5c79990417260288ade4f4667f847047d8 Author: Nicholas Crookston Date: Tue Dec 13 11:46:05 2022 +0100 Started process of adding support of package sf commit 4563c6b81e8593b272e1e92a65195ee4bbfa43e4 Merge: 231904a b3f05a0 Author: Nicholas Crookston Date: Tue Dec 13 10:17:49 2022 +0100 Merge branch 'development' of github.com:USDAForestService/ForestVegetationSimulator-Interface into development Local development branch is out of date with what Mike has commit 231904ad39c2c80312c3ebf5c6be0ab8866f7413 Author: Nicholas Crookston Date: Tue Dec 13 10:08:13 2022 +0100 rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). * Addition of the cmpCalibStats table to the pool of composite tables. This is analogous to the lower table(s) in the legacy calibration statistics post processor that summarized calibration values across stands. The already-existing FVS_CalibStats table is analogous to the top half table of said post processor. sqlQueries.R: added the SQL query code to create the table. databaseDescription.xlsx: added the "cmpCalibStats" sheet for display in the Describe tables dropdown menu. Edited the OutputTableDescriptions" and "GuideLinks" tabs by adding in a line for this new table. server.R: added the code for the new table to show up in the "View outputs > Load > Runs to consider" window, and for it to be categorized correctly in the "Database tables to consider" window. Co-authored-by: mshettles <100229112+mshettles@users.noreply.github.com> Co-authored-by: Daniel Wagner commit e492a4c184c32f24c43d833575be6f0e7aaa07a1 Author: Daniel Wagner Date: Wed May 3 09:53:35 2023 -0400 Updated server side notification modals to be consistant with other UI triggered modals commit 1fca5c01414a5b719facd2b43a3abd87c2222c7e Author: Daniel Wagner Date: Tue Apr 25 15:21:00 2023 -0400 Initial updates to action buttons for calls to 'add selected stand', 'add selected groups' to prevent population of dropdowns when no stands or groups were selected. Added updates to 'save in run' button when adding manaement / modifier / event monitor / or kcp components to prevent component from saving to an empty run contents window (including user feedback). Added user feedback to 'Save and Run' button when Run Contents Window is empty * Update to project selection updates to fvsOL and ability for user to save and open from user specified locations * Delete fvsOL_2023.05.18.tar.gz * Delete rFVS_2023.02.01.tar.gz * Removed unwanted files marked in .gitignore Co-authored-by: mshettles <100229112+mshettles@users.noreply.github.com> Co-authored-by: wagnerds <100228553+wagnerds@users.noreply.github.com> Co-authored-by: Nicholas Crookston Co-authored-by: MICHAEL A. SHETTLES commit 153b56fc3c08eb79dfd8d0892fa7586bcdcbdb62 Merge: f027b52 e492a4c Author: LANCE R. DAVID Date: Fri Jun 9 12:48:24 2023 -0600 Merge pull request #23 from forest-service/initial-actionbtn-rethink Initial actionbtn rethink commit f027b52985da9ed7a11ae1f49c53492f65207755 Author: MICHAEL A. SHETTLES Date: Fri Jun 9 12:14:31 2023 -0600 Cmp calib stats (#22) * Squashed commit of the following: commit 07a9aee26977a50643737ef6ceb0837a3d3dbb3f Merge: faf1542 c171a15 Author: Daniel Wagner Date: Wed May 3 12:18:32 2023 -0400 Merge branch 'development' into staging commit c171a1562c5843265d51666ed7143e38a40d8472 Author: MICHAEL A. SHETTLES Date: Thu Mar 30 05:23:28 2023 -0600 1) Updated the example text under the SQLout window (#21) 2) Fixed the Lory's height EM variable calculation so that it inserts the correct variable commit a91514066278e2136102d8a64ce66445d71fa0a3 Merge: 348cced dc70eb6 Author: MICHAEL A. SHETTLES Date: Wed Mar 29 17:39:37 2023 -0600 Merge pull request #20 from forest-service/_pr15CrookstonDevelopment Pr15 crookston development commit dc70eb67a8b49899afe2c817e15e9689bf8c96d8 Author: Nicholas Crookston Date: Mon Mar 13 16:56:06 2023 -0700 Removed NAMESPACE from being tracked by git. It is automatically built when R builds the package. commit ba451694feb15e78112f6a54b55ee95c1c563c52 Author: Nicholas Crookston Date: Mon Mar 13 16:45:59 2023 -0700 Modified R/externalCallable.R to add the ability to delete stands and modified the function that lists stands to return a data.frame that has the stand uuid as well as the standid. Modified fvsRunAadian to not use fvsStopPoint 7. The stoppoint works, but what we were trying to accomplish was not getting done. commit 20d7e1c38a6aa408f1184ac79928e32c57125cac Merge: e5463fc 348cced Author: Daniel Wagner Date: Fri Feb 24 15:34:01 2023 -0500 Merge branch 'development' of https://code.fs.usda.gov/forest-service/ForestVegetationSimulator-Interface into development commit 348cced1ddce0eaad9ecc6243d58ef8c54c03777 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 13:33:24 2023 -0700 Update of "Release date" for upper right panel in GUI to read 20230518 for upcoming Q2 release. (#19) commit e5463fc9801f9691c996ab926aab19ba3279d41f Merge: 18d4719 8e04abb Author: Daniel Wagner Date: Fri Feb 24 14:36:40 2023 -0500 Merge branch 'development' of https://github.com/USDAForestService/ForestVegetationSimulator-Interface into development commit 18d47196a9ae69c733631d11b6081dabe4096039 Author: MICHAEL A. SHETTLES Date: Fri Feb 24 12:29:40 2023 -0700 1) Added keyword windows for the REGREPTS and INVSTATS DBS keywords (#18) 2) Added the new BHTWTBA and AHTWTBA Event Monitor variables to the "Variables" dropdown list commit 955d5a2ecad8a502f9ee4306e053b6c28d5133b6 Author: MICHAEL A. SHETTLES Date: Thu Feb 16 11:33:06 2023 -0700 2023 q2 shettles final (#17) * Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). * The BurnReDB database keyword was still being displayed as BurnRept in the Keywords menu dropdown menu list. * Removal of a browser() command from code. commit 8e04abb647131018852cd24767a2ee22e109350a Author: Michael Shettles Date: Fri Feb 10 11:48:04 2023 -0700 Bug fixes (fvsOL): • When trying to import a project backup the check for a blank/null INV_YEAR field in the input database was causing a crash if the column name for that variables was not upper case. The tolower() function was added to coerce it to lower case for even comparison of all casings of that variable. • The keyword writing code was missing logic to handle when a conditional was following a previous conditional that had multiple non-base keywords. • When deleting the only stand from a run that had components attached to groups (thus creating a blank-appearing run), the components were being inherited by any subsequently-added stands. This made sense for runs with multiple stands (where deleting one stand didn’t result in a blank run) but was deemed confusing (since adding stands into a blank run should not carry any keyword inheritance). Now, any groups & their associated keywords associated with the stand being deleted from a single-stand run are now removed from the run upon clicking “Cut/delete”. • The sumOnSpecies indicator variable in the graphing code was not setup to accommodate the 3 newer species codes (SpeciesFVS, SpeciesPLANTS, SpeciesFIA) resulting in plots containing any one of those 3 variables were resulting in erroneously large Y-axis values (e.g., 4000ft tall trees). commit e1b9bfbf09f5417c9face3f63c2788ac9f9a57d3 Author: DANIEL S. WAGNER Date: Mon Feb 6 16:33:44 2023 -0500 Update fvsRunUtilities.R Fixing inadvertent overwrite when merging multiple pull requests commit bee30907733ded48557983a0995f5ea3f69f17e6 Merge: f563c78 6879a78 Author: DANIEL S. WAGNER Date: Thu Feb 2 09:44:52 2023 -0500 Merge pull request #16 from forest-service/Q2FVSCHANGES Round 2 for the changes since Jan 30th. commit 6879a782f155518f7aae0f35f3cfa3776006f506 Author: Michael Shettles Date: Wed Feb 1 16:27:10 2023 -0700 1. When trying to manually add the RRTREIN and BBCLEAR root disease keywords a crash was occurring. 2. When trying to add in the THINRDSL keyword into the Run contents using a non-NE variant, a crash was occurring (keyword only applies to the NE variant). 3. When trying to import a custom SQL query using the Import runs and other items, a crash was occurring, and the query was also not showing up in the Custom query menu after import. 4. Improvements to the SQLIN/SQLOUT database keyword windows: a. Updated example text & code was added to below the windows b. A column ruler was added to be above the editor window c. The needed DATABASE/END keywords are now automatically added around the query when building the keyword file at run time (they were previously being tagged as “base” instead of “dbs”) 5. The “Rebuild StdStk” button now works in that if a run containing a StdStk (or cmpStdStk) table is pre-selected in the “Runs to consider” window, and then the “Rebuild StdStk” button is clicked after changing the “DBH class size” and/or “Large DBH” values, the “DBHClasses” under the Explore menu are immediately updated. Previously, a run had to not be selected before changing either of those values, and then a run selected, for the changes to then reflect under the Explore menu. 6. A logical variables was added to the keyword writing function to prevent two successive END keywords from being written that was happening when a base keyword was following a conditionally-scheduled non-base keyword. commit f563c78550babcc2648522c8b8b99c310ecc1271 Merge: a7063a5 d7514de Author: MICHAEL A. SHETTLES Date: Wed Feb 1 13:13:25 2023 -0700 Merge pull request #14 from forest-service/pr/nickcrookston/14 Pr/nickcrookston/14 commit d7514deff88c951412827f829fc8b753682deb2a Author: Daniel Wagner Date: Wed Feb 1 14:18:01 2023 -0500 Pull Request #14 Updates from NCrookston commit 0b35e4ce5a2872639e2933e5f7dc0bcbced0c9d4 Author: Nicholas Crookston Date: Wed Feb 1 08:41:12 2023 -0800 fvsOL: Fixed a bug that caused a warning in some cases when a run's variant was not set, modified the code that runs the Acadian variant so that fvs tree ids are maintained (the trees were being renumbered). Updated the revision tag in DESCRIPTION commit 3c202662c3c1119e626a63e24cb78bbc608c4d00 Author: Nicholas Crookston Date: Wed Feb 1 08:38:43 2023 -0800 rFVS: Improved the documentation for fvs[Get|Set]SpeciesAttrs, reset the revision date in DESCRIPRTION commit a7063a5b7905da507c5ff02fb41cdfcc02582aaa Author: Nicholas Crookston Date: Fri Jan 13 15:02:16 2023 -0800 Removed the use of R-dev as an installation library (a change to the makefiles) This restores the code to a previous version. commit 18fa412541b775e4c4adbc64d073437e9a3da8d2 Author: Nicholas Crookston Date: Thu Jan 12 15:49:37 2023 -0800 Fixed a bug I just introduced. commit 3bc464d4fff160ff739173bfbc36ccc47b5b08d6 Author: Nicholas Crookston Date: Thu Jan 12 15:28:20 2023 -0800 Commented out the ability to specify "development" code in new projects. commit 2e84c7904f4efa48966407632d5b5956673eec0a Author: Nicholas Crookston Date: Wed Dec 14 13:25:16 2022 +0100 Finished changes to convert from package sp to sf for spatial data commit 67ac4d5c5c5ec4a8c0ffc5576d6584acb585df39 Author: Nicholas Crookston Date: Tue Dec 13 11:48:42 2022 +0100 Rmeoved "NAMESPACE" from management by the repository commit 96434c5c79990417260288ade4f4667f847047d8 Author: Nicholas Crookston Date: Tue Dec 13 11:46:05 2022 +0100 Started process of adding support of package sf commit 4563c6b81e8593b272e1e92a65195ee4bbfa43e4 Merge: 231904a b3f05a0 Author: Nicholas Crookston Date: Tue Dec 13 10:17:49 2022 +0100 Merge branch 'development' of github.com:USDAForestService/ForestVegetationSimulator-Interface into development Local development branch is out of date with what Mike has commit 231904ad39c2c80312c3ebf5c6be0ab8866f7413 Author: Nicholas Crookston Date: Tue Dec 13 10:08:13 2022 +0100 rFVS: added fvsCutNow and fvsMakeyFile functions, Fixed a typo in fvsAddActivity, added the ability to set/get "special" tree tag and kutkod used in prescription thinnings. fvsOL: modified code to support package sf (more work to do on this). * Addition of the cmpCalibStats table to the pool of composite tables. This is analogous to the lower table(s) in the legacy calibration statistics post processor that summarized calibration values across stands. The already-existing FVS_CalibStats table is analogous to the top half table of said post processor. sqlQueries.R: added the SQL query code to create the table. databaseDescription.xlsx: added the "cmpCalibStats" sheet for display in the Describe tables dropdown menu. Edited the OutputTableDescriptions" and "GuideLinks" tabs by adding in a line for this new table. server.R: added the code for the new table to show up in the "View outputs > Load > Runs to consider" window, and for it to be categorized correctly in the "Database tables to consider" window. Co-authored-by: mshettles <100229112+mshettles@users.noreply.github.com> Co-authored-by: Daniel Wagner commit e492a4c184c32f24c43d833575be6f0e7aaa07a1 Author: Daniel Wagner Date: Wed May 3 09:53:35 2023 -0400 Updated server side notification modals to be consistant with other UI triggered modals commit 1fca5c01414a5b719facd2b43a3abd87c2222c7e Author: Daniel Wagner Date: Tue Apr 25 15:21:00 2023 -0400 Initial updates to action buttons for calls to 'add selected stand', 'add selected groups' to prevent population of dropdowns when no stands or groups were selected. Added updates to 'save in run' button when adding manaement / modifier / event monitor / or kcp components to prevent component from saving to an empty run contents window (including user feedback). Added user feedback to 'Save and Run' button when Run Contents Window is empty --- .github/CODEOWNERS | 10 +- .gitignore | 20 + FVSDataConvert/www/message-handler.js | 122 +- FVSPrjBldr/prjListEmail.R | 162 +- FVSPrjBldr/uuidgen.R | 98 +- fvsOL/DESCRIPTION | 4 +- fvsOL/R/externalCallable.R | 7 +- fvsOL/R/fvsRunUtilities.R | 11 +- fvsOL/R/modalDialog.R | 49 +- fvsOL/R/server.R | 16774 ++++++++-------- fvsOL/R/svsTree.R | 846 +- fvsOL/R/ui.R | 65 +- fvsOL/inst/extdata/AcadianGY.R | 4423 ++-- fvsOL/inst/extdata/customRun_fvsRunAcadian.R | 186 +- .../inst/extdata/customRun_fvsRunAdirondack.R | 422 +- fvsOL/inst/extdata/databaseDescription.xlsx | Bin 220726 -> 222403 bytes fvsOL/inst/extdata/fvsOnlineHelp.html | 966 +- fvsOL/inst/extdata/mkhelp.R | 186 +- fvsOL/inst/extdata/runScripts.R | 46 +- fvsOL/inst/extdata/sqlQueries.R | 52 +- fvsOL/inst/extdata/sqlQueries_Metric.R | 828 +- fvsOL/inst/extdata/www/message-handler.js | 330 +- fvsOL/makefile | 4 +- fvsOL/parms/HabPa_oc.prm | 190 +- fvsOL/parms/forest.prm | 1 + fvsOL/parms/habpa_op.prm | 164 +- fvsOL/parms/mkpkeys.R | 650 +- fvsOL/parms/org.kwd | 280 +- rFVS/DESCRIPTION | 2 +- rFVS/R/fvsAddActivity.R | 168 +- rFVS/R/fvsAddTrees.R | 88 +- rFVS/R/fvsCompositeSum.R | 212 +- rFVS/R/fvsGetDims.R | 38 +- rFVS/R/fvsGetEventMonitorVariables.R | 122 +- rFVS/R/fvsGetRestartcode.R | 34 +- rFVS/R/fvsGetSVSDims.R | 38 +- rFVS/R/fvsGetSVSObjectSet.R | 244 +- rFVS/R/fvsGetSpeciesCodes.R | 56 +- rFVS/R/fvsGetStandIDs.R | 30 +- rFVS/R/fvsGetSummary.R | 60 +- rFVS/R/fvsGetTreeAttrs.R | 116 +- rFVS/R/fvsGetUnitConversion.R | 102 +- rFVS/R/fvsInteractRun.R | 320 +- rFVS/R/fvsRun.R | 102 +- rFVS/R/fvsSetCmdLine.R | 38 +- rFVS/R/fvsSetTreeAttr.R | 92 +- rFVS/R/fvsSetupSummary.R | 86 +- rFVS/tests/iet01.key | 130 +- rFVS/tests/iet01.tre | 60 +- 49 files changed, 14862 insertions(+), 14172 deletions(-) create mode 100644 .gitignore diff --git a/.github/CODEOWNERS b/.github/CODEOWNERS index 73de209..5c36976 100644 --- a/.github/CODEOWNERS +++ b/.github/CODEOWNERS @@ -1,5 +1,5 @@ -# Comment line are preceeded by hash symbol -# Each line is a file pattern followed by one or more owners. - -# Default repo owners take precdence, unless subsequent match -* @mshettles @DavidLRfs @wagnerds +# Comment line are preceeded by hash symbol +# Each line is a file pattern followed by one or more owners. + +# Default repo owners take precdence, unless subsequent match +* @mshettles @DavidLRfs @wagnerds diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..9594114 --- /dev/null +++ b/.gitignore @@ -0,0 +1,20 @@ + +.RData +.Rhistory +.Rproj.user/* +BuildfvsOL.R +ForestVegetationSimulator-Interface.Rproj +fvsOL/.Rhistory +fvsOL/LaunchFVS.R +build_fvsOL.R +fvsOL/data/fvsOnlineHelpRender.RData +fvsOL/data/prms.RData +fvsOL/launch.R +fvsOL/NAMESPACE +rFVS/NAMESPACE +rFVS/rFVSmadeTag +fvsOL/fvsOLmadeTag +fvsOL/man/* +rFVS/man/* +*.gz +.Rproj.user diff --git a/FVSDataConvert/www/message-handler.js b/FVSDataConvert/www/message-handler.js index 0e17cbc..911fd38 100644 --- a/FVSDataConvert/www/message-handler.js +++ b/FVSDataConvert/www/message-handler.js @@ -1,61 +1,61 @@ -(function() { - -// This recieves messages of type "dialogContentUpdate" from the server. -Shiny.addCustomMessageHandler("dialogContentUpdate", - function(data) { - $('#' + data.id).find(".modal-body").html(data.message); - } -); - -// This recieves messages of type "infomessage" from the server. -Shiny.addCustomMessageHandler("infomessage", - function(message) { alert(message); } -); - -// Refocus "eltid" -Shiny.addCustomMessageHandler("refocus", - function(eltid) { document.getElementById(eltid).focus(); } -); - - -// This gets the cursor postion from eltid -Shiny.addCustomMessageHandler("getStart", - function(eltid) - { - if (document.getElementById(eltid)) - { - document.getElementById(eltid).onmouseout = function() - { - Shiny.onInputChange("selectionStart", document.getElementById(eltid).selectionStart); - Shiny.onInputChange("selectionEnd", document.getElementById(eltid).selectionEnd); - } - } - } -); - -// This will attempt to open a new tab with the provided URL -// add: session$sendCustomMessage(type = "openURL",url) anywhere in the server code. -Shiny.addCustomMessageHandler("openURL", - function (url) { window.open(url); } -); - -// This will close the window, it causes onSessionEnded to be called as well. -// add: session$sendCustomMessage(type = "closeWindow"," ") anywhere in the server code. -Shiny.addCustomMessageHandler("closeWindow", - function (dummy) { window.close(); } -); - -// this function load causes a shiny variable "signalClosing" to be set to 1 if the -// browser is being closed for any reason. NB: return null will suppress the "do you -// really want to exit" dialog automatically created by the browser. -window.onbeforeunload = function(e) -{ - Shiny.onInputChange("signalClosing", 1); - return null; -}; - - - -})(); - - +(function() { + +// This recieves messages of type "dialogContentUpdate" from the server. +Shiny.addCustomMessageHandler("dialogContentUpdate", + function(data) { + $('#' + data.id).find(".modal-body").html(data.message); + } +); + +// This recieves messages of type "infomessage" from the server. +Shiny.addCustomMessageHandler("infomessage", + function(message) { alert(message); } +); + +// Refocus "eltid" +Shiny.addCustomMessageHandler("refocus", + function(eltid) { document.getElementById(eltid).focus(); } +); + + +// This gets the cursor postion from eltid +Shiny.addCustomMessageHandler("getStart", + function(eltid) + { + if (document.getElementById(eltid)) + { + document.getElementById(eltid).onmouseout = function() + { + Shiny.onInputChange("selectionStart", document.getElementById(eltid).selectionStart); + Shiny.onInputChange("selectionEnd", document.getElementById(eltid).selectionEnd); + } + } + } +); + +// This will attempt to open a new tab with the provided URL +// add: session$sendCustomMessage(type = "openURL",url) anywhere in the server code. +Shiny.addCustomMessageHandler("openURL", + function (url) { window.open(url); } +); + +// This will close the window, it causes onSessionEnded to be called as well. +// add: session$sendCustomMessage(type = "closeWindow"," ") anywhere in the server code. +Shiny.addCustomMessageHandler("closeWindow", + function (dummy) { window.close(); } +); + +// this function load causes a shiny variable "signalClosing" to be set to 1 if the +// browser is being closed for any reason. NB: return null will suppress the "do you +// really want to exit" dialog automatically created by the browser. +window.onbeforeunload = function(e) +{ + Shiny.onInputChange("signalClosing", 1); + return null; +}; + + + +})(); + + diff --git a/FVSPrjBldr/prjListEmail.R b/FVSPrjBldr/prjListEmail.R index ecc2192..9a4cb04 100644 --- a/FVSPrjBldr/prjListEmail.R +++ b/FVSPrjBldr/prjListEmail.R @@ -1,81 +1,81 @@ -prjListEmail <- function (queryEmail,ndays=60,sendEmail=TRUE) -{ - ## This funciton needs to be customized a noted below! - - # Send an Email of the projects associated with an email address - # to the email address. The Email address must be a match (case insensitive) - # to the one sepecified when the project was created. - - trim <- function (x) gsub("^\\s+|\\s+$","",x) - - if (missing(queryEmail)) stop("queryEmail must be specified") - # insure a single token, no blanks - queryEmail = scan(text=queryEmail,what="character",quiet=TRUE) - if (length(queryEmail) > 1) stop ("queryEmail string contains white space") - - workDirs = list.dirs("/home/shiny/FVSwork",recursive = FALSE) - ids = lapply(workDirs,function (x) - { - fn = paste0(x,"/projectId.txt") - id = NULL - if (file.exists(fn)) - { - id = scan(file=fn,what="character", - sep="\n",quiet=TRUE) - if (!is.null(id)) - { - info = file.info(x) - attr(id,"ctime") = info[1,"ctime"] - info = file.info(fn) - attr(id,"mtime") = info[1,"mtime"] - } - } - id - }) -##The following line needs to be edited and uncommented to replace the -##base web address string in the substitution - names (ids) = sub("/home/shiny/FVSwork", - "https://charcoal2.cnre.vt.edu/FVSwork",workDirs) - - rptFile = tempfile() - con = file(rptFile,"w") - - cat (file=con,"To:",queryEmail,"\n") - cat (file=con,"Subject: FVSOnline projects at Virginia Tech\n") - cat (file=con,"\n Projects and links for Email:",queryEmail,"\n") - nprjs = 0 - for (i in 1:length(ids)) - { - id = unlist(ids[i]) - nam = names(ids[i]) - if (is.null(id)) next - email = trim(scan(text=id[1],what="character",quiet=TRUE)[2]) - if (tolower(email) == tolower(queryEmail)) - { - nprjs = nprjs+1 - cat (file=con,"\n",id[1],"\n",id[2],"\n") - tt = format(attr(ids[i][[1]],"ctime"),usetz=TRUE) - cat (file=con," created at = ",tt,"\n") - tt = format(attr(ids[i][[1]],"mtime"),usetz=TRUE) - cat (file=con," last modified= ",tt,"\n") - tt = format(attr(ids[i][[1]],"mtime")+(86400*ndays),usetz=TRUE)#86400=seconds/day - cat (file=con," auto removal = ",tt,"\n") - cat (file=con," project link = ",nam,"\n") - } - } - - if (nprjs == 0) cat (file=con,"\n There are no projects under this Email address.\n") - if (nprjs == 1) cat (file=con,"\n There is one project under this Email address.\n") - if (nprjs > 1) cat (file=con,"\n There are",nprjs, - "projects under this Email address.\n") - close(con) - -##Edit and uncomment the mailCmd as necessary for a given installation - mailCmd = paste('ssmtp -t < ',rptFile) - - if (sendEmail) system (mailCmd) else system(paste("cat",rptFile)) - unlink (rptFile) - nprjs -} - - +prjListEmail <- function (queryEmail,ndays=60,sendEmail=TRUE) +{ + ## This funciton needs to be customized a noted below! + + # Send an Email of the projects associated with an email address + # to the email address. The Email address must be a match (case insensitive) + # to the one sepecified when the project was created. + + trim <- function (x) gsub("^\\s+|\\s+$","",x) + + if (missing(queryEmail)) stop("queryEmail must be specified") + # insure a single token, no blanks + queryEmail = scan(text=queryEmail,what="character",quiet=TRUE) + if (length(queryEmail) > 1) stop ("queryEmail string contains white space") + + workDirs = list.dirs("/home/shiny/FVSwork",recursive = FALSE) + ids = lapply(workDirs,function (x) + { + fn = paste0(x,"/projectId.txt") + id = NULL + if (file.exists(fn)) + { + id = scan(file=fn,what="character", + sep="\n",quiet=TRUE) + if (!is.null(id)) + { + info = file.info(x) + attr(id,"ctime") = info[1,"ctime"] + info = file.info(fn) + attr(id,"mtime") = info[1,"mtime"] + } + } + id + }) +##The following line needs to be edited and uncommented to replace the +##base web address string in the substitution + names (ids) = sub("/home/shiny/FVSwork", + "https://charcoal2.cnre.vt.edu/FVSwork",workDirs) + + rptFile = tempfile() + con = file(rptFile,"w") + + cat (file=con,"To:",queryEmail,"\n") + cat (file=con,"Subject: FVSOnline projects at Virginia Tech\n") + cat (file=con,"\n Projects and links for Email:",queryEmail,"\n") + nprjs = 0 + for (i in 1:length(ids)) + { + id = unlist(ids[i]) + nam = names(ids[i]) + if (is.null(id)) next + email = trim(scan(text=id[1],what="character",quiet=TRUE)[2]) + if (tolower(email) == tolower(queryEmail)) + { + nprjs = nprjs+1 + cat (file=con,"\n",id[1],"\n",id[2],"\n") + tt = format(attr(ids[i][[1]],"ctime"),usetz=TRUE) + cat (file=con," created at = ",tt,"\n") + tt = format(attr(ids[i][[1]],"mtime"),usetz=TRUE) + cat (file=con," last modified= ",tt,"\n") + tt = format(attr(ids[i][[1]],"mtime")+(86400*ndays),usetz=TRUE)#86400=seconds/day + cat (file=con," auto removal = ",tt,"\n") + cat (file=con," project link = ",nam,"\n") + } + } + + if (nprjs == 0) cat (file=con,"\n There are no projects under this Email address.\n") + if (nprjs == 1) cat (file=con,"\n There is one project under this Email address.\n") + if (nprjs > 1) cat (file=con,"\n There are",nprjs, + "projects under this Email address.\n") + close(con) + +##Edit and uncomment the mailCmd as necessary for a given installation + mailCmd = paste('ssmtp -t < ',rptFile) + + if (sendEmail) system (mailCmd) else system(paste("cat",rptFile)) + unlink (rptFile) + nprjs +} + + diff --git a/FVSPrjBldr/uuidgen.R b/FVSPrjBldr/uuidgen.R index 7833a7a..9c5b643 100644 --- a/FVSPrjBldr/uuidgen.R +++ b/FVSPrjBldr/uuidgen.R @@ -1,49 +1,49 @@ -uuidgen <- function (n=1) -{ -# generate a version 4 uuid using R's random number generator and a -# special seed/status. -# example: "36d3054f-553b-4f52-ac3f-b1a028f3dfa8" - -# designed to make it almost impossible to cause this generator -# to generate a duplicate...even when the user first calls set.seed -# and does not have package digest. - -# NLCrookston, Dec 2014. - - ss <- if (exists(".Random.seed",envir=.GlobalEnv)) - get(".Random.seed",envir=.GlobalEnv) else NULL - cp <- Sys.getpid() - if (exists(".uuid.seedpid",envir=.GlobalEnv) && - get(".uuid.seedpid",envir=.GlobalEnv) == cp && - exists(".uuid.seed", envir=.GlobalEnv)) - .Random.seed <<- get(".uuid.seed",envir=.GlobalEnv) else - { - .uuid.seedpid <<- cp - if (file.exists("/dev/random")) { - rn <- file ("/dev/random",open="rb",raw=TRUE) - set.seed(readBin(rn,"integer")) - close(rn) - } else - { - if (require (digest,quietly=TRUE)) { - i <- as.integer(runif(1,min=1,max=32-7)) - dig <- paste0("0x",substring(digest(Sys.getenv()),i,i+6)) - dig <- strtoi(dig) * if (strtoi(substring(dig,1,3)) %% 2) 1 else -1 - } else dig <- 1 - set.seed(as.integer(Sys.time())+cp+as.integer(runif(1)*1000)+dig) - } - } - uuid <- vector("character",n) - for (i in 1:n) { - rnum = runif(4) - rstr <- substring(sprintf("%.8a",rnum),5,12) - uuid[i] <- sprintf("%s-%s-4%s%s%s-%s%s",rstr[1],substring(rstr[2],1,4), - substring(rstr[2],5,7), - c("-8","-9","-a","-b","-8")[as.integer(rnum[1]*4)+1], - substring(rstr[3],1,3),substring(rstr[3],4,7),rstr[4]) - } - .uuid.seed <<- .Random.seed - if (is.null(ss)) rm(.Random.seed,envir=.GlobalEnv) else .Random.seed <<- ss - uuid -} - +uuidgen <- function (n=1) +{ +# generate a version 4 uuid using R's random number generator and a +# special seed/status. +# example: "36d3054f-553b-4f52-ac3f-b1a028f3dfa8" + +# designed to make it almost impossible to cause this generator +# to generate a duplicate...even when the user first calls set.seed +# and does not have package digest. + +# NLCrookston, Dec 2014. + + ss <- if (exists(".Random.seed",envir=.GlobalEnv)) + get(".Random.seed",envir=.GlobalEnv) else NULL + cp <- Sys.getpid() + if (exists(".uuid.seedpid",envir=.GlobalEnv) && + get(".uuid.seedpid",envir=.GlobalEnv) == cp && + exists(".uuid.seed", envir=.GlobalEnv)) + .Random.seed <<- get(".uuid.seed",envir=.GlobalEnv) else + { + .uuid.seedpid <<- cp + if (file.exists("/dev/random")) { + rn <- file ("/dev/random",open="rb",raw=TRUE) + set.seed(readBin(rn,"integer")) + close(rn) + } else + { + if (require (digest,quietly=TRUE)) { + i <- as.integer(runif(1,min=1,max=32-7)) + dig <- paste0("0x",substring(digest(Sys.getenv()),i,i+6)) + dig <- strtoi(dig) * if (strtoi(substring(dig,1,3)) %% 2) 1 else -1 + } else dig <- 1 + set.seed(as.integer(Sys.time())+cp+as.integer(runif(1)*1000)+dig) + } + } + uuid <- vector("character",n) + for (i in 1:n) { + rnum = runif(4) + rstr <- substring(sprintf("%.8a",rnum),5,12) + uuid[i] <- sprintf("%s-%s-4%s%s%s-%s%s",rstr[1],substring(rstr[2],1,4), + substring(rstr[2],5,7), + c("-8","-9","-a","-b","-8")[as.integer(rnum[1]*4)+1], + substring(rstr[3],1,3),substring(rstr[3],4,7),rstr[4]) + } + .uuid.seed <<- .Random.seed + if (is.null(ss)) rm(.Random.seed,envir=.GlobalEnv) else .Random.seed <<- ss + uuid +} + diff --git a/fvsOL/DESCRIPTION b/fvsOL/DESCRIPTION index 216ab85..9b5a802 100644 --- a/fvsOL/DESCRIPTION +++ b/fvsOL/DESCRIPTION @@ -1,9 +1,9 @@ Package: fvsOL Title: Forest Vegetation Simulator -Version: 2023.05.18 +Version: 2023.07.28 Authors@R: c(person("Nicholas", "Crookston", email = "ncrookston.fs@gmail.com", role = c("aut")), - person("Michael", "Shettles", email = "michael.a.shettles@usda.gov", + person("FVS", "Staff", email = "sm.fs.fvs-support@usda.gov", role = c("aut", "cre"))) Description: An R-Shiny interface to the Forest Vegetation Simulator which can be run as an "Online" or "Onlocal" configuration. diff --git a/fvsOL/R/externalCallable.R b/fvsOL/R/externalCallable.R index 67e0bdd..97c7422 100644 --- a/fvsOL/R/externalCallable.R +++ b/fvsOL/R/externalCallable.R @@ -438,14 +438,14 @@ extnAddComponentKwds <- function(prjDir=getwd(),runUUID,cmps,groups=NULL,stands= extnSetRunOptions <- function(prjDir=getwd(),runUUID,autoOut=NULL,svsOut=NULL, startyr=NULL,endyr=NULL,cyclelen=NULL,cycleat=NULL) { - changed=FALSE if (missing(runUUID)) stop("runUUID required") + changed=FALSE prjDir = normalizePath(prjDir) if (file.exists(file.path(prjDir,"/projectIsLocked.txt"))) stop("project is locked") db = connectFVSProjectDB(prjDir) on.exit(dbDisconnect(db)) fvsRun = loadFVSRun(db,runUUID) - if (!exists("fvsRun")) stop("runUUID run data not loaded") + if (!exists("fvsRun")) stop(paste0(runUUID," run data not loaded")) if (attr(class(fvsRun),"package") != "fvsOL") stop("Don't recognize the loaded object") if (!is.null(autoOut)) { @@ -457,7 +457,7 @@ extnSetRunOptions <- function(prjDir=getwd(),runUUID,autoOut=NULL,svsOut=NULL, autoRD_Det = "RD_Det", autoRD_Beetle = "RD_Beetle", autoInvStats = "InvStats", autoRegen = "Regen", autoDelOTab = "KeepTextTables") set=intersect(tolower(autoOut),tolower(autoSets)) - if (length(set)==0) warning(paste0("autoOut does not contains one or more of: ", + if (length(set)==0) warning(paste0("autoOut does not contain one or more of: ", paste0(autoSets,collapse=", "))) else { set = charmatch(set,tolower(autoSets)) @@ -1170,6 +1170,7 @@ extnErrorScan <- function (outfile) { if (length(grep("STANDARD ERRORS",toupper(line),fixed=TRUE))) next if (length(grep("SAMPLING",toupper(line),fixed=TRUE))) next + if (length(grep("MAY CAUSE MATHEMATICAL ERRORS", toupper(line), fixed = TRUE))) next err <- c(l1,line) names(err) <- paste0("Std=",sid,";Line=",as.character(c(ln-1,ln))) errs<-append(errs,err) diff --git a/fvsOL/R/fvsRunUtilities.R b/fvsOL/R/fvsRunUtilities.R index 33eaff7..e069cf5 100644 --- a/fvsOL/R/fvsRunUtilities.R +++ b/fvsOL/R/fvsRunUtilities.R @@ -408,9 +408,9 @@ resetActiveFVS <- function(globals) "cover", "wrd3", "phewrd3", "armwrd3", "ardwrd3"), FVSws = c("ws", "strp", "dbs", "cover", "mist", "fire", "climate", "econ", "wrd3", "phewrd3", "armwrd3", "ardwrd3" )) - avalFVS <- dir(globals$fvsBin,pattern=paste0("[.]", - substr(.Platform$dynlib.ext,2,999),"$")) - avalFVS <- unique(sub(.Platform$dynlib.ext,"",avalFVS)) + avalFVS <- dir(globals$fvsBin,pattern=paste0("FVS[a-z]*",.Platform$dynlib.ext,"$")) + avalFVS <- unique(sub(paste0(.Platform$dynlib.ext,"$"),"",avalFVS)) +cat ("in resetActiveFVS, avalFVS=",avalFVS,"\nglobals$lastRunVar=",globals$lastRunVar,"\n") if (length(avalFVS)) globals$activeFVS = globals$activeFVS[avalFVS] globals$activeVariants <- unlist(lapply(globals$activeFVS, function(x) x[1])) vars = c("ak: Alaska"="ak", @@ -458,7 +458,8 @@ nextMgmtID <- function(nruns=0) resetGlobals <- function(globals,runDef) { -cat("resetGlobals, runDef=",runDef,"\n") +cat("resetGlobals, runDef=",runDef,"\nglobals$lastRunVar=",globals$lastRunVar, + " globals$activeVariants=",globals$activeVariants,"\n") resetActiveFVS(globals) globals$schedBoxYrLastUsed=character(0) globals$currentEditCmp=globals$NULLfvsCmp @@ -501,7 +502,7 @@ updateVarSelection <- function (globals,session,input) if (length(globals$fvsRun$FVSpgm) == 0) { vlst = as.list(globals$activeVariants) - selected = if (length(globals$lastRunVar)) globals$lastRunVar else globals$activeVariants[1] + selected = if (length(globals$lastRunVar)) globals$lastRunVar[1] else globals$activeVariants[1] } else { if (is.null(globals$activeFVS[[globals$fvsRun$FVSpgm]])) { diff --git a/fvsOL/R/modalDialog.R b/fvsOL/R/modalDialog.R index 237dea4..d40de22 100644 --- a/fvsOL/R/modalDialog.R +++ b/fvsOL/R/modalDialog.R @@ -1,26 +1,23 @@ -# code taken form shiny-confirm-dialog, Wei Cheng, with thanks! -modalDialog <- function(id, header = "Confirmation", body = "Confirm action", - footer = list(actionButton("confirmDlgOkBtn", "OK"))) -{ - div(id = id, class = "modal fade", - div(class = "modal-dialog", - div(class = "modal-content", - div(class = "modal-header", - tags$button(type = "button", class = "close", - 'data-dismiss' = "modal", 'aria-hidden' = "true", HTML('×')), - tags$h4(class = "modal-title", header)), - div(class = "modal-body", tags$p(body)), - div(class = "modal-footer", tagList(footer))) - )) -} - -# code taken form shiny-confirm-dialog, Wei Cheng, with thanks! -modalTriggerButton <- function(inputId, target, label) -{ - tags$button(id = inputId, type = "button", - class = "btn action-button btn-primary", 'data-toggle' = "modal", - 'data-target' = target, label) -} - - - +# code taken form shiny-confirm-dialog, Wei Cheng, with thanks! +modalDialog <- function(id, header = "Confirmation", body = "Confirm action", + footer = list(actionButton("confirmDlgOkBtn", "OK"))) +{ + div(id = id, class = "modal fade", + div(class = "modal-dialog", + div(class = "modal-content", + div(class = "modal-header", + tags$button(type = "button", class = "close", + 'data-dismiss' = "modal", 'aria-hidden' = "true", HTML('×')), + tags$h4(class = "modal-title", header)), + div(class = "modal-body", tags$p(body)), + div(class = "modal-footer", tagList(footer))) + )) +} + +# code taken form shiny-confirm-dialog, Wei Cheng, with thanks! +modalTriggerButton <- function(inputId, target, label) +{ + tags$button(id = inputId, type = "button", + class = "btn action-button btn-primary", 'data-toggle' = "modal", + 'data-target' = target, label) +} \ No newline at end of file diff --git a/fvsOL/R/server.R b/fvsOL/R/server.R index f1e57a0..da87765 100644 --- a/fvsOL/R/server.R +++ b/fvsOL/R/server.R @@ -1,8356 +1,8418 @@ -# The top of this file contains several objects loaded into the .GlobalEnv -# prior to the shinyApp call. - -#' Run fvsOL (FVS OnLine/OnLocal). -#' -#' @param prjDir the name of the directory containing an fvsOL project. -#' @param runUUID the uuid of the run that should be opened when the system starts, -#' if NULL or not found in the list of runs, it is ignored. -#' @param fvsBin the name of the directory containing the FVS load libraries for the platform -#' @param shiny.trace turns on tracing for shiny, see shiny documentation -#' @param logToConsole controls if the log is output to the console or the log file, -#' the default set by the interactive() function. -#' @return the shiny app. -#' @export -fvsOL <- function (prjDir=NULL,runUUID=NULL,fvsBin=NULL,shiny.trace=FALSE, - logToConsole=interactive()) -{ - require(stats) - require(utils) - if (!is.null(prjDir) && dir.exists(prjDir)) setwd(prjDir) - if (is.null(fvsBin) || !dir.exists(fvsBin)) - { - if (dir.exists("FVSbin")) fvsBin="FVSbin" else stop("fvsBin must be set") - } - fvsBin <<- fvsBin - runUUID <<- runUUID - logToConsole <<- logToConsole - - cat ("FVSOnline/OnLocal function fvsOL started.\n") - - addResourcePath("colourpicker-lib/js", - system.file("www/shared/colourpicker/js", package="colourpicker")) - addResourcePath("colourpicker-lib/css", - system.file("www/shared/colourpicker/css",package="colourpicker")) - addResourcePath("colourpicker-binding", - system.file("srcjs",package="colourpicker")) - addResourcePath("FVSlogo.png", - system.file("extdata","www/FVSlogo.png",package="fvsOL")) - addResourcePath("USDAFS.png", - system.file("extdata","www/USDAFS.png",package="fvsOL")) - addResourcePath("message-handler.js", - system.file("extdata","www/message-handler.js",package="fvsOL")) - if (!dir.exists ("www")) dir.create("www") - addResourcePath("www",file.path(".","www")) - - # set shiny.trace=TRUE for reactive tracing - options(shiny.maxRequestSize=10000*1024^2,shiny.trace=shiny.trace, - rgl.inShiny=TRUE,rgl.useNULL=TRUE) - - data (prms) - data (treeforms) - - cat ("Starting shinyApp.\n") - - shinyApp(FVSOnlineUI, FVSOnlineServer, options=list(launch.browser=TRUE)) -} - -mkfvsStd <- setRefClass("fvsStd", - fields = list(sid = "character", rep = "numeric", repwt = "numeric", - invyr = "character", grps = "list", cmps = "list",uuid="character")) - -mkfvsGrp <- setRefClass("fvsGrp", - fields = list(grp = "character", cmps = "list", uuid="character")) - -mkfvsCmp <- setRefClass("fvsCmp", - fields = list(kwds = "character", kwdName = "character", exten="character", - title="character", variant="character",uuid="character", atag="character", - reopn="character")) -# atag is always "c" if the component is a condition, "k" if it is a keyword -# component that is not attached to a specific component. If it is longer than 1 -# character it is the uuid of the related condition - -mkfvsRun <- setRefClass("fvsRun", - fields = list(stands = "list", grps = "list", simcnts = "list", - selsim = "list", FVSpgm = "character", title = "character", - startyr = "character", endyr = "character", cyclelen = "character", - cycleat = "character", refreshDB = "character", uuid="character", - defMgmtID = "character", autoOut = "list", runScript = "character" , - uiCustomRunOps = "list", startDisp = "character")) - -mkfvsOutData <- - setRefClass("fvsOutData", - fields = list(dbLoadData = "list", dbData = "data.frame", - dbVars = "character", browseVars = "character", - dbSelVars = "character", browseSelVars = "character", - runs = "character", plotSpecs = "list", - render = "data.frame")) - -mkGlobals <- setRefClass("globals", - fields = list(activeFVS = "list", activeVariants = "character", - activeExtens = "character", schedBoxYrLastUsed = "character", - extnsel = "character", kwdsel = "list", mgmtsel = "list", - mevsel = "list", mmodsel = "list", pastelist = "list",fvsBin="character", - pastelistShadow = "list", inData = "list", FVS_Runs = "list", - customCmps = "list", selStds = "character", currentCmdDefs="character", - schedBoxPkey = "character", currentCmdPkey = "character",GrpNum="numeric", - currentCndPkey = "character", winBuildFunction = "character",GenGrp="list", - existingCmps = "list",currentQuickPlot = "character", - currentEditCmp = "fvsCmp", NULLfvsCmp = "fvsCmp", saveOnExit= "logical", - customQueries = "list", fvsRun = "fvsRun", foundStand="integer", - reloadAppIsSet = "numeric", hostname= "character", toggleind="character", - selStandTableList = "list",kcpAppendConts = "list",opencond="numeric", - condKeyCntr="numeric",prevDBname="list",changeind="numeric", - lastRunVar="character",gFreeze="logical",importItems="list", - settingChoices="list",exploreChoices="list",simLvl="list",stdLvl="list", - 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", RepsDesign='logical')) - -isLocal <- function () Sys.getenv('SHINY_PORT') == "" - -# cbbPalette is used in the graphics -cbbPalette <- c("#FF0000","#009E73","#0072B2","#E69F00","#CC79A7","#0000FF", - "#D55E00","#8F7800","#D608FA","#009100","#CF2C73","#00989D", - "#00FF00","#BAF508","#202020","#6B6B6A","#56B4E9","#20D920") - -extnslist <- list( - "Base FVS system"="base", - "Cover Model"="cover", - "Full Establishment Model"="estb", - "Partial Establishment Model"="strp", - "Database Extension"="dbs", - "Economic Analysis Extension"="econ", - "Dwarf Mistletoe Impact Model"="mist", - "ORGANON in FVS"="organon", - "Fire and Fuels Extension"="fire", - "Climate-FVS Extension"="climate", - "WRD (Annosus Root Disease)"="ardwrd3", - "WRD (Armillaria Root Disease)"="armwrd3", - "WRD (Laminated Root Rot)"="phewrd3") - -options(rgl.useNULL=TRUE) - -trim <- function (x) gsub("^\\s+|\\s+$","",x) - -defaultRun <- list("Default useful for all FVS variants"="fvsRun") - -# used in Tools, dlZipSet -zipList <- list( - "FVSProject data base (Runs, Custom components (kcp), Custom queries, GraphSettings)" = "fvsProjdb", - "Output data base for for all runs" = "outdb", - "Keyword file for current run" = "key", - "FVS output file for current run" = "out", - "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]) - -# if "runScripts.R" exists in the project directory, then use it, otherwise load -# the version that is part of the package software. -rsf <- "runScripts.R" -if (file.exists(rsf)) source(rsf) else source(system.file("extdata", rsf, - package="fvsOL")) -runScripts <- if (exists("customRunScripts") && length(customRunScripts)) - append(x=customRunScripts,after=0,defaultRun) else defaultRun - -customRunElements = list( - selectInput("runScript", - "Select run script (normally, use the default)", - choices=runScripts, - selected="fvsRun",multiple=FALSE,selectize=FALSE), - uiOutput("uiCustomRunOps")) - -FVSOnlineServer <- function(input, output, session) -{ -cat ("FVSOnline/OnLocal interface server start\n") - - # set serverDate to be the release date using packageVersion - serverDate=as.character(packageVersion("fvsOL")) - serverDate=unlist(strsplit(serverDate,".",fixed=TRUE)) - for (i in 2:3) if (nchar(serverDate[i])==1) serverDate[i]=paste0("0",serverDate[i]) - serverDate=paste0(serverDate,collapse="") - -cat ("ServerDate=",serverDate,"\n") - - if (!logToConsole) - { - if (file.exists("FVSOnline.log")) - { - unlink("FVSOnline.older.log") - file.rename("FVSOnline.log","FVSOnline.older.log") - } - #make sure the sink stack is empty - while (sink.number()) sink() - sink("FVSOnline.log") - } - -cat ("FVSOnline/OnLocal interface server start, serverDate=",serverDate,"\n") - - withProgress(session, - { - setProgress(message = "Start up", - detail = "Loading scripts and settings", value = 1) - - globals <- mkGlobals$new(saveOnExit=TRUE,reloadAppIsSet=0, - gFreeze=FALSE,fvsBin=fvsBin) - dbGlb <- new.env() - dbGlb$tbl <- NULL - dbGlb$navsOn <- FALSE - dbGlb$rowSelOn <- FALSE - dbGlb$disprows <- 20 - if (file.exists("projectIsLocked.txt")) - { -cat ("Project is locked.\n") - output$appLocked<-renderUI(HTML(paste0('

', - 'Warning: This project may already be opened.

', - '
Insure the project is not opened in another window.
', - '', - '    

'))) - } else cat (file="projectIsLocked.txt",date(),"\n") - setProgress(message = "Start up",value = 2) - - nruns = mkFVSProjectDB() - dbGlb$prjDB = connectFVSProjectDB() - - if (nruns==0) - { - globals$fvsRun <- mkfvsRun$new(uuid=uuidgen(),title="Run 1",defMgmtID="A001") - resetGlobals(globals,FALSE) - storeFVSRun(dbGlb$prjDB,globals$fvsRun) - } - globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) - #update a couple of list buttons with the list of tables - xlsxFile=system.file("extdata", "databaseDescription.xlsx", - package="fvsOL") - if (file.exists(xlsxFile)) - { - if ("OutputTableDescriptions" %in% getSheetNames(xlsxFile)) - { - tabs = read.xlsx(xlsxFile=xlsxFile,sheet="OutputTableDescriptions")[,1] - tableList <- sort(c("",tabs)) - metr=grep("Metric",tableList,ignore.case=TRUE) - if (length(metr)) - { - metric = tableList[metr] - tableList=c(tableList[-metr],metric) - } - tableList = as.list(tableList) - } - updateSelectInput(session=session, inputId="tabDescSel2",choices=tableList, - select=tableList[[1]]) - updateSelectInput(session=session, inputId="tabDescSel",,choices=tableList, - select=tableList[[1]]) - } - - setProgress(message = "Start up", - detail = "Loading interface elements", value = 3) - - serverDateOut = if (tolower(basename(dirname(system.file(package="fvsOL")))) == "r-dev") - { - if (isLocal()) - paste0('Dev OnLocal ',serverDate,"
") else - paste0('Development ',serverDate,"
") - } else { - paste0(paste0("Release date: ",serverDate,"
"),if (isLocal()) " Local" else " Online"," configuration
") - } - hostedByLogo=system.file("extdata","www/hostedByLogo.png", - package="fvsOL") -cat ("hostedByLogo=",hostedByLogo," serverDateOut=",serverDateOut,"\n") - if (file.exists(hostedByLogo)) - { - addResourcePath("hostedByLogo.png",hostedByLogo) - serverDateOut = paste0(serverDateOut,"Hosted by
",'
') - } - output$serverDate=renderUI(HTML(serverDateOut)) - tit=NULL - pfexists = file.exists("projectId.txt") - if (!pfexists || (pfexists && file.size("projectId.txt") < 2)) - cat("title= ",basename(getwd()),"\n",file="projectId.txt") - prjid = scan("projectId.txt",what="",sep="\n",quiet=TRUE) - tit=prjid[grep("^title",prjid)] - tit=trim(unlist(strsplit(tit,split="=",fixed=TRUE))[2]) - email=prjid[grep("^email",prjid)] - email=trim(unlist(strsplit(email,split="=",fixed=TRUE))[2]) - tstring = paste0("Project title: ",tit,"", - if (length(email)) paste0("
Email: ",email,"") else "", - "
Last accessed: ", - format(file.info(getwd())[1,"mtime"],"%a %b %d %H:%M:%S %Y"),"") -cat ("tstring=",tstring,"\n") - output$projectTitle = renderText(HTML(tstring)) - mkSimCnts(globals$fvsRun,sels=globals$fvsRun$selsim) - resetGlobals(globals,TRUE) - selChoices = globals$FVS_Runs -cat ("Setting initial selections, length(selChoices)=",length(selChoices),"\n") - runUUID = if (!is.null(runUUID) && runUUID %in% selChoices) runUUID else selChoices[[1]] - updateSelectInput(session=session, inputId="runSel", - choices=selChoices,selected=runUUID) - updateTextInput(session=session, inputId="title", value=names(selChoices[1])) - if (exists("fvsOutData")) rm (fvsOutData) - fvsOutData <- mkfvsOutData$new(plotSpecs=list(res=144,height=4,width=6)) - - dbDrv <- dbDriver("SQLite") - dbGlb$dbOcon <- dbConnect(dbDrv,"FVSOut.db") - - loadObject(dbGlb$prjDB,"stdstkParms") - if (exists("stdstkParms")) - { - val = stdstkParms$sdskwdbh - if (!is.na(val)) updateNumericInput(session=session,inputId="sdskwdbh", - value=val) - val = stdstkParms$sdskldbh - if (!is.na(val)) updateNumericInput(session=session, inputId="sdskldbh", - value=val) - } - - # the default SpatialData is distributed with the package, install it if it - # is not in the project directory. - if (!file.exists("FVS_Data.db")) - { - frm=system.file("extdata", "FVS_Data.db.default", package="fvsOL") - file.copy(frm,"FVS_Data.db",overwrite=TRUE) - frm=system.file("extdata", "SpatialData.RData.default",package=sub("package:","",find('fvsOL')[1])) - file.copy(frm,"SpatialData.RData",overwrite=TRUE) - } - globals$changeind <- 0 - output$contChange <- renderUI("Run") - dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") - globals$exploring <- FALSE - - setProgress(value = NULL) - }, min=1, max=6) - observe({ -cat ("protocol: ", session$clientData$url_protocol, "\n", - "hostname: ", session$clientData$url_hostname, "\n", - "pathname: ", session$clientData$url_pathname, "\n", - "port: ", session$clientData$url_port, "\n", - "search: ", session$clientData$url_search, "\n") - globals$hostname = session$clientData$url_hostname -cat("signalClosing=",input$signalClosing,"\n") - if (!is.null(input$signalClosing) && input$signalClosing==1 && - globals$reloadAppIsSet == 0 && globals$hostname == "127.0.0.1") - { -cat ("sending closeWindow\n") - session$sendCustomMessage(type = "closeWindow"," ") - } - }) - - session$onSessionEnded(function () - { -cat ("onSessionEnded, globals$saveOnExit=",globals$saveOnExit, - " interactive()=",interactive(),"\n", - "globals$reloadAppIsSet=",globals$reloadAppIsSet, - " globals$hostname=",globals$hostname,"\n") - if (exists("dbOcon",envir=dbGlb,inherit=FALSE)) try(dbDisconnect(dbGlb$dbOcon)) - if (exists("dbIcon",envir=dbGlb,inherit=FALSE)) try(dbDisconnect(dbGlb$dbIcon)) - if (length(globals$importItems)) - { - if (attr(globals$importItems,"temp")) unlink(attr(globals$importItems,"dir"),recursive = TRUE) - globals$importItems=list() - } - - if (globals$saveOnExit) - { - saveRun(input,session) - FVS_Runs = globals$FVS_Runs - stdstkParms = isolate(list("sdskwdbh"=input$sdskwdbh, - "sdskldbh"=input$sdskldbh)) - storeOrUpdateObject(dbGlb$prjDB,stdstkParms) - prjIdTxt = "projectId.txt" - if (file.exists(prjIdTxt)) # this is done to update the modification time. - { - prjid = scan(prjIdTxt,what="character",sep="\n",quiet=TRUE) - write(file=prjIdTxt,prjid) - } - } - unlink ("projectIsLocked.txt") - # remove excess images that may be created in Maps. - delList = dir ("www",pattern="*png$",full.names=TRUE) - if (length(delList)) lapply(delList,function(x) unlink(x)) - #note: the stopApp function returns to the R process that called shinyApp() - if (globals$reloadAppIsSet == 0) stopApp() - globals$reloadAppIsSet == 0 - }) - - ## clearLock - observe({ - if (!is.null(input$clearLock) && input$clearLock==0) - { - withProgress(session, { - for (i in 1:5) - { - setProgress(message = "5 second delay ", - detail = paste(i,"of 5"), value = i) - Sys.sleep(1) - } - setProgress(value = NULL) - }, min=1, max=10) - } - }) - - ## exitNow - observe({ - if (!is.null(input$exitNow) && input$exitNow>0) - { -cat ("exit now\n") - globals$saveOnExit=FALSE - session$sendCustomMessage(type = "closeWindow"," ") - } - }) - ## remake the lock file. - observe({ - if (!is.null(input$clearLock) && input$clearLock>0) - { - output$appLocked<-NULL - # remake the lock file. - cat (file="projectIsLocked.txt",date(),"\n") - } - }) - - ## changeind - observe({ - cat ("changeind=",globals$changeind,"\n") - if (globals$changeind == 0){ - output$contChange <- renderUI("Run") - output$srtYr <-renderUI({ - HTML(paste0("",input$startyr,"")) - }) - output$eYr <-renderUI({ - HTML(paste0("",input$endyr,"")) - }) - output$cyLen <-renderUI({ - HTML(paste0("",input$cyclelen,"")) - }) - output$cyAt <-renderUI({ - HTML(paste0("",input$cycleat,"")) - }) - } - }) - - ## Load - observe({ - if (input$topPan == "View Outputs" && input$leftPan == "Load") - { - globals$selAllVars=FALSE - globals$tableMessage=FALSE -cat ("View Outputs & Load\n") - initTableGraphTools(globals,session,output,fvsOutData) - output$table <- renderTable(NULL) - tbs <- myListTables(dbGlb$dbOcon) - if (length(tbs) > 0 && !is.na(match("FVS_Cases",tbs))) - { - runsdf = dbGetQuery(dbGlb$dbOcon, - paste0("Select RunTitle,KeywordFile from FVS_Cases group by KeywordFile ", - "having min(RunDateTime) order by RunDateTime desc;")) - fvsOutData$runs = runsdf$KeywordFile - names(fvsOutData$runs) = runsdf$RunTitle - } - updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) - } - }) - - ## runs output run selection - observeEvent((input$leftPan == "Load" && !is.null(input$runs)), { - if (input$leftPan != "Load") return() -cat ("runs, run selection (load) input$runs=",input$runs,"\n") - if (!is.null(input$runs) && !length(globals$tbsFinal) && !globals$exploring) # will be a list of run keywordfile names (uuid's) - { - tbs <- myListTables(dbGlb$dbOcon) -cat ("tbs related to the run",tbs,"\n") - if (length(tbs) == 0) - { - updateSelectInput(session, "selectdbtables", choices=list()) - return() - } - withProgress(session, { - i = 1 - setProgress(message = "Please wait: Performing output query", - detail = "Selecting tables", value = i); i = i+1 - # set an exclusive lock on the database - dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = EXCLUSIVE") - trycnt=0 - while (TRUE) - { - trycnt=trycnt+1 - setProgress(message = "Please wait: Getting exclusive lock", - detail = paste0("Number of attempts=",trycnt," of 1000")) - if (trycnt > 1000) - { - dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") - myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active - setProgress(value = NULL) - return() - } -cat ("try to get exclusive lock, trycnt=",trycnt,"\n"); - rtn <- try(dbExecute(dbGlb$dbOcon,"create table dummy (dummy int)")) - if (class(rtn) != "try-error") break; - Sys.sleep (10) - } -cat ("have exclusive lock\n") - dbExecute(dbGlb$dbOcon,"drop table if exists dummy") - # create a temp.Cases table that is a list of CaseIDs - # associated with the selected runs. These two items are used to - # filter records selected from selected tables. - qry = paste0("create table temp.Cases as select _RowID_,CaseID,Variant ", - "from FVS_Cases where FVS_Cases.KeywordFile in ", - paste0("('",paste(input$runs,collapse="','"),"')")) -cat("qry=",qry,"\n") - dbExecute(dbGlb$dbOcon,"drop table if exists temp.Cases") - rtn = dbExecute(dbGlb$dbOcon,qry) -cat("rtn from create temp.Cases=",rtn,"\n") - ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] -cat ("ncases=",ncases,"\n") - bagit=ncases==0 - isMetric=FALSE - if (!bagit) - { - variantsRun = tolower(dbGetQuery(dbGlb$dbOcon, - "select distinct Variant from temp.Cases;")[,1]) - metricVars = c("bc","on") - isMetric = length(intersect(variantsRun,metricVars)) > 0 - # can not have metric and non-metric variants - bagit = isMetric && length(setdiff(variantsRun,metricVars)) - } - if (bagit) - { - updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) - dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") - myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active - setProgress(value = NULL) - return() - } - for (tb in tbs) - { -cat ("tb=",tb,"\n") - cnt = 0 - if (tb == "FVS_Cases") next - if (tb %in% c("CmpSummary","CmpSummary_East", "CmpSummary2", - "CmpSummary2_East","CmpSummary2_Metric", "StdStk","CmpStdStk", - "StdStk_East","CmpStdStk_East","StdStk_Metric","CmpStdStk_Metric", - "CmpMetaData","CmpCompute")) - { -cat ("drop tb=",tb,"\n") - dbExecute(dbGlb$dbOcon,paste0("drop table if exists ",tb)) - } else { - qry = paste0("select count(*) from ", - "(select CaseID from ",tb," where ",tb,".CaseID in ", - "(select CaseID from temp.Cases))") -cat("qry=",qry,"\n") - cnt = if ("CaseID" %in% dbListFields(dbGlb$dbOcon,tb)) - dbGetQuery(dbGlb$dbOcon,qry) else -1 - cnt = if (class(cnt)=="data.frame") cnt[1,1] else -1 -cat ("tb=",tb," cnt=",cnt,"\n") - } - if (cnt == 0) tbs = setdiff(tbs,tb) - } - source(system.file("extdata", if (isMetric) "sqlQueries_Metric.R" else "sqlQueries.R", - package="fvsOL")) - if (!exqury(dbGlb$dbOcon,Create_CmpMetaData)) - { - updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) - dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") - myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active - setProgress(value = NULL) - return() - } - dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) - if (!isMetric) - { - if ("FVS_Summary" %in% tbs && ncases > 1) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpSummary", value = i); i = i+1 - exqury(dbGlb$dbOcon,Create_CmpSummary) - tbs = c(tbs,"CmpSummary") -cat ("tbs1=",tbs,"\n") - } - if ("FVS_Summary_East" %in% tbs && ncases > 1) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpSummary_East", value = i); i = i+1 - exqury(dbGlb$dbOcon,Create_CmpSummary_East) - tbs = c(tbs,"CmpSummary_East") -cat ("tbs2=",tbs,"\n") - } - if ("FVS_Summary2" %in% tbs && ncases > 1) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpSummary2", value = i); i = i+1 - exqury(dbGlb$dbOcon,Create_CmpSummary2) - tbs = c(tbs,"CmpSummary2") -cat ("tbs3=",tbs,"\n") - } - if ("FVS_Summary2_East" %in% tbs && ncases > 1) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpSummary2_East", value = i); i = i+1 - exqury(dbGlb$dbOcon,Create_CmpSummary2_East) - tbs = c(tbs,"CmpSummary2_East") -cat ("tbs4=",tbs,"\n") - } - } else { - if ("FVS_Summary2_Metric" %in% tbs && exists("Create_CmpSummary2")) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpSummary2_Metric", value = i); i = i+1 - exqury(dbGlb$dbOcon,Create_CmpSummary2) - tbs = c(tbs,"CmpSummary2_Metric") -cat ("tbs5=",tbs,"\n") - } - } - if ("FVS_Compute" %in% tbs && ncases > 1) - { - setProgress(message = "Please wait: performing output query", - detail = "Building CmpCompute", value = i); i = i+1 - cmp = dbGetQuery(dbGlb$dbOcon, - "select * from FVS_Compute limit 0") - sumExpressions = paste0( - lapply(setdiff(colnames(cmp),c("CaseID","StandID","Year")), - function (var) paste0("round(sum(",var, - "*SamplingWT)/sum(SamplingWt),2) as Cmp",var)),collapse=",") - exqury(dbGlb$dbOcon,Create_CmpCompute,subExpression=sumExpressions) - cmp = dbGetQuery(dbGlb$dbOcon,"Select * from CmpCompute;") - keep = apply(cmp,2,function (x) !(all(is.na(x)))) - if (!all(keep)) - { - cmp = cmp[,keep] - dbWriteTable(dbGlb$dbOcon,"CmpCompute",cmp,overwrite=TRUE) - } - tbs = c(tbs,"CmpCompute") -cat ("tbs6=",tbs,"\n") - } - tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) - if (!isMetric && any(tlprocs)) - { - tlprocs = names(tlprocs)[tlprocs] - chtoEast = function(cmd) - { - cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) - cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) - cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) - gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) - } - for (tlp in tlprocs) - { - if (tlp == "tlwest") - { - C_StdStkDBHSp = Create_StdStkDBHSp - C_HrvStdStk = Create_HrvStdStk - C_StdStk1Hrv = Create_StdStk1Hrv - C_StdStk1NoHrv = Create_StdStk1NoHrv - C_StdStkFinal = Create_StdStkFinal - C_CmpStdStk = Create_CmpStdStk - detail = "Building StdStk from tree lists" - stdstk = "StdStk" - clname = "FVS_CutList" - } else { - C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) - C_HrvStdStk = chtoEast(Create_HrvStdStk ) - C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) - C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) - C_StdStkFinal = chtoEast(Create_StdStkFinal ) - C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) - C_CmpStdStk = chtoEast(Create_CmpStdStk ) - C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) - C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) - detail = "Building StdStk_East from tree lists" - stdstk = "StdStk_East" - clname = "FVS_CutList_East" - } - setProgress(message = "Please wait: performing output query", - detail = detail, value = i); i = i+1 - exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - if (clname %in% tbs) - { - setProgress(message = "Please wait: performing output query", - detail = detail, value = i); i = i+1 - exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - setProgress(message = "Please wait: performing output query", - detail = "Joining tables", value = i); i = i+1 - exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - } else { - setProgress(message = "Please wait: performing output query", - detail = "Joining tables", value = i); i = i+2 - exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - } - exqury(dbGlb$dbOcon,C_StdStkFinal) - tbs = c(tbs,stdstk) - if (ncases > 1) - { - exqury(dbGlb$dbOcon,C_CmpStdStk) - tbs = c(tbs,paste0("Cmp",stdstk)) - } - } - } - if ("FVS_TreeList_Metric" %in% tbs) - { - asSpecies=paste0("Species",input$spCodes) - setProgress(message = "Please wait: performing output query", detail = "Building StdStk", value = i); i = i+1 - if ("FVS_CutList_Metric" %in% tbs) exqury(dbGlb$dbOcon,Create_HrvStdStk, - subExpression=dbhclassexp, asSpecies=asSpecies) - exqury(dbGlb$dbOcon,Create_StdStkDBHSp,subExpression=dbhclassexp,asSpecies=asSpecies) - exqury(dbGlb$dbOcon,Create_StdStk1NoHrv,subExpression=dbhclassexp,asSpecies=asSpecies) - exqury(dbGlb$dbOcon,Create_StdStkFinal) - tbs = c(tbs,"StdStk_Metric") - if (ncases > 1) - { - exqury(dbGlb$dbOcon,Create_CmpStdStk) - tbs = c(tbs,"CmpStdStk_Metric") - } - } - if (all(Create_View_DWN_Required %in% tbs)) - { - exqury(dbGlb$dbOcon,Create_View_DWN) - tbs = c(tbs,"View_DWN") - } - dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") -cat ("tbs7=",tbs,"\n") - setProgress(message = "Please wait: performing output query", - detail = "Committing changes", value = i); i = i+1 - dbd = lapply(tbs,function(tb,con) dbListFields(con,tb), dbGlb$dbOcon) - names(dbd) = tbs - if (!is.null(dbd[["FVS_Summary"]])) dbd$FVS_Summary = c(dbd$FVS_Summary, - c("TPrdTpa","TPrdTCuFt","TPrdMCuFt","TPrdBdFt")) - if (!is.null(dbd[["FVS_Summary_East"]])) dbd$FVS_Summary_East = - c(dbd$FVS_Summary_East,c("TPrdTpa","TPrdMCuFt","TPrdSCuFt","TPrdSBdFt")) - if (!is.null(dbd[["CmpSummary"]])) dbd$CmpSummary = c(dbd$CmpSummary, - c("CmpTPrdTpa","CmpTPrdTCuFt","CmpTPrdMCuFt","CmpTPrdBdFt")) - if (!is.null(dbd[["CmpSummary_East"]])) dbd$CmpSummary = c(dbd$CmpSummary_East, - c("CmpTPrdTpa","CmpTPrdTCuFt","CmpTPrdMCuFt","CmpTPrdBdFt")) - if (length(dbd)) fvsOutData$dbLoadData <- dbd - sel = intersect(tbs, c("FVS_Summary2","FVS_Summary2_East")) #not both! - if (length(sel)==0) sel = intersect(tbs, c("FVS_Summary","FVS_Summary_East")) #not both! - if (length(sel)>1) sel = sel[1] - # rearrange the table list so be organized by levels (i.e., tree level, stand level) - globals$simLvl <- list("CmpCompute","CmpStdStk","CmpStdStk_East","CmpStdStk_Metric", - "CmpSummary","CmpSummary_East","CmpSummary_Metric", - "CmpSummary2","CmpSummary2_East","CmpSummary2_Metric","CmpMetaData") - globals$stdLvl <- list("FVS_Climate","FVS_Compute","FVS_EconSummary","FVS_BurnReport","FVS_Carbon", - "FVS_Down_Wood_Cov","FVS_Down_Wood_Vol","FVS_Consumption","FVS_Hrv_Carbon", - "FVS_PotFire","FVS_PotFire_Cond","FVS_PotFire_East","FVS_SnagSum","FVS_Fuels", - "FVS_DM_Stnd_Sum","FVS_Regen_Sprouts","FVS_Regen_SitePrep","FVS_Regen_HabType", - "FVS_Regen_Tally","FVS_Regen_Ingrow","FVS_RD_Sum","FVS_RD_Det","FVS_RD_Beetle", - "FVS_Stats_Stand","FVS_StrClass","FVS_Summary2","FVS_Summary2_East","FVS_Summary2_Metric", - "FVS_Summary","FVS_Summary_East","View_DWN","FVS_DM_Stnd_Sum_Metric") - globals$specLvl <- list("FVS_CalibStats","FVS_EconHarvestValue","FVS_Stats_Species", - "FVS_DM_Spp_Sum","FVS_DM_Spp_Sum_Metric") - globals$dClsLvl <- list("StdStk","StdStk_East","StdStk_Metric","FVS_Mortality","FVS_DM_Sz_Sum", - "FVS_DM_Sz_Sum_Metric") - globals$htClsLvl <- list("FVS_CanProfile") - globals$treeLvl <- list("FVS_ATRTList","FVS_CutList","FVS_SnagDet","FVS_TreeList", - "FVS_TreeList_East","FVS_CutList_East","FVS_ATRTList_East", - "FVS_TreeList_Metric","FVS_CutList_Metric","FVS_ATRTList_Metric", - "FVS_DM_Treelist","FVS_DM_Treelist_Metric") - globals$tbsFinal <- list("FVS_Cases") - tbsFinal <- globals$tbsFinal - if (any(tbs %in% globals$simLvl)) { - tbsFinal <- c(tbsFinal,"-----Composite tables-----") - simLvlIdx <- subset(match(globals$simLvl,tbs),match(globals$simLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[simLvlIdx])) - } - if (any(tbs %in% globals$stdLvl)) { - tbsFinal = c(tbsFinal,"-----Stand-level tables-----") - stdLvlIdx <- subset(match(globals$stdLvl,tbs),match(globals$stdLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[stdLvlIdx])) - } - if (any(tbs %in% globals$specLvl)) { - tbsFinal = c(tbsFinal,"-----Species-level tables-----") - specLvlIdx <- subset(match(globals$specLvl,tbs),match(globals$specLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[specLvlIdx])) - } - if (any(tbs %in% globals$dClsLvl)) { - tbsFinal = c(tbsFinal,"-----Diameter-class tables-----") - dClsLvlIdx <- subset(match(globals$dClsLvl,tbs),match(globals$dClsLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[dClsLvlIdx])) - } - if (any(tbs %in% globals$htClsLvl)) { - tbsFinal = c(tbsFinal,"-----Height-class tables-----") - htClsLvlIdx <- subset(match(globals$htClsLvl,tbs),match(globals$htClsLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[htClsLvlIdx])) - } - if (any(tbs %in% globals$treeLvl)) { - tbsFinal = c(tbsFinal,"-----Tree-level tables-----") - treeLvlIdx <- subset(match(globals$treeLvl,tbs),match(globals$treeLvl,tbs) != "NA") - tbsFinal <- c(tbsFinal,sort(tbs[treeLvlIdx])) - } - othTbs = setdiff(tbs,tbsFinal) - if (length(othTbs)) { - tbsFinal = c(tbsFinal,"-----Other tables-----") - tbsFinal <- c(tbsFinal,othTbs) - } - globals$tbsFinal <- tbsFinal - if(is.null(input$selectdbtables)){ - updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), - selected="FVS_Cases") - } else if(globals$tableMessage) { - updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), - selected=input$selectdbtables[1]) - globals$tableMessage=FALSE - } else { - updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), - selected=input$selectdbtables) - } - globals$tbsFinal <- list() - setProgress(value = NULL) - }, min=1, max=6) - } else - { - updateSelectInput(session, "selectdbtables", choices=list()) - globals$exploring <- FALSE - } - }) - - ## bldstdsk - observeEvent(input$bldstdsk,{ - tbs <- myListTables(dbGlb$dbOcon) -cat ("tbs related to the run",tbs,"\n") - if (length(tbs) == 0) - { - updateSelectInput(session, "selectdbtables", choices=list()) - return() - } - dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) - tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) - if (any(tlprocs)) - { - tlprocs = names(tlprocs)[tlprocs] - chtoEast = function(cmd) - { - cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) - cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) - cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) - gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) - } - for (tlp in tlprocs) - { - if (tlp == "tlwest") - { - C_StdStkDBHSp = Create_StdStkDBHSp - C_HrvStdStk = Create_HrvStdStk - C_StdStk1Hrv = Create_StdStk1Hrv - C_StdStk1NoHrv = Create_StdStk1NoHrv - C_StdStkFinal = Create_StdStkFinal - C_CmpStdStk = Create_CmpStdStk - detail = "Building StdStk from tree lists" - stdstk = "StdStk" - clname = "FVS_CutList" - } else { - C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) - C_HrvStdStk = chtoEast(Create_HrvStdStk ) - C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) - C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) - C_StdStkFinal = chtoEast(Create_StdStkFinal ) - C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) - C_CmpStdStk = chtoEast(Create_CmpStdStk ) - C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) - C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) - detail = "Building StdStk_East from tree lists" - stdstk = "StdStk_East" - clname = "FVS_CutList_East" - } - exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - if (clname %in% tbs) - { - exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - } else { - exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, - asSpecies=paste0("Species",input$spCodes)) - } - exqury(dbGlb$dbOcon,C_StdStkFinal) - ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] - if (ncases > 1) exqury(dbGlb$dbOcon,C_CmpStdStk) - } - } - }) - - ## selectdbtables - observe({ -cat("selectdbtables\n") - if (is.null(input$selectdbtables) ||(length(input$selectdbtables)==1 - && length(grep("-----",input$selectdbtables)))) - { - updateSelectInput(session, "selectdbvars", choices=list()) - } else { - tables = input$selectdbtables - if(length(grep("-----",tables))) tables <- setdiff(tables,tables[grep("-----",tables)]) - # Logic to restrict combining tables from different levels (e.g., tree with stand-level). - # Throw up warning, then have first table selection in level that threw error remain selected - while(length(tables)>1) - { - if(length(tables)==2 && "FVS_Cases" %in% tables) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary")) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary_East")) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary_Metric")) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2")) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2_East")) break - if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2_Metric")) break - '%notin%' = Negate('%in%') - if (any(tables %in% globals$simLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("This composite table combination in not allowed")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - if (any(tables %in% globals$stdLvl) && any(tables %notin% globals$stdLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("Stand-level tables can only be combined with other stand-level tables")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - if (any(tables %in% globals$specLvl) && any(tables %notin% globals$specLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("Species-level tables can only be combined with other species-level tables")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - # DBH-class tables cannot be combined with any other table - if (any(tables %in% globals$dClsLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("DBH-class tables cannot be combined with any other tables")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - # HT-class tables cannot be combined with any other table - if (any(tables %in% globals$htClsLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("HT-class tables cannot be combined with any other tables")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - # tree-level tables cannot be combined with any other table - if (any(tables %in% globals$treeLvl)) { - session$sendCustomMessage(type = "infomessage", - message = paste0("Tree-level tables cannot be combined with any other tables")) - tables <- tables[1] - globals$tableMessage=TRUE - updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), - selected=tables) - } - break - } - vars = lapply(tables,function (tb,dbd) paste0(tb,".",dbd[[tb]]),fvsOutData$dbLoadData) - vars = unlist(vars) - if (length(vars) == 0) return() - fvsOutData$dbVars <- vars - fvsOutData$dbSelVars <- vars - updateSelectInput(session=session, "selectdbvars",choices=as.list(vars), - selected=vars) - output$tbSel <-renderUI({ - HTML(tables) - }) - } - }) - - ## selectdbvars - observe({ -cat("selectdbvars\n") - if (!is.null(input$selectdbvars)) - { - # if CaseID is part of the variable set, make sure it is selected at least once - selidxCaseID=grep("CaseID",input$selectdbvars) - if (!length(selidxCaseID)) - { - idxCaseID=grep("CaseID",fvsOutData$dbVars) - if (length(idxCaseID)) - { - selvars=union(fvsOutData$dbVars[idxCaseID[1]],input$selectdbvars) - updateSelectInput(session=session, "selectdbvars",choices=as.list(fvsOutData$dbVars), - selected=selvars) - } - } - fvsOutData$dbSelVars <- input$selectdbvars -cat ("input$selectdbvars=",input$selectdbvars,"\n") - } - }) - - ## Custom Query - observe({ - if (input$leftPan == "Custom Query") - { -cat("Custom Query\n") - initTableGraphTools(globals,session,output,fvsOutData) - if (length(globals$customQueries) == 0) - { - loadObject(dbGlb$prjDB,"customQueries") - if (exists("customQueries")) globals$customQueries=customQueries - } - if (length(globals$customQueries) == 0) - { - updateSelectInput(session=session, inputId="sqlSel", - choices=list(),selected=0) - } else { - sels = as.list(as.character(1:length(globals$customQueries))) - names(sels) = names(globals$customQueries) - updateSelectInput(session=session, inputId="sqlSel", choices=sels, - selected = 0) - } - updateTextInput(session=session, inputId="sqlTitle", value="") - updateTextInput(session=session, inputId="sqlQuery", value="") - updateTextInput(session=session, inputId="sqlOutput", label="", value="") - output$table <- renderTable(NULL) - } - }) - - ## sqlRunQuery - observe({ - if (input$sqlRunQuery > 0) - { -cat ("sqlRunQuery\n") - isolate({ - msgtxt = character(0) - qrys = trim(gsub("\n"," ",removeComment(input$sqlQuery)," ",input$sqlQuery)) - qrys = scan(text=qrys,sep=";",what="",quote="",quiet=TRUE) - qrys = qrys[nchar(qrys)>0] - output$table <- renderTable(NULL) - iq = 0 - dfrtn = NULL - # attempt to attach the input database is attached as "input" - attInput = if (!dbGlb$dbIcon@dbname %in% dbGetQuery(dbGlb$dbOcon,"PRAGMA database_list")$file) - try(dbExecute(dbGlb$dbOcon,paste0("attach database '",dbGlb$dbIcon@dbname, - "' as input"))) else NULL - for (qry in qrys) - { - iq = iq+1 -cat ("sqlRunQuery, qry=",qry,"\n") - res = try (dbGetQuery(dbGlb$dbOcon,qry)) - msgtxt = if (class(res) == "data.frame" && ncol(res) && nrow(res)) - paste0(msgtxt,"query ",iq," returned a data frame with ",nrow(res), - " rows and ",ncol(res)," cols\n") else - if (class(res) == "try-error") paste0(msgtxt,"query ",iq, - " returned\n",attr(res,"condition"),"\n") else - paste0(msgtxt,"query ",iq," ran\n") - updateTextInput(session=session, inputId="sqlOutput", label="", - value=msgtxt) - if (class(res) == "try-error") break - if (class(res) == "data.frame" && ncol(res) && nrow(res)) - { - for (col in 1:ncol(res)) if (class(res[[col]]) == "character") - res[[col]] = factor(res[[col]],unique(res[[col]])) - if (!is.null(res$Year)) res$Year = as.factor(res$Year) - fvsOutData$dbData = res - fvsOutData$render = res - fvsOutData$runs = character(0) - fvsOutData$dbVars = colnames(res) - fvsOutData$browseVars = colnames(res) - fvsOutData$dbSelVars = character(0) - fvsOutData$browseSelVars = colnames(res) - choices = as.list(c("None", - colnames(res)[unlist(lapply(res, is.factor))])) - updateSelectInput(session,"pivVar",choices=choices,selected="None") - updateSelectInput(session,"hfacet",choices=choices,selected="None") - updateSelectInput(session,"vfacet",choices=choices,selected="None") - updateSelectInput(session,"pltby", choices=choices,selected="None") - globals$settingChoices[["pivVar"]] = choices - globals$settingChoices[["hfacet"]] = choices - globals$settingChoices[["vfacet"]] = choices - globals$settingChoices[["pltby"]] = choices - choices = as.list(c("None", - colnames(res)[!unlist(lapply(res, is.factor))])) - globals$settingChoices[["dispVar"]] = choices - updateSelectInput(session,"dispVar",choices=choices,selected="None") - choices = as.list(colnames(res)) - globals$settingChoices[["xaxis"]] = choices - globals$settingChoices[["yaxis"]] = choices - updateSelectInput(session,"xaxis",choices=choices,selected=colnames(res)[1]) - updateSelectInput(session,"yaxis",choices=choices,selected=colnames(res)[1]) - if (input$outputRightPan != "Tables") - updateSelectInput(session,"outputRightPan",selected="Tables") - tableDisplayLimit = 5000 - if (nrow(res) > tableDisplayLimit) - { - msg=paste0("Table display limit exceeded. ", - tableDisplayLimit," of ",nrow(res)," displayed. Use Download table", - " to download all rows.") - output$tableLimitMsg<-renderText(msg) - res = res[1:tableDisplayLimit,,drop=FALSE] - } else output$tableLimitMsg<-NULL - output$table <- renderTable(res) - break - } - } - if (!is.null(attInput)) try(dbExecute(dbGlb$dbOcon,"detach database 'input'")) - }) - } - }) - -## sqlSave - observe({ - if (input$sqlSave > 0) - { -cat ("sqlSave\n") - isolate({ - if (is.null(input$sqlTitle) || input$sqlTitle == "") - { - newTit = paste0("Query ",length(globals$customQueries)+1) - updateTextInput(session=session, inputId="sqlTitle", value=newTit) - } else newTit = input$sqlTitle - globals$customQueries[[newTit]] = input$sqlQuery - customQueries = globals$customQueries - storeOrUpdateObject(dbGlb$prjDB,customQueries) - if (length(globals$customQueries) == 0) - { - updateSelectInput(session=session, inputId="sqlSel", - choices=list(),selected=0) - } else { - sels = as.list(as.character(1:length(globals$customQueries))) - names(sels) = names(globals$customQueries) - updateSelectInput(session=session, inputId="sqlSel", choices=sels, - selected = match(newTit,names(globals$customQueries))) - } - }) - } - }) - - ## sqlSel - observe({ -cat ("sqlSel input$sqlSel=",input$sqlSel," isnull=", - is.null(input$sqlSel),"\n") - updateTextInput(session=session, inputId="sqlTitle", value="") - updateTextInput(session=session, inputId="sqlOutput", value="") - updateTextInput(session=session, inputId="sqlQuery", value="") - output$table <- renderTable(NULL) - if (!is.null(input$sqlSel)) - { - sel = as.numeric(input$sqlSel) - if(is.na(sel)) sel = as.numeric(match(input$sqlSel,names(globals$customQueries))) -cat ("sqlSel sel=",sel,"\n") - if (length(globals$customQueries) >= sel || !is.null(sel)) - { - updateTextInput(session=session, inputId="sqlTitle", - value=names(globals$customQueries)[sel]) - updateTextInput(session=session, inputId="sqlQuery", - value=globals$customQueries[[sel]]) - } - } - }) - - ## sqlDelete - observe({ - if (input$sqlDelete > 0) - { - isolate ({ -cat ("sqlDelete is.null(input$sqlTitle)=",is.null(input$sqlTitle),"\n") - if (is.null(input$sqlTitle)) return() - globals$customQueries[[input$sqlTitle]] = NULL - customQueries = globals$customQueries - storeOrUpdateObject(dbGlb$prjDB,customQueries) - if (length(customQueries) > 0) - { - sels = as.list(as.character(1:length(globals$customQueries))) - names(sels) = names(globals$customQueries) - } else sels=list() - updateSelectInput(session=session, inputId="sqlSel", choices=sels, - selected = 0) - updateTextInput(session=session, inputId="sqlTitle", value="") - updateTextInput(session=session, inputId="sqlQuery", value="") - updateTextInput(session=session, inputId="sqlOutput", value="") - }) - } - }) - - ## sqlNew - observe({ - if (input$sqlNew > 0) - { -cat ("sqlNew\n") - updateSelectInput(session=session, inputId="sqlSel", selected = 0) - updateTextInput(session=session, inputId="sqlQuery", value="") - updateTextInput(session=session, inputId="sqlOutput", value="") - } - }) - - ## Explore - observe({ - if (input$leftPan == "Explore") - { - globals$exploring <- TRUE -cat ("Explore, length(fvsOutData$dbSelVars)=",length(fvsOutData$dbSelVars),"\n") - if (length(fvsOutData$dbSelVars) == 0) - { - initTableGraphTools(globals,session,output,fvsOutData) - output$table <- renderTable(NULL) - return() - } - withProgress(session, - { - iprg = 1 - setProgress(message = "Processing variable names", detail="", - value = iprg) - tbs = unique(unlist(lapply(strsplit(fvsOutData$dbSelVars,".",fixed=TRUE), - function (x) x[1]))) - if (length(tbs) == 0) return() - cols = unique(unlist(lapply(strsplit(fvsOutData$dbSelVars,".",fixed=TRUE), - function (x) x[2]))) - if (length(cols) == 0) return() - tbgroup=c("CmpMetaData"="0","CmpSummary"=1, "CmpSummary_East"=1, - "CmpSummary2"=1, "CmpSummary2_East"=1,"CmpSummary2_Metric"=1, - "CmpCompute"=1, "CmpStdStk"=1, "CmpStdStk_East"=1, "CmpStdStk_Metric"=1, - "StdStk"=3, "StdStk_East"=3, "StdStk_Metric"=3, "FVS_ATRTList"=8, - "FVS_Cases"=2, "FVS_Climate"=4, "FVS_Compute"=2, "FVS_CutList"=8, - "FVS_EconHarvestValue"=2, "FVS_EconSummary"=2, "FVS_BurnReport"=2, - "FVS_CanProfile"=5, "FVS_Carbon"=2, "FVS_SnagDet"=6, "FVS_Down_Wood_Cov"=2, - "FVS_Down_Wood_Vol"=2, "FVS_Consumption"=2, "FVS_Hrv_Carbon"=2, - "FVS_Mortality"=2, "FVS_PotFire_East"=2, "FVS_PotFire"=2, "FVS_SnagSum"=2, - "FVS_Fuels"=2, "FVS_DM_Spp_Sum"=7, "FVS_DM_Spp_Sum_Metric"=7, - "FVS_DM_Stnd_Sum"=2, "FVS_DM_Stnd_Sum_Metric"=2, "FVS_DM_Sz_Sum"=2, "FVS_DM_Sz_Sum_Metric"=2, - "FVS_RD_Sum"=2, "FVS_RD_Det"=2, "FVS_RD_Beetle"=2, "FVS_StrClass"=2, - "FVS_Summary_East"=2, "FVS_Summary"=2, "FVS_TreeList"=8,"FVS_ATRTList"=8, - "FVS_CutList"=8,"FVS_TreeList_East"=8,"FVS_ATRTList_East"=8,"FVS_CutList_East"=8, - "FVS_TreeList_Metric"=8,"FVS_ATRTList_Metric"=8,"FVS_CutList_Metric"=8, - "FVS_DM_Treelist"=8,"FVS_DM_Treelist_Metric"=8) - tbg = tbgroup[tbs] - arena = is.na(tbg) - if (any(arena)) - { - tbg[arena] = 3 - names(tbg)[arena] = tbs[arena] - } - if (max(tbg) > 1 && ! ("FVS_Cases" %in% tbs)) tbg = c("FVS_Cases"=2,tbg) - dat=NULL - for (tb in names(sort(tbg))) - { -cat ("tb=",tb," len(dat)=",length(dat),"\n") - iprg = iprg+1 - setProgress(message = "Processing tables", detail=tb,value = iprg) - if (tb %in% c("CmpSummary","CmpSummary_East","CmpSummary2", - "CmpSummary2_East","CmpSummary2_Metric")) - { - dtab <- dbReadTable(dbGlb$dbOcon,tb) - if (tb %in% c("CmpSummary","CmpSummary_East")) - dtab <- ddply(dtab,.(MgmtID),.fun=function (x) - setupSummary(x,composite=TRUE)) else - dtab$RmvCode <- as.factor(dtab$RmvCode) - dtab$Year <- as.factor(dtab$Year) - dtab$MgmtID <- as.factor(dtab$MgmtID) - dat[[tb]] <- dtab - } else { - dtab = if ("CaseID" %in% dbListFields(dbGlb$dbOcon,tb)) - dbGetQuery(dbGlb$dbOcon,paste0("select * from ",tb, - " where CaseID in (select CaseID from temp.Cases)")) else - dbGetQuery(dbGlb$dbOcon,paste0("select * from ",tb)) - # fix the stand and stock table. - if (tb == "StdStk") - { - fix = grep ("Hrv",colnames(dtab)) - if (length(fix)) for (ifx in fix) dtab[[ifx]] = as.numeric(dtab[[ifx]]) - } else if (tb == "FVS_Summary" || tb == "FVS_Summary_East") - { - dtab <- ddply(dtab,.(CaseID),.fun=setupSummary) - dtab$ForTyp =as.factor(dtab$ForTyp) - dtab$SizeCls=as.factor(dtab$SizeCls) - dtab$StkCls =as.factor(dtab$StkCls) - } else if (tb == "FVS_Summary2" || tb == "FVS_Summary2_East") - { - dtab$ForTyp =as.factor(dtab$ForTyp) - dtab$SizeCls=as.factor(dtab$SizeCls) - dtab$StkCls =as.factor(dtab$StkCls) - dtab$RmvCode=as.factor(dtab$RmvCode) - } else if (tb == "FVS_Cases") dtab$RunTitle=trim(dtab$RunTitle) - cls = intersect(c(cols,"StandID","MgmtID","RunTitle","srtOrd"),colnames(dtab)) - if (length(cls) > 0) dtab = dtab[,cls,drop=FALSE] - for (col in colnames(dtab)) if (is.character(dtab[,col])) - dtab[,col] = as.factor(dtab[,col]) - if (!is.null(dtab$Year)) dtab$Year =as.factor(dtab$Year) - if (!is.null(dtab$TreeVal)) dtab$TreeVal =as.factor(dtab$TreeVal) - if (!is.null(dtab$PtIndex)) dtab$PtIndex =as.factor(dtab$PtIndex) - if (!is.null(dtab$SSCD)) dtab$SSCD =as.factor(dtab$SSCD) - rownames(dtab) = 1:nrow(dtab) - # fix the species column. - spcd=paste0("Species",input$spCodes) - if (spcd %in% names(dtab)) - { - if (is.null(dtab$Species)) dtab$Species=dtab[,spcd] else - { - na=is.na(dtab$Species) - dtab$Species = as.character(dtab$Species) - dtab$Species[na] = as.character(dtab[na,spcd]) - dtab$Species = as.factor(dtab$Species) - } - } - dat[[tb]] = dtab - } - } -cat ("Explore, len(dat)=",length(dat),"\n") - if (length(dat) == 0) - { - initTableGraphTools(globals,session,output,fvsOutData) - return() - } - iprg = iprg+1 - setProgress(message = "Merging selected tables", detail = "", value = iprg) - inch = 0 - mdat = NULL - for (tb in names(dat)) - { -cat ("tb=",tb," is.null(mdat)=",is.null(mdat),"\n") - if (is.null(mdat)) mdat = dat[[tb]] else - { - mrgVars = intersect(names(mdat),c("CaseID","Year","StandID","MgmtID")) - mrgVars = intersect(mrgVars,names(dat[[tb]])) - setProgress(message = "Merging selected tables", - detail = tb, value = iprg) -cat ("tb=",tb," mrgVars=",mrgVars,"\n") - merged = merge(mdat,dat[[tb]], by=mrgVars) - mdat = if (nrow(merged)) merged else - { - common = intersect(names(mdat),names(dat[[tb]])) - unique = setdiff(names(dat[[tb]]),c(common,mrgVars)) - nd=matrix(data=NA,ncol=length(unique),nrow=nrow(mdat)) - colnames(nd)=unique - mdat=cbind(mdat,nd) - common = intersect(names(mdat),names(dat[[tb]])) - unique = setdiff(names(mdat),c(common,mrgVars,"MgmtID","RunTitle")) - nd=matrix(data=NA,ncol=length(unique),nrow=nrow(dat[[tb]])) - colnames(nd)=unique - nd = data.frame(nd) - idr=match(as.character(dat[[tb]]$CaseID),as.character(dat$FVS_Cases$CaseID)) - nd=cbind(dat$FVS_Cases[idr,c("MgmtID","RunTitle")],nd) - dat[[tb]]=cbind(dat[[tb]],nd) - rbind(mdat,dat[[tb]]) - } - } - } - if (!is.null(mdat$CaseID)) - { - mdat=merge(mdat,dbGetQuery(dbGlb$dbOcon,"select _RowID_,CaseID from temp.Cases"),by="CaseID") - mdat=mdat[order(mdat$rowid,1:nrow(mdat)),] - mdat$rowid=NULL - } - fvsOutData$dbData = mdat - iprg = iprg+1 - # do rep assignments - setProgress(message = "Setting stand reps", detail = "", value = iprg) - newSid = as.character(fvsOutData$dbData$StandID) - icid = as.integer(fvsOutData$dbData$CaseID) - imid = as.integer(fvsOutData$dbData$MgmtID) - isid = as.integer(fvsOutData$dbData$StandID)+as.integer(imid*1000000) - sidch = FALSE - for (id in unique(isid)) - { - nq = unique(icid[isid==id]) - if (length(nq)==1) next - mq = unique(imid[isid==id]) - sidch = TRUE - rep = 0 - for (iq in nq) - { - rep = rep+1 - chng = icid==iq - newSid[chng] = sprintf("%s r%03i",newSid[chng],rep) - } - } - if (sidch) fvsOutData$dbData$StandID = as.factor(newSid) - iprg = iprg+1 - setProgress(message = "Processing variables", detail=tb,value = iprg) - mdat = fvsOutData$dbData - vars = colnames(mdat) - sby = NULL - for (v in c("MgmtID","StandID","Stand_CN","Year","RmvCode","PtIndex", - "TreeIndex","Species","DBHClass")) if (v %in% vars) sby=c(sby,v) - sby = if (length(sby)) - { - cmd = paste0("order(",paste(paste0("mdat$",sby),collapse=","), - if("srtOrd" %in% vars) ",mdat$srtOrd)" else ")") -cat ("cmd=",cmd,"\n") - sby = try(eval(parse(text=cmd))) - if (class(sby) == "try-error") NULL else sby - } else NULL - vars = intersect(c("MgmtID","Stand_CN","StandID","Year", - "Species","DBHClass"),colnames(mdat)) - vars = c(vars,setdiff(colnames(mdat),vars)) - endvars = intersect(c("SamplingWt","Variant","RunTitle", - "Groups","RunDateTime","KeywordFile","CaseID"),vars) - vars = union(setdiff(vars,endvars),endvars) - if (!is.null(sby)) mdat = mdat[sby,vars,drop=FALSE] - mdat$srtOrd = NULL - vars = colnames(mdat) - if (length(vars) == 0) - { - setProgress(value = NULL) - return() - } - iprg = iprg+1 - setProgress(message = "Loading selection widgets", detail = "", value = iprg) - if (is.null(mdat$RunTitle)) - updateSelectInput(session, "stdtitle", choices = list("None loaded"), - selected = NULL) else - updateSelectInput(session, "stdtitle", - choices=as.list(levels(mdat$RunTitle)), selected=levels(mdat$RunTitle)) - iprg = iprg+1 - setProgress(message = "Loading selection widgets", detail = "", value = iprg) - if (is.null(mdat$StandID)) - { - cho = "None loaded" - updateSelectInput(session,"stdid",choices =list(cho),selected = NULL) - } else { - cho = levels(mdat$StandID) - sel = cho - if (length(cho) > 5000) - { - cho = paste0("None loaded (",length(cho)," stands)") - sel = NULL - } - updateSelectInput(session,"stdid",choices=as.list(cho),selected=sel) - } - globals$exploreChoices$stdid = cho - if (is.null(mdat$Groups)) - { - cho = "None loaded" - updateSelectInput(session,"stdgroups",choices=as.list(cho),selected = NULL) - } else { - cho = sort(unique(unlist(lapply(levels(mdat$Groups), function (x) - trim(scan(text=x,what="character",sep=",",quiet=TRUE)))))) - updateSelectInput(session, "stdgroups",choices=as.list(cho),selected=cho) - } - globals$exploreChoices$stdgroups = cho - if (is.null(mdat$MgmtID)) - { - cho = "None loaded" - updateSelectInput(session,"mgmid",choices=as.list(cho),selected=0) - } else { - cho = levels(mdat$MgmtID) - updateSelectInput(session, "mgmid",choices=as.list(cho),selected=cho) - } - globals$exploreChoices$mgmid = cho - if (length(intersect(c("FVS_TreeList","FVS_ATRTList","FVS_CutList", - "FVS_TreeList_East","FVS_ATRTList_East","FVS_CutList_East", - "FVS_TreeList_Metric","FVS_ATRTList_Metric","FVS_CutList_Metric" - ),names(dat)))) - updateSelectInput(session, "plotType",selected="scat") else - if (length(intersect(c("StdStk","CmpStdStk","StdStk_East", - "CmpStdStk_East","StdStk_Metric","CmpStdStk_Metric"),names(dat)))) - updateSelectInput(session, "plotType",selected="bar") else - updateSelectInput(session, "plotType",selected="line") - iprg = iprg+1 - setProgress(message = "Loading selection widgets", detail = "", value = iprg) - if (is.null(mdat$Year)) - { - cho = "None loaded" - updateSelectInput(session,"year",choices=as.list(cho),selected = NULL) - } else { - cho = levels(mdat$Year) - isel = max(1,length(cho) %/% 2) - sel = if (length(intersect(c("FVS_TreeList","FVS_ATRTList","FVS_CutList", - "FVS_TreeList_East","FVS_ATRTList_East","FVS_CutList_East", - "StdStk","StdStk_East","StdStk_Metric","CmpStdStk","CmpStdStk_East", - "CmpStdStk_Metric"),names(dat)))) - cho[isel] else cho - updateSelectInput(session, "year", choices=as.list(cho), selected=sel) - } - globals$exploreChoices$year = cho - if (is.null(mdat$Species)) - { - cho = "None loaded" - updateSelectInput(session, "species", choices = list(cho), selected = NULL) - } else { - cho = levels(mdat$Species) - updateSelectInput(session, "species", - choices=as.list(cho), selected=setdiff(cho,"All")) - } - globals$exploreChoices$species = cho - if (is.null(mdat$DBHClass)) - { - cho = "None loaded" - updateSelectInput(session,"dbhclass",choices=list(cho),selected = NULL) - } else { - cho = levels(mdat$DBHClass) - sel = if ("All" %in% cho) "All" else cho - updateSelectInput(session, "dbhclass", choices=as.list(cho), selected=sel) - } - globals$exploreChoices$dbhclass = cho - iprg = iprg+1 - setProgress(message = "Finishing", detail = "", value = iprg) - fvsOutData$dbData <- mdat - vars <- c("Select all",vars) - fvsOutData$browseVars <- vars - varsList <- as.list(vars) - vars = setdiff(vars,c("Select all","Stand_CN","KeywordFile", - "SamplingWt","Variant","Version", - "RV", "RunDateTime")) - fvsOutData$browseSelVars <- vars - updateCheckboxGroupInput(session, "browsevars", choices=varsList, - selected=vars,inline=TRUE) - setProgress(value = NULL) - }, min=1, max=12) - } - }) - - ## renderTable - renderTable <- function (dat) - { -cat ("renderTable, is.null=",is.null(dat)," nrow(dat)=",nrow(dat),"\n") - if (!is.null(dat) && ncol(dat)==0){ - renderRHandsontable(NULL) - return() - } - if (!is.null(dat) && nrow(dat) > 0) - { - dat = lapply(dat,function (x) - if (is.factor(x)) levels(x)[as.numeric(x)] else x) - dat = as.data.frame(dat) - for (i in 1:ncol(dat)) - if (class(dat[[i]]) == "numeric") dat[[i]] = round(dat[[i]],3) - } - if(length(grep("X_",names(dat)))){ - idxs <- grep("X_",names(dat)) - for(i in 1:length(grep("X_",names(dat)))){ - names(dat)[idxs[i]] <- sub('.', '', names(dat)[idxs[i]]) - } - } - renderRHandsontable(if (is.null(dat) || nrow(dat)==0) NULL else - rhandsontable(dat,readOnly=TRUE,useTypes=FALSE,contextMenu=FALSE, - width="100%",height=700)) - } - - ## browsevars - observe({ - if (is.null(input$browsevars)) return() -cat("filterRows and/or pivot\n") - if(fvsOutData$browseVars[1]==input$browsevars[1]){ - fvsOutData$browseSelVars <- fvsOutData$browseVars[-1] - updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), - selected=fvsOutData$browseVars,inline=TRUE) - globals$selAllVars = TRUE - if(length(input$browsevars)==(length(fvsOutData$browseVars)-1) && globals$selAllVars){ - fvsOutData$browseSelVars <- input$browsevars[-1] - updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), - selected=fvsOutData$browseSelVars,inline=TRUE) - globals$selAllVars = FALSE - } - }else if (fvsOutData$browseVars[1]!=input$browsevars[1] && globals$selAllVars){ - fvsOutData$browseSelVars <- character() - updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), - selected=fvsOutData$browseSelVars,inline=TRUE) - globals$selAllVars = FALSE - }else fvsOutData$browseSelVars <- input$browsevars - dat = if (length(input$stdtitle) || length(input$stdgroups) || - length(input$stdid) || length(input$mgmid) || - length(input$year) || length(input$species) || - length(input$dbhclass)) - fvsOutData$dbData[filterRows(fvsOutData$dbData, input$stdtitle, input$stdgroups, - input$stdid, input$mgmid, input$year, input$species, input$dbhclass) - ,fvsOutData$browseSelVars,drop=FALSE] else - fvsOutData$dbData[,fvsOutData$browseSelVars,drop=FALSE] - if (!is.null(input$pivVar) && input$pivVar != "None" && - !is.null(input$dispVar) && input$dispVar != "None") - dat = pivot(dat,input$pivVar,input$dispVar) - fvsOutData$render = dat - tableDisplayLimit = 5000 - if (nrow(dat) > tableDisplayLimit) - { - msg=paste0("Table display limit exceeded. ", - tableDisplayLimit," of ",nrow(dat)," displayed. Use Download table", - " to download all rows.") - output$tableLimitMsg<-renderText(msg) - dat = dat[1:tableDisplayLimit,,drop=FALSE] - } else output$tableLimitMsg<-NULL - output$table <- renderTable(dat) - }) - - ##Graphs - observe({ - if (input$leftPan == "Explore" && input$outputRightPan == "Graphs") - { -cat ("Graphs pan hit\n") - # update color pallet - for (i in 1:length(cbbPalette)) - updateColourInput(session=session,inputId=paste0("color",i),value=cbbPalette[i]) - loadObject(dbGlb$prjDB,"GraphSettings") - if (!exists("GraphSettings")) GraphSettings=list("None"=list()) - updateSelectInput(session=session, inputId="OPsettings", choices=names(GraphSettings), - selected="None") - updateTextInput(session=session, "OPname", value = "") - output$OPmessage=NULL - } - }) - - ## OPsettings - observe({ - if (!is.null(input$OPsettings)) - { - input$OPredo - isolate({ -cat ("OPsettings hit, OPsettings=",input$OPsettings,"\n") - loadObject(dbGlb$prjDB,"GraphSettings") - if (!exists("GraphSettings") || - length(GraphSettings[[input$OPsettings]])<1 || - input$OPsettings == "None") - { - output$OPmessage=NULL - updateTextInput(session=session, "OPname", value = "") - } else { - updateTextInput(session=session, "OPname", value = input$OPsettings) - if (all(unlist(GraphSettings[[input$OPsettings]][["selectdbtables"]]) %in% - input$selectdbtables) && - all(unlist(GraphSettings[[input$OPsettings]][["dbvars"]]) %in% - input$selectdbvars)) - { - output$OPmessage=NULL - msg = setGraphSettings(session,globals,GraphSettings[[input$OPsettings]]) -cat ("msg=",msg,"\n") - if (! is.null(msg)) output$OPmessage= - renderUI(HTML(paste0('

', - "Warning(s):
",paste0(msg,collapse="
"),"

"))) - } else output$OPmessage=renderUI(HTML(paste0('

', - "Error: The data needed for this setting was not selected ", - "when you picked data to load.
Table(s) needed: ", - paste0(GraphSettings[[input$OPsettings]][["selectdbtables"]], - collapse=", "),"

"))) - } - }) - } - }) - - ## OPsave - observe({ - if (input$OPsave > 0) - { - output$OPmessage=NULL - isolate({ -cat ("OPsave hit, OPname=",input$OPname,"\n") - loadObject(dbGlb$prjDB,"GraphSettings") - if (!exists("GraphSettings")) - { - GraphSettings=list("None"=list()) - attr(GraphSettings[[1]],"setTime")=.Machine$integer.max - } - if (nchar(input$OPname)==0) - { - setName=paste0("Setting ",length(GraphSettings)+1) - updateTextInput(session=session,inputId="OPname",value=setName) - } else setName=input$OPname - GraphSettings[[setName]]=getGraphSettings(input) - attr(GraphSettings[[setName]],"setTime")=as.integer(Sys.time()) - GraphSettings <- GraphSettings[order(unlist(lapply(GraphSettings, - function(x) attr(x,"setTime"))),decreasing = TRUE)] - storeOrUpdateObject(dbGlb$prjDB,GraphSettings) - updateSelectInput(session=session, inputId="OPsettings", choices= - names(GraphSettings),selected=setName) - }) - } - }) - - ## OPdel - observe({ - if (input$OPdel > 0) - { - isolate({ -cat("OPdel hit, input$OPname=",input$OPname,"\n") - output$OPmessage=NULL - loadObject(dbGlb$prjDB,"GraphSettings") - if (!exists("GraphSettings")) return() - if (input$OPname == "None") return() - if (is.null(GraphSettings[[input$OPname]])) return() - GraphSettings[[input$OPname]] = NULL - if (length(GraphSettings)==0) - { - updateSelectInput(session=session, inputId="OPsettings", choices=list()) - removeObject(dbGlb$prjDB,"GraphSettings") - } else { - updateSelectInput(session=session, inputId="OPsettings", choices= - names(GraphSettings),selected="None") - storeOrUpdateObject(dbGlb$prjDB,GraphSettings) - } - updateTextInput(session=session, "OPname", value = "") - }) - } - }) - - ## browsevars/plotType - observe({ - if (!is.null(input$browsevars) && !is.null(input$plotType)) - { -cat ("browsevars/plotType, input$plotType=",input$plotType," globals$gFreeze=",globals$gFreeze,"\n") - fvsOutData$browseSelVars <- input$browsevars - cats = unlist(lapply(fvsOutData$dbData,is.factor)) - cats = names(cats)[cats] - cats = intersect(cats,input$browsevars) - cont = union("Year",setdiff(input$browsevars,cats)) - if(length(cont) > 1 && cont[2]=="Select all") cont <- cont[-2] - spiv = if (length(input$pivVar) && - input$pivVar %in% cats) input$pivVar else "None" - sdisp = if (length(input$dispVar) && - input$dispVar %in% input$browsevars) input$dispVar else "None" - ccont = c("None",setdiff(input$browsevars,spiv)) - bb = intersect(ccont,cats) # put the factors at the end of the choices - ccont = c(setdiff(ccont,bb),bb) - updateSelectInput(session,"pivVar",choices=as.list(c("None",cats)), - selected=spiv) - updateSelectInput(session,"dispVar",choices=as.list(ccont), - selected=sdisp) - if (globals$gFreeze) return() - isolate({ - curX = input$xaxis - curY = input$yaxis - if (input$plotType=="line") { - selx = if (is.null(curX)) "Year" else curX - selx = if (selx %in% cont) selx else - if (length(cont) > 0) cont[1] else NULL - globals$settingChoices[["xaxis"]] = as.list(cont) - updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=selx) - sel = if (is.null(curY)) "BA" else curY - sel = if (sel %in% cont) sel else - if (length(cont) > 0) cont[1] else NULL - if (sel == selx && length(cont) > 1) - { - sel = grep("BA",cont)[1] - sel = if (is.na(sel)) cont[2] else cont[sel] - } - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) - } else if (input$plotType == "scat") { - sel = if (is.null(curX)) "DBH" else curX - sel = if (sel %in% cont) sel else - if (length(cont) > 0) cont[1] else NULL - updateSelectInput(session, "xaxis",choices=as.list(cont), selected=sel) - sel = if (is.null(curY)) "DG" else curY - sel = if (sel %in% cont) sel else - if (length(cont) > 0) cont[1] else NULL - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) - } else if (input$plotType == "bar") { - def = if ("Species" %in% cats) "Species" else NULL - def = if (is.null(def) && "Year" %in% cats) "Year" else cats[1] - sel = if (!is.null(curX) && curX %in% cats) curX else def - globals$settingChoices[["xaxis"]] = as.list(cats) - updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=sel) - sel = if (!is.null(curX) && curX %in% cont) curX else cont[1] - if (sel=="Year" && length(cont) > 1) sel = cont[2] - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) - } else if (input$plotType == "box") { - def = if ("Species" %in% cats) "Species" else NULL - def = if (is.null(def) && "Year" %in% cats) "Year" else cats[1] - sel = if (!is.null(curX) && curX %in% cats) curX else def - globals$settingChoices[["xaxis"]] = as.list(cats) - updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=sel) - sel = if (!is.null(curX) && curX %in% cont) curX else cont[1] - if (sel=="Year" && length(cont) > 1) sel = cont[2] - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) - } else if (input$plotType=="DMD") { - updateRadioButtons(session=session,inputId="XUnits",selected="QMD") - updateRadioButtons(session=session,inputId="YUnits",selected="Tpa") - updateRadioButtons(session=session,inputId="YTrans",selected="log10") - updateRadioButtons(session=session,inputId="XTrans",selected="log10") - globals$settingChoices[["xaxis"]] = as.list(cont) - updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected="QMD") - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected="Tpa") - } else if (input$plotType=="StkCht") { - globals$settingChoices[["xaxis"]] = as.list(cont) - updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected="Tpa") - globals$settingChoices[["yaxis"]] = as.list(cont) - updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected="BA") - } - updateSliderInput(session, "transparency", - value = if(input$plotType == "scat") .3 else 0.) - if (input$plotType!="DMD") - { - updateRadioButtons(session=session,inputId="YTrans",selected="identity") - updateRadioButtons(session=session,inputId="XTrans",selected="identity") - } - sel = if ("StandID" %in% cats && input$plotType != "box") "StandID" else "None" - updateSelectInput(session=session, inputId="hfacet",choices=as.list(c("None",cats)), - selected=sel) - sel = if ("MgmtID" %in% cats && input$plotType != "box") "MgmtID" else "None" - updateSelectInput(session=session, inputId="vfacet",choices=as.list(c("None",cats)), - selected=sel) - sel = if ("Species" %in% cats && input$plotType != "box") "Species" else "None" - updateSelectInput(session=session, inputId="pltby",choices=as.list(c("None",cats)), - selected=sel) -cat ("end of browsevars/plotType\n") - }) - } - }) - - ## yaxis, xaxis regarding the Y- and XUnits for DMD - observe({ - if (globals$gFreeze) return() - if (!is.null(input$yaxis) && input$yaxis %in% c("Tpa","QMD")) - updateRadioButtons(session=session,inputId="YUnits", - selected=input$yaxis) - if (!is.null(input$xaxis) && input$xaxis %in% c("Tpa","QMD")) - updateRadioButtons(session=session,inputId="XUnits", - selected=input$xaxis) - }) - ## Set a tool to "None" if the same level is selected by another tool (doesn't - ## apply to axes selection - observe({ - if (is.null(input$pltby) || input$pltby == "None" || globals$gFreeze) return() - isolate({ - if (all(!c(is.null(input$pltby),is.null(input$xaxis),is.null(input$pltby), - is.null(input$yaxis))) && - (input$pltby == input$xaxis || input$pltby == input$yaxis)) - { - updateSelectInput(session=session, inputId="pltby", selected="None") - return() - } - if (input$pltby == input$vfacet) - updateSelectInput(session=session, inputId="vfacet", selected="None") - if (input$pltby == input$hfacet) - updateSelectInput(session=session, inputId="hfacet", selected="None") - }) }) - - ## vfacet change - observe({ -cat ("vfacet change, globals$gFreeze=",globals$gFreeze,"\n") - if (is.null(input$vfacet) || input$vfacet == "None" || globals$gFreeze) return() - isolate({ - if (!is.null(input$xaxis) && !is.null(input$yaxis) && - (input$vfacet == input$xaxis || input$vfacet == input$yaxis)) - { - updateSelectInput(session=session, inputId="vfacet", selected="None") - return() - } - if (!is.null(input$pltby) && input$vfacet == input$pltby) - updateSelectInput(session=session, inputId="pltby", selected="None") - if (input$vfacet == input$hfacet) - updateSelectInput(session=session, inputId="hfacet", selected="None") - }) }) - - ## hfacet change - observe({ -cat ("hfacet change, globals$gFreeze=",globals$gFreeze,"\n") - if (is.null(input$hfacet) || input$hfacet == "None" || globals$gFreeze) return() - isolate({ - if (!is.null(input$xaxis) && !is.null(input$yaxis) && - (input$hfacet == input$xaxis || input$hfacet == input$yaxis)) - { - updateSelectInput(session=session, inputId="hfacet", selected="None") - return() - } - if (!is.null(input$pltby) && input$hfacet == input$pltby) - updateSelectInput(session=session, inputId="pltby", selected="None") - if (input$hfacet == input$vfacet) - updateSelectInput(session=session, inputId="vfacet", selected="None") - }) }) - - ## renderPlot - output$outplot <- renderImage( - { -cat ("renderPlot\n") - output$plotMessage=NULL - nullPlot <- function (msg="Select different data, variables, plot type, or facet settings.") - { - outfile = "www/nullPlot.png" - if (!file.exists(outfile)) - { - CairoPNG(outfile, width=3, height=2, res=72, units="in", pointsize=12) - plot.new() - text(x=.5,y=.5,"Nothing to graph",col="red") - dev.off() - } - output$plotMessage=renderText(msg) - list(src = outfile) - } - if (input$leftPan == "Load" || (length(input$xaxis) == 0 && - length(input$yaxis) == 0)) return(nullPlot()) - output$plotMessage=renderText(NULL) - - vf = if (input$vfacet == "None") NULL else input$vfacet - hf = if (input$hfacet == "None") NULL else input$hfacet - pb = if (input$pltby == "None") NULL else input$pltby - needVars = unique(c(vf,hf,pb,input$xaxis,input$yaxis)) - dat = if (input$leftPan == "Custom Query") fvsOutData$dbData else - droplevels(fvsOutData$dbData[filterRows(fvsOutData$dbData, input$stdtitle, - input$stdgroups, input$stdid, input$mgmid, input$year, input$species, - input$dbhclass),]) - if (nrow(dat)==0) return(nullPlot("No observations using these selections")) - # fix DBHClass if it is in the data. - if (!is.null(dat$DBHClass)) - { - mlv=setdiff(input$dbhclass,levels(dat$DBHClass)) - if (length(mlv)) - { - # this bit makes sure CaseID is first - if(!length(grep("CmpStdStk",input$selectdbtables))) - byset=c("CaseID",setdiff(names(dat)[unlist(lapply(dat,is.factor))], - c("CaseID", "MgmtID","StandID","DBHClass","RunTitle"))) else - byset=c(setdiff(names(dat)[unlist(lapply(dat,is.factor))], - c("CaseID","MgmtID","StandID","DBHClass","RunTitle"))) - newrows = ddply(dat,byset,function(x) x[1,]) - newrows[,!unlist(lapply(dat,is.factor))]=0 - newrows$DBHClass=as.character(newrows$DBHClass) - dat$DBHClass=as.character(dat$DBHClass) - for (lms in mlv) - { - newrows$DBHClass = lms - dat=rbind(dat,newrows) - } - dat$DBHClass=factor(as.character(dat$DBHClass)) - cmd=paste0("idx=with(dat,order(",paste0(c(byset,"DBHClass"),collapse=","),"))") - eval(parse(text=cmd)) - dat = dat[idx,] - } - } # end of DBHClass fixup - if (!is.null(pb) && pb=="Groups" && length(input$stdgroups) && length(levels(dat$Groups))) - { - for (il in 1:length(levels(dat$Groups))) - { - levs = trim(unlist(strsplit(levels(dat$Groups)[il],","))) - newl = paste0(intersect(levs,input$stdgroups),collapse=", ") - levels(dat$Groups)[il] = newl - } - } - if (length(setdiff(needVars,names(dat)))) return(nullPlot()) -cat ("vf=",vf," hf=",hf," pb=",pb," xaxis=",input$xaxis," yaxis=",input$yaxis,"\n") - if (is.null(input$xaxis) || is.null(input$yaxis)) return (nullPlot("Select both X- and Y-axes")) - if (!is.null(hf) && nlevels(dat[,hf]) > 9) - { -cat ("hf test, nlevels(dat[,hf])=",nlevels(dat[,hf]),"\n") - return (nullPlot(paste0("Number of horizontal facets= ",nlevels(dat[,hf]),"> 9"))) - } - if (!is.null(vf) && nlevels(dat[,vf]) > 9) - { -cat ("vf test hit, nlevels(dat[,vf])=",nlevels(dat[,vf]),"\n") - return (nullPlot(paste0("Number of vertical facets= ",nlevels(dat[,vf]),"> 9"))) - } - chk = if ("RunTitle" %in% c(input$xaxis, vf, hf, pb, input$yaxis)) - c("RunTitle","StandID","Year") else c("MgmtID","StandID","Year") - if ( ! input$plotType %in% c("scat","box")) for (v in chk) - { - if (input$plotType %in% c("line","DMD","StkCht") && v=="Year") next - if (v %in% names(dat) && nlevels(dat[[v]]) > 1 && - ! (v %in% c(input$xaxis, vf, hf, pb, input$yaxis))) - return(nullPlot(paste0("Variable '",v,"' has ",nlevels(dat[[v]])," levels and ", - " therefore must be an axis, plot-by code, or a facet."))) - } - pltp = input$plotType - if (input$xaxis == "Year" && !(pltp %in% c("bar","box"))) dat$Year = as.numeric(as.character(dat$Year)) - nlv = 1 + (!is.null(pb)) + (!is.null(vf)) + (!is.null(hf)) - vars = c(input$xaxis, vf, hf, pb, input$yaxis) - nd = NULL - specOpts <- c("Species","SpeciesFVS","SpeciesPLANTS","SpeciesFIA") - sumOnSpecies= (all(!specOpts %in% vars) && any(specOpts %in% names(dat)) && - nlevels(dat$Species)>1) - sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && - nlevels(dat$DBHClass)>1 - for (v in vars[(nlv+1):length(vars)]) - { - if (is.na(v) || !v %in% names(dat)) return(nullPlot()) - pd = dat[,c(vars[1:nlv],v),drop=FALSE] - names(pd)[ncol(pd)] = "Y" - if (sumOnSpecies) pd = cbind(pd,Species =dat$Species) - if (sumOnDBHClass)pd = cbind(pd,DBHClass=dat$DBHClass) - nd = rbind(nd, data.frame(pd,Legend=v,stringsAsFactors=FALSE)) - } -cat("sumOnSpecies=",sumOnSpecies," sumOnDBHClass=",sumOnDBHClass,"\n") - if (sumOnSpecies) - { - nd=subset(nd,Species!="All") - nd$Species="Sum" - } - if (sumOnDBHClass) - { - nd=subset(nd,DBHClass!="All") - nd$DBHClass="Sum" - } - if (sumOnSpecies || sumOnDBHClass) - { - nd=ddply(nd,setdiff(names(nd),"Y"),.fun=function (x) sum(x$Y)) - names(nd)[ncol(nd)]="Y" - } - if (nlevels(nd[[input$xaxis]])>7 && max(nchar(levels(nd[[input$xaxis]]))) > 6 && - isolate(input$XlabRot) == "0" && !globals$gFreeze) - updateSelectInput(session=session,inputId="XlabRot",selected="90") - hrvFlag = NULL - if (input$plotType %in% c("line","DMD","StkCht")) - { - if (is.null(dat[["RmvCode"]])) - { - rtpa = grep ("RTpa",names(dat))[1] - if (!is.null(dat$Year) && !is.null(rtpa) && !is.na(rtpa) && nrow(dat)>1) - { - hrvFlag = vector(mode="logical",length=nrow(pd)) - i = 0 - while (i < nrow(dat)-1) { - i = i+1; - if (dat$Year[i]==dat$Year[i+1] && dat[i+1,rtpa]>0) - { - hrvFlag[i]=TRUE - i=i+1 - } - } - } - } else hrvFlag = dat[["RmvCode"]] == 1 - } - nd = na.omit(nd) - omits = as.numeric(attr(nd,"na.action")) - if (length(nd) == 0) return(nullPlot()) - if (length(omits)) hrvFlag = hrvFlag[-omits] - rownames(nd)=1:nrow(nd) - names(nd)[match(input$xaxis,names(nd))] = "X" - if (!is.null(vf)) names(nd)[match(vf,names(nd))] = "vfacet" - if (!is.null(hf)) names(nd)[match(hf,names(nd))] = "hfacet" - legendTitle = "Legend" - if (!is.null(pb) && !is.null(nd$Legend)) - { - legendTitle = pb - nd$Legend = if (nlevels(as.factor(nd$Legend)) == 1) - nd[,pb] else paste(nd$Legend,nd[,pb],sep=":") - } - if (input$plotType %in% c("line","DMD","StkCht") && - length(unique(nd$X)) < 2) return(nullPlot( - "Selected plot type requires more than 1 unique value on the X-axis")) - if (!is.null(nd$vfacet)) nd$vfacet = ordered(nd$vfacet, levels=sort(unique(nd$vfacet))) - if (!is.null(nd$hfacet)) nd$hfacet = ordered(nd$hfacet, levels=sort(unique(nd$hfacet))) - if (!is.null(nd$Legend)) nd$Legend = ordered(nd$Legend, levels=sort(unique(nd$Legend))) - fg = if (!is.null(nd$vfacet) && !is.null(nd$hfacet)) facet_grid(vfacet~hfacet) else NULL - if (input$facetWrap == "Off") - { - fg = if (is.null(fg) && !is.null(nd$hfacet)) facet_grid(.~hfacet) else fg - fg = if (is.null(fg) && !is.null(nd$vfacet)) facet_grid(vfacet~.) else fg - } else { - fg = if (is.null(fg) && !is.null(nd$hfacet)) - facet_wrap(~hfacet,ncol=ceiling(sqrt(nlevels(nd$hfacet))),strip.position="top") else fg - fg = if (is.null(fg) && !is.null(nd$vfacet)) - facet_wrap(~vfacet,ncol=ceiling(sqrt(nlevels(nd$vfacet))),strip.position="right") else fg - } - if (pltp %in% c("bar","box")) nd$Y[nd$Y==0] = NA - mkgraphlab <- function (str) - { - str=trim(str) - if(nchar(str)<10) return(str) - if(substr(str,1,10)=="expression") - { - rtn = try(eval(parse(text=str))) - if (class(rtn)=="expression") return(rtn) - } - str - } - xxlab=if (nchar(input$xlabel)) mkgraphlab(input$xlabel) else input$xaxis - yylab=if (nchar(input$ylabel)) mkgraphlab(input$ylabel) else input$yaxis - grtit=if (nchar(input$ptitle)) mkgraphlab(input$ptitle) else input$ptitle - p = ggplot(data=nd) + fg + labs(x=xxlab,y=yylab,title=grtit) + - theme(text = element_text(size=9), - panel.background = element_rect(fill="gray95"), - axis.text = element_text(color="black")) - if (!is.null(fg)) p = p + - theme(strip.text.x = element_text(margin = margin(.025, .01, .025, .01, "in"))) + - theme(strip.text.y = element_text(margin = margin(.025, .01, .025, .01, "in"))) - colors = if (input$colBW == "B&W") - unlist(lapply(seq(0,.3,.05),function (x) rgb(x,x,x))) else - { - if (is.null(input$color1)) cbbPalette else - c(input$color1,input$color2,input$color3,input$color4, input$color5, input$color6, - input$color7,input$color8,input$color9,input$color10,input$color11,input$color12, - input$color13,input$color14,input$color15,input$color16,input$color17,input$color18) - } - colors = autorecycle(colors,nlevels(nd$Legend)) - linetypes = autorecycle(c("solid","dashed","dotted","dotdash","longdash","twodash"), - nlevels(nd$Legend)) - alpha = if (is.null(input$transparency)) .7 else (1-input$transparency) -cat ("Legend nlevels=",nlevels(nd$Legend)," colors=",colors,"\n") - p = p + theme(axis.text.x = element_text(angle = as.numeric(input$XlabRot), - hjust = if(input$XlabRot=="0") .5 else 1)) - p = p + theme(axis.text.y = element_text(angle = as.numeric(input$YlabRot), - hjust = if(input$YlabRot!="0") .5 else 1)) - p = p + scale_colour_manual(values=colors) - p = p + scale_fill_manual(values=colors) - p = p + scale_shape_manual(values=1:nlevels(nd$Legend)) - scale_linetype_manual(values=linetypes) - p = p + scale_linetype_manual(values=1:nlevels(nd$Legend)) -cat ("input$XTrans=",input$XTrans," input$YTrans=",input$YTrans,"\n") - xmin = as.numeric(input$XLimMin) - xmax = as.numeric(input$XLimMax) - xlim = if (!is.na(xmin) && !is.na(xmax) && xmin < xmax) c(xmin, xmax) else NULL - ymin = as.numeric(input$YLimMin) - ymax = as.numeric(input$YLimMax) - ylim = if (!is.na(ymin) && !is.na(ymax) && ymin < ymax) c(ymin, ymax) else NULL -cat("ylim=",ylim," xlim=",xlim,"\n") - ymaxlim = NA - xmaxlim = NA - DMDguideLines = NULL - if (input$plotType == "DMD") - { - sdis=input$SDIvals - for (xx in c(" ","\n","\t",",",";")) sdis = if (is.null(sdis)) - NULL else unlist(strsplit(sdis,split=xx)) - if (!is.null(sdis)) - { - maxSDI = max(na.omit(as.numeric(sdis))) - if (maxSDI == -Inf) {maxSDI=700; sdis = c(sdis,as.character(maxSDI))} - sdisn = NULL - for (xx in sdis) - { - li = nchar(xx) - nv = if (li>1 && substr(xx,li,li)=="%") - as.numeric(substr(xx,1,li-1))*.01*maxSDI else as.numeric(xx) - sdisn = c(sdisn,nv) - } -cat("sdisn=",sdisn,"\nXUnits=",input$XUnits," YUnits=",input$YUnits,"\n") - seqTpa = seq(5,3000,length.out=50) - seqQMD = seq(1,80,length.out=50) - for (SDI in sdisn) - { - xseq = if (input$XUnits=="Tpa") seqTpa else seqQMD - yseq = if (input$YUnits=="Tpa") - if (input$XUnits=="Tpa") seqTpa else - # Tpa = f(QMD,SDI) - SDI / (seqQMD/10)^1.605 else - if (input$XUnits=="QMD") seqQMD else - # QMD = f(Tpa,SDI) - exp(log(SDI/seqTpa) / 1.605)*10 - lineData = data.frame(xseq=xseq,yseq=yseq)[! yseq > Inf,] - ymaxlim = range(c(ymaxlim,lineData$yseq),na.rm=TRUE) - xmaxlim = range(c(xmaxlim,lineData$xseq),na.rm=TRUE) - DMDguideLines[[as.character(SDI)]] = lineData -cat("SDI=",SDI," ymaxlim=",ymaxlim," xmaxlim=",xmaxlim,"\n") - } - } - } - StkChtguideLines = NULL - if (input$plotType == "StkCht") - { - sdis=input$StkChtvals - for (xx in c(" ","\n","\t",",",";")) sdis = if (is.null(sdis)) - NULL else unlist(strsplit(sdis,split=xx)) - if (length(sdis)) - { - sdis = unlist(lapply(sdis,function(x) if(substr(x,nchar(x),nchar(x)) == "%") - x else paste0(x,"%"))) - for (i in 1:length(sdis)) - yptsba = c(70.2,80.9,89.5,96.5,102.5,107.5,111.9,115.7,119.0,121.8, - 124.4,126.6,128.9) - xptstpa = c(1430,928,657,492,383,308,253,212,180,155,135,119,105) - seqTpa = seq(10,max(2000,nd$X),length.out=100) - seqBA = 161.47029555*exp(-.02275259*(seqTpa^.5)) #found using nls() - ymaxlim = range(seqBA) - xmaxlim = range(seqTpa) - StkChtguideLines = list() - for (PCT in sdis) - { - pct = as.numeric(gsub("%","",PCT))*.01 - lineData = data.frame(xseq=seqTpa*pct,yseq=seqBA*pct) - StkChtguideLines[[as.character(PCT)]] = lineData - ymaxlim = range(c(ymaxlim,lineData$yseq),na.rm=TRUE) - xmaxlim = range(c(xmaxlim,lineData$xseq),na.rm=TRUE) - } - pcts = as.numeric(gsub("%","",sdis))*.01 - pm = min(pcts) - px = max(pcts) - StkChtrng = data.frame(X=c(xptstpa[1]*pm,xptstpa[1]*px,xptstpa*px,rev(xptstpa)*pm), - Y=c(yptsba[1]*pm,yptsba[1]*px,yptsba*px,rev(yptsba)*pm)) - } - } - ### end DMD...except for adding annotations, see below. - if (is.factor(nd$X)) nd$X = as.ordered(nd$X) - if (is.factor(nd$Y)) nd$Y = as.ordered(nd$Y) - if (pltp %in% c("DMD","StkCht")) pltp = "path" -cat ("pltp=",pltp," input$colBW=",input$colBW," hrvFlag is null=",is.null(hrvFlag),"\n") - brks = function (x,log=FALSE) - { - b = range(x,na.rm=TRUE) - if (log) { - b = pretty (log10(b), n = 4, min.n = 1) - b = ifelse(b<=.1,.1,b) - b = floor(10**b[!duplicated(b)]) - xx = 10**floor(log10(b)) - ceiling((b/xx))*xx - } else pretty(b, n=4, min.n = 1) - } - if (!is.factor(nd$X)) - { - rngx=range(if (!is.null(xlim)) xlim else range(c(nd$X,xmaxlim),na.rm=TRUE)) - if(input$XTrans == "log10") - { - brkx=brks(rngx,log=TRUE) - rngx=ifelse(rngx<=.01,.01,rngx) - p = p + scale_x_log10(breaks=brkx,limits=rngx) - } else { - brkx=brks(rngx) - if (! (pltp %in% c("bar","box"))) p = p + scale_x_continuous(breaks=brkx, - limits=rngx,guide=guide_axis(check.overlap = TRUE)) - } -cat("xlim=",xlim," rngx=",rngx," brkx=",brkx,"\n") - } else p = p + scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) - - if (!is.factor(nd$Y)) - { - rngy=range(if (!is.null(ylim)) ylim else range(c(nd$Y,ymaxlim),na.rm=TRUE)) - if(input$YTrans == "log10") - { - brky=brks(rngy,log=TRUE) - rngy=ifelse(rngy<.01,.01,rngy) - p = p + scale_y_log10(breaks=brky,limits=rngy) - } else { - brky=brks(rngy) - if (! (pltp %in% c("bar","box"))) p = p + scale_y_continuous(breaks=brky, - limits=rngy,guide = guide_axis(check.overlap = TRUE)) - } -cat("ylim=",ylim," rngy=",rngy," brky=",brky,"\n") - } else p = p + scale_y_discrete(guide = guide_axis(check.overlap = TRUE)) - # add the guidelines and annotation here (now that we know the range limits of x and y - if (!is.null(DMDguideLines)) - { - pltorder = sort(as.numeric(names(DMDguideLines)),decreasing=TRUE,index.return=TRUE)$ix - for (linetype in 1:length(pltorder)) - { - SDI = names(DMDguideLines)[pltorder[linetype]] - p = p + geom_line(aes(x=xseq,y=yseq),show.legend=FALSE,alpha=.4, - linetype=linetype,data=DMDguideLines[[SDI]]) - } - sq = seq(.95,0,-.05) - sq = if (input$YTrans=="log10") 10^(log10(rngy[2])*sq) else rngy[2]*sq - sq = sq[1:min(length(sq),length(pltorder))] - xs = if (input$XTrans=="log10") 10^(log10(rngx[2])*c(.75,.9)) else rngx[2]*c(.75,.9) - guidedf = do.call(rbind,lapply(sq,function(y) data.frame(ys=y,xs=xs))) - guidedf$SDI=unlist(lapply(names(DMDguideLines)[pltorder], function(x) c(x,x))) - linetype = 0 - for (idrow in seq(1,nrow(guidedf)-1,2)) - { - linetype = linetype+1 - p = p + annotate(geom="text",hjust="left", - label=paste0(guidedf$SDI[idrow]),size=2,y=guidedf$ys[idrow],x=guidedf$xs[idrow+1]) + - annotate("segment",y=guidedf$ys[idrow],yend=guidedf$ys[idrow+1],linetype=linetype, - x=guidedf$xs[idrow],xend=guidedf$xs[idrow+1],alpha=.4) - } - } - if (!is.null(StkChtguideLines)) - { - linetype = 1 - for (PCT in rev(names(StkChtguideLines))) - { - linetype = linetype+1 - p = p + geom_line(aes(x=xseq,y=yseq),show.legend=FALSE,alpha=.4, - linetype=if (PCT == "100%") 1 else linetype,data=StkChtguideLines[[PCT]]) - } - sq = seq(.95,0,-.05) - sq = if (input$YTrans=="log10") 10^(log10(rngy[2])*sq) else rngy[2]*sq - sq = sq[1:min(length(sq),length(names(StkChtguideLines)))] - xs = if (input$XTrans=="log10") 10^(log10(rngx[2])*c(.75,.9)) else rngx[2]*c(.75,.9) - guidedf = do.call(rbind,lapply(sq,function(y) data.frame(ys=y,xs=xs))) - guidedf$PCT=unlist(lapply(rev(names(StkChtguideLines)), function (x) c(x,x))) - linetype = 1 - for (idrow in seq(1,nrow(guidedf)-1,2)) - { - linetype = linetype+1 - p = p + annotate(geom="text",hjust="left", - label=paste0(guidedf$PCT[idrow]),size=2,y=guidedf$ys[idrow],x=guidedf$xs[idrow+1]) + - annotate("segment",y=guidedf$ys[idrow],yend=guidedf$ys[idrow+1],alpha=.4, - x=guidedf$xs[idrow],xend=guidedf$xs[idrow+1], - linetype=if (guidedf$PCT[idrow] == "100%") 1 else linetype) - } - p = p + geom_polygon(aes(x=X,y=Y), data = StkChtrng, color="Gray", alpha=.3, - show.legend = FALSE) - } - size = approxfun(c(50,100,1000),c(1,.7,.5),rule=2)(nrow(nd)) - - if (is.factor(nd$X)) nd$X = as.ordered(nd$X) - if (is.factor(nd$Y)) nd$Y = as.ordered(nd$Y) - pltp = input$plotType - if (pltp %in% c("DMD","StkCht")) pltp = "path" -cat ("pltp=",pltp," input$colBW=",input$colBW," hrvFlag is null=",is.null(hrvFlag),"\n") - p = p + switch(pltp, - line = if (input$colBW == "B&W") - geom_line (aes(x=X,y=Y,linetype=Legend),alpha=alpha) else - geom_line (aes(x=X,y=Y,color=Legend),alpha=alpha), - path = if (input$colBW == "B&W") - geom_path (aes(x=X,y=Y,linetype=Legend),alpha=alpha, - arrow=grid::arrow(angle=20,length=unit(6,"pt"), - ends="last",type="closed")) else - geom_path (aes(x=X,y=Y,color=Legend),alpha=alpha, - arrow=grid::arrow(angle=20,length=unit(6,"pt"), - ends="last",type="closed")), - scat = - geom_point (aes(x=X,y=Y,color=Legend,shape=Legend),size=size,alpha=alpha), - bar = if (input$colBW == "B&W") - geom_col (aes(x=X,y=Y,fill=Legend),color="black",size=.2,alpha=alpha, - position=input$barPlace) else - geom_col (aes(x=X,y=Y,fill=Legend),color="transparent",size=.1,alpha=alpha, - position=input$barPlace), - box = if (input$colBW == "B&W") - geom_boxplot (aes(x=X,y=Y,linetype=Legend),color="black",size=.6,alpha=alpha) else - geom_boxplot (aes(x=X,y=Y,color=Legend),linetype=1,size=.6,alpha=alpha) - ) - if (!is.null(hrvFlag) && any(hrvFlag)) p = p + - if (input$colBW == "B&W") - geom_point(aes(x=X,y=Y), shape=82, #the letter R is code 82 - data = nd[hrvFlag,], alpha=alpha, show.legend = FALSE) else - geom_point(aes(x=X,y=Y,color=Legend), shape=82, #the letter R is code 82 - data = nd[hrvFlag,], alpha=alpha, show.legend = FALSE) - if (input$colBW == "B&W" && pltp == "bar") - p = p + scale_fill_grey(start=.15, end=.85) - p = p + theme(text=element_text(size=9),plot.title = element_text(hjust = 0.5)) - p = p + switch(pltp, - line = if (input$colBW == "B&W") - guides(linetype=guide_legend(override.aes = list(alpha=1,size=.8), - title=legendTitle)) else - guides(colour=guide_legend(override.aes = list(alpha=1,size=.8), - title = legendTitle)), - path = if (input$colBW == "B&W") - guides(linetype=guide_legend(override.aes=list(alpha=1,size=.8), - arrow=grid::arrow(angle=20,length=unit(5,"pt"),ends="last",type="closed"), - title=legendTitle)) else - guides(colour=guide_legend(override.aes=list(alpha=1,size=.8), - arrow=grid::arrow(angle=20,length=unit(5,"pt"),ends="last",type="closed"), - title=legendTitle)), - scat = - guides(shape=guide_legend(override.aes = list(color=colors,alpha=1,size=1), - title = legendTitle),color="none"), - bar = - guides(fill=guide_legend(override.aes = list(alpha=.9,size=.6), - title = legendTitle, keywidth = .8, keyheight = .8)), - box = if (input$colBW == "B&W") - guides(linetype=guide_legend(override.aes = list(alpha=.8,size=.5), - title = legendTitle, keywidth = .8, keyheight = .8)) else - guides(color=guide_legend(override.aes = list(alpha=.8,size=.5), - title = legendTitle, keywidth = .8, keyheight = .8))) - if (nlevels(nd$Legend)==1 || nlevels(nd$Legend)>30) - { - p = p + theme(legend.position="none") - if (nlevels(nd$Legend)>30) output$plotMessage=renderText("Over 30 legend items, legend not drawn.") - } else p = p + theme(legend.position=input$legendPlace) - outfile = "www/plot.png" - fvsOutData$plotSpecs$res = as.numeric(if (is.null(input$res)) 150 else input$res) - fvsOutData$plotSpecs$width = as.numeric(input$width) - fvsOutData$plotSpecs$height = as.numeric(input$height) - CairoPNG(outfile, width=fvsOutData$plotSpecs$width, - height=fvsOutData$plotSpecs$height, units="in", - res=fvsOutData$plotSpecs$res) - print(p) - dev.off() - globals$gFreeze = FALSE - list(src = outfile) - }, deleteFile = FALSE) - - ## copyplot - observe( - if (input$copyplot > 0) - { -cat ("copyToClipboard copyplot\n") - session$sendCustomMessage(type="copyEltToClipboard", "outplot") - } - ) - - ## Stands tab - observe({ - if (input$topPan == "Simulate" || input$rightPan == "Stands") - { -cat ("Stands\n") - f1=system.file("extdata", "FVS_Data.db.default",package="fvsOL") - output$sayDataSource <-renderUI((h4(paste0( - if (areFilesIdentical(f1=f1,f2="FVS_Data.db")) "Training" else "User", - " data installed")))) - initNewInputDB(session,output,dbGlb) - loadStandTableData(globals, dbGlb$dbIcon) - updateStandTableSelection(session,input,globals) - loadVarData(globals,input,dbGlb$dbIcon) - updateVarSelection(globals,session,input) - } - }) - - ## inTabs has changed - observe({ - if (is.null(input$inTabs)) return() - reloadStandSelection(session,input) -cat ("inTabs\n") - }) - - ## inVars has changed - observe({ - if (is.null(input$inVars)) return() - globals$activeVariants = input$inVars - globals$activeExtens = c("base",globals$activeFVS[[paste0("FVS",globals$activeVariants)]][-1]) - reloadStandSelection(session,input) -cat ("inVars globals$activeVariants=",globals$activeVariants, - " globals$activeExtens=",globals$activeExtens," \n") - }) - - ## reloadStandSelection - reloadStandSelection <- function (session,input) - isolate({ -cat ("in reloadStandSelection\n") - if (is.null(input$inTabs) || is.null(input$inVars)) return() - sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) "StandPlot_ID" else "Stand_ID" - grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups, INV_YEAR from ",input$inTabs, - ' where lower(variant) like "%',tolower(input$inVars),'%"'))) - grps <- subset(grps, !is.na(grps[grep("inv_year",tolower(names(grps)))])) - grps <- subset(grps, grps[grep("inv_year",tolower(names(grps)))] !="") - if (class(grps) == "try-error" || is.null(grps) || nrow(grps) == 0) - { - dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") - dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.Grps"),data.frame(Stand_ID="",Grp="")) - updateSelectInput(session=session, inputId="inGrps",choices=list()) - updateSelectInput(session=session, inputId="inStds",list()) - } else { - if(tolower(input$inVars)=="cr"){# check for 5 GENGYM submodel variant codes in the input data - test <- try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct variant from ',input$inTabs))) - test=sort(unique(tolower(scan(text=gsub(","," ",test[,1]),what="character", - strip.white=TRUE,sep=" ",quiet=TRUE)))) - CRsubModels <- c("sm","sp","bp","sf","lp") - if(any(!is.na(match(test,CRsubModels)))){ - CRsubModels <- CRsubModels[na.omit(match(test,CRsubModels))] - for(i in 1:length(CRsubModels)){ - subgrps <- try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups from ",input$inTabs, - ' where lower(variant) like "%',tolower(CRsubModels[i]),'%"'))) - if(length(subgrps))grps <- rbind(grps,subgrps) - } - } - } - dd = apply(grps,1,function (x) - { - gr=unlist(strsplit(x[2]," ")) - st=rep(x[1],length(gr)) - attributes(st) = NULL - attributes(gr) = NULL - list(st,gr) - }) - dd = lapply(dd,function(x) matrix(unlist(x),ncol=2)) - dd = do.call(rbind,dd) - colnames(dd) = c(if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) - "StandPlot_ID" else "Stand_ID","Grp") - dd = as.data.frame(dd) - dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") - dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.Grps"),dd) - selGrp = dbGetQuery(dbGlb$dbIcon, - 'select distinct Grp from temp.Grps order by Grp')[,1] - updateSelectInput(session=session, inputId="inGrps", - choices=as.list(selGrp)) - updateSelectInput(session=session, inputId="inStds", - choices=list()) - output$stdSelMsg <- renderUI(NULL) - } - }) - - ## inGrps, inAnyAll, or inStdFindBut has changed - observe({ - if (input$topPan == "Simulate" || input$rightPan == "Stands") - { -cat ("inGrps inAnyAll inStdFindBut\n") - # insure reactivity to inStdFindBut - input$inStdFindBut - if (is.null(input$inGrps)) - { - output$stdSelMsg <- renderUI(NULL) - updateSelectInput(session=session, inputId="inStds", - choices=list()) - } else { - dbExecute(dbGlb$dbIcon,"drop table if exists temp.SGrps") - dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.SGrps"),data.frame(SelGrps = input$inGrps)) - sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) - "StandPlot_ID" else "Stand_ID" - stds = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,' from temp.Grps ', - 'where Grp in (select SelGrps from temp.SGrps)'))) - if (class(stds) == "try-error") return() -cat ("inGrps, nrow(stds)=",nrow(stds),"\n") - globals$selStds = stds[,1] - globals$selStds = if (input$inAnyAll == "Any") unique(globals$selStds) else - { - stdCnts = table(globals$selStds) - names(stdCnts[stdCnts == length(input$inGrps)]) - } - isolate({ -cat ("input$inStdFind=",input$inStdFind,"\n") - srchStr = input$inStdFind - if (length(globals$selStds) && nchar(srchStr)) globals$selStds = - globals$selStds[grep(srchStr,globals$selStds)] - }) - nstds = length(globals$selStds) - msg = paste0(length(globals$selStds)," Stand(s) in ",length(input$inGrps)," Group(s)") - if (nchar(srchStr)) msg = paste0(msg," and matching search string ",srchStr) - msg = paste0(msg,"
") - output$stdSelMsg <- renderUI(HTML(msg)) - stds = if (length(globals$selStds) <= 220) globals$selStds else - c(globals$selStds[1:200],paste0("<< Display 201 to ", - min(400,length(globals$selStds ))," of ",length(globals$selStds )," >>")) - updateSelectInput(session=session, inputId="inStds", - choices=as.list(stds)) - } - } - }) - ## inStds has changed - observe({ -cat ("inStds, length(input$inStds)=",length(input$inStds),"\n") - if (length(input$inStds) != 1) return() - prts = unlist(strsplit(input$inStds[1]," ")) - if (prts[1] != "<<") return() - nprts = as.numeric(prts[c(3,5,7)]) -cat ("inStds, nprts=",nprts,"\n") - up = nprts[c(1,2)] - 200 - if (up[2]-up[1] < 200) up[2] = min(up[1]+200,length(globals$selStds)) - upM = if (up[1] > 0) paste0("<< Display ",up[1]," to ", - min(up[2],length(globals$selStds))," of ", - length(globals$selStds)," >>") else NULL - dn = nprts[c(1,2)] + 200 - if (dn[2]-dn[1] < 200) dn[2] = min(dn[1]+200,length(globals$selStds)) - dn[2] = min(dn[2],length(globals$selStds)) - dnM = if (dn[1] <= length(globals$selStds)) paste0("<< Display ",dn[1]," to ", - dn[2]," of ",length(globals$selStds)," >>") else NULL - stds = c(upM,globals$selStds[nprts[1]:nprts[2]],dnM) -cat ("inStds upM=",upM," dnM=",dnM,"\n") - updateSelectInput(session=session, inputId="inStds", - choices=as.list(stds)) - }) - - ## Save saveRun - observe({ - if (input$saveRun > 0) - { -cat ("saveRun\n") - saveRun(input,session) - updateSelectInput(session=session, inputId="runSel", - choices=globals$FVS_Runs,selected=globals$FVS_Runs[[1]]) - } - }) - - ## New run - observe({ - if (input$newRun > 0) - { - saveRun(input,session) - resetfvsRun(globals$fvsRun,globals$FVS_Runs) - globals$fvsRun$title <- nextRunName(names(globals$FVS_Runs)) - storeFVSRun(dbGlb$prjDB,globals$fvsRun) - globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) -cat("New run, calling resetGlobals\n") - resetGlobals(globals,TRUE) - if (length(globals$GenGrp)) globals$GenGrp <- list() - if (length(globals$GrpNum)) globals$GrpNum <- numeric(0) - updateTextInput(session=session, inputId="title", value=globals$fvsRun$title) -cat ("in new run, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID,"\n") - updateTextInput(session=session, inputId="defMgmtID", - value=globals$fvsRun$defMgmtID) - updateSelectInput(session=session, inputId="simCont",choices=list()) - output$contCnts <- renderUI(HTML(paste0("Run contents: ", - length(globals$fvsRun$stands)," stand(s), ", - length(globals$fvsRun$grps)," group(s)"))) - updateSelectInput(session=session, inputId="addMgmtCats",choices=list()) - updateSelectInput(session=session, inputId="addMgmtCmps",choices=list()) - updateTextInput(session=session, inputId="startyr", - value=globals$fvsRun$startyr) - updateTextInput(session=session, inputId="endyr", - value=globals$fvsRun$endyr) - updateTextInput(session=session, inputId="cyclelen", - value=globals$fvsRun$cyclelen) - updateTextInput(session=session, inputId="cycleat", - value=globals$fvsRun$cycleat) - updateTextInput(session=session, inputId="inReps",value="1") - updateTextInput(session=session, inputId="inRwts",value="1") - output$runProgress <- renderUI(NULL) - updateSelectInput(session=session, inputId="rightPan", - selected="Stands") - updateSelectInput(session=session, inputId="compTabSet", - selected="Management") - updateSelectInput(session=session, inputId="runScript", - selected="fvsRun") - updateCheckboxGroupInput(session=session, "autoSVS", choices=list("Stand visualization:"="autoSVS")) - updateRadioButtons(session=session,inputId="svsPlotShape",selected="Round") - updateNumericInput(session=session,inputId="svsNFire",value=4) - updateCheckboxGroupInput(session=session, "autoOut", choices=list( - "Tree lists (FVS_Treelist, FVS_CutList (StdStk-stand and stock))"="autoTreelists", - "Carbon and fuels (FVS_Carbon, FVS_Consumption, FVS_Hrv_Carbon, FVS_Fuels)"="autoCarbon", - "Fire and mortality (FVS_Potfire, FVS_BurnReport, FVS_Mortality)"="autoFire", - "Snags and down wood (FVS_SnagSum, FVS_Down_Wood_Cov, FVS_Down_Wood_Vol)"="autoDead", - "FFE canopy profile (FVS_CanProfile)"="autoCanProfile", - "FFE detailed snag (FVS_SnagDet)"="autoSnagDet", - "Stand structure (FVS_StrClass)"="autoStrClass", - "Calibration statistics (FVS_CalibStats)"="autoCalibStats", - "Climate-FVS (FVS_Climate)"="autoClimate", - "Economics (FVS_EconSummary, FVS_EconHarvestValue)"="autoEcon", - "Mistletoe detail by tree size (FVS_DM_Sz_Sum)"="autoDM_Sz_Sum", - "Western Root Disease summary (FVS_RD_Sum)"="autoRD_Sum", - "Western Root Disease details (FVS_RD_Det)"="autoRD_Det", - "Western Root Disease bark beetles (FVS_RD_Beetle)"="autoRD_Beetle", - "Inventory statistics (FVS_Stats_Species, FVS_Stats_Stand)"="autoInvStats", - "Regeneration (All Variants: FVS_Regen_Sprouts, FVS_Regen_SitePrep, FVS_Regen_Tally. - AK, EM, KT, IE, and CI variants also get: FVS_Regen_HabType, FVS_Regen_Ingrowth)"="autoRegen", - "Produce all standard FVS text outputs (otherwise some are suppressed)"="autoDelOTab" - ), selected=list()) - isolate ({ - loadStandTableData(globals, dbGlb$dbIcon) - updateSelectInput(session=session, inputId="inTabs", choices=globals$selStandTableList, - selected=if (length(globals$selStandTableList)) globals$selStandTableList[[1]] else NULL) - updateSelectInput(session=session, inputId="inGrps", NULL, NULL) - updateSelectInput(session=session, inputId="inStds", NULL, NULL) - updateTabsetPanel(session=session, inputId="rightPan",selected="Stands") - loadVarData(globals,input,dbGlb$dbIcon) - updateVarSelection(globals,session,input) - }) - updateSelectInput(session=session, inputId="runSel", - choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) - globals$changeind <- 0 - output$contChange <- renderUI("Run") - } - }) - - - ## Duplicate run - observe({ - if (input$dupRun > 0) - { - if (length(globals$FVS_Runs) == 0) return() - isolate(if (is.null(input$runSel)) return()) - saveRun(input,session) - globals$fvsRun$title <- mkNameUnique(globals$fvsRun$title,names(globals$FVS_Runs)) - globals$fvsRun$uuid <- uuidgen() - globals$fvsRun$defMgmtID <- nextMgmtID(length(globals$FVS_Runs)) - storeFVSRun(dbGlb$prjDB,globals$fvsRun) - globals$FVS_Runs=getFVSRuns(dbGlb$prjDB) - updateTextInput(session=session, inputId="title", label="Run title", - value=globals$fvsRun$title) - updateTextInput(session=session, inputId="defMgmtID", - value=globals$fvsRun$defMgmtID) - updateSelectInput(session=session, inputId="compTabSet", - selected="Management") - updateSelectInput(session=session, inputId="runSel", - choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) - globals$changeind <- 0 - output$contChange <- renderUI("Run") - } - }) - - ## updateAutoOut - updateAutoOut <- function(session,autoOut) - { -cat ("updateAutoOut called\n") - if (!is.null(autoOut) && is.null(names(autoOut))) # block is for backward compatibility, after 2021 it can be deleted. - { - updateCheckboxGroupInput(session=session, inputId="autoOut", - selected=autoOut) - if ("autoSVS" %in% unlist(autoOut)) updateCheckboxGroupInput(session=session, - inputId="autoSVS",selected="autoSVS") - } else { - if (is.null(autoOut)) return() - updateCheckboxGroupInput(session=session, inputId="autoOut", - selected=autoOut[["autoOut"]]) - updateCheckboxGroupInput(session=session,inputId="autoSVS",selected=autoOut[["svsOut"]][["svs"]]) - updateRadioButtons(session=session,inputId="svsPlotShape",selected=autoOut[["svsOut"]][["shape"]]) - updateNumericInput(session=session,inputId="svsNFire",value=as.numeric(autoOut[["svsOut"]][["nfire"]])) - } - } - - ## Reload or Run Selection - observe({ - if (input$reload > 0 || !is.null(input$runSel)) - isolate({ - if (length(globals$fvsRun$uuid) && input$runSel != globals$fvsRun$uuid) saveRun(input,session) -cat ("reload or run selection, runSel=",input$runSel," lensim=", -length(globals$fvsRun$simcnts)," globals$currentQuickPlot=",globals$currentQuickPlot,"\n") - if (length(globals$currentQuickPlot) && - globals$currentQuickPlot != input$runSel) - { -cat("setting uiRunPlot to NULL\n") - output$uiRunPlot <- output$uiErrorScan <- renderUI(NULL) - globals$currentQuickPlot = character(0) - } - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - progress <- shiny::Progress$new(session,min=1,max=5) - progress$set(message = "Loading selected run",value = 1) - resetGlobals(globals,FALSE) - sel = match (input$runSel,globals$FVS_Runs) - if (is.na(sel)) sel = 1 - saveFvsRun = loadFVSRun(dbGlb$prjDB,globals$FVS_Runs[sel]) - # make sure the saved object has the correct class. This will fix load errors from old projects - if (! identical(attributes(class(saveFvsRun)),attributes(class(globals$fvsRun)))) - attributes(class(saveFvsRun)) = attributes(class(globals$fvsRun)) - globals$fvsRun = saveFvsRun - - if (length(globals$fvsRun$stands)) for (i in 1:length(globals$fvsRun$stands)) - { - if (length(globals$fvsRun$stands[[i]]$grps) > 0) - for (j in 1:length(globals$fvsRun$stands[[i]]$grps)) - { - if (length(globals$fvsRun$stands[[i]]$grps[[j]]$cmps) > 0) - for (k in 1:length(globals$fvsRun$stands[[i]]$grps[[j]]$cmps)) - { - test <- globals$fvsRun$stands[[i]]$grps[[j]]$cmps[[k]]$kwds - spgtest <- grep("^SpGroup",test) - cntr <- 0 - spgname <- list() - if (length(spgtest)) - { - cntr<-cntr+1 - spgname[cntr] <- trim(unlist(strsplit(strsplit(test, split = "\n")[[1]][1], - split=" "))[length(unlist(strsplit(strsplit(test, split = "\n")[[1]][1],split=" ")))]) - if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else - globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 - - spgname[1] <- gsub(" ","", spgname[1]) - tmpk <- match(spgname[1], globals$GenGrp) - if (!is.na(tmpk)) - { - globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] - } else globals$GenGrp[length(globals$GrpNum)]<-spgname - } - } - } - } - resetGlobals(globals,TRUE) - tmp = unlist(globals$activeFVS[globals$fvsRun$FVSpgm]) - globals$lastRunVar = if (length(tmp) && !is.null(tmp)) tmp[1] else - if (length(globals$fvsRun$FVSpgm) && nchar(globals$fvsRun$FVSpgm)>4) - substring(globals$fvsRun$FVSpgm,4) else character(0) - mkSimCnts(globals$fvsRun,sels=globals$fvsRun$selsim, - justGrps=isolate(input$simContType)=="Just groups") - output$uiCustomRunOps = renderUI(NULL) -cat ("reloaded globals$fvsRun$title=",globals$fvsRun$title," uuid=",globals$fvsRun$uuid,"\n") -cat ("reloaded globals$fvsRun$runScript=",globals$fvsRun$runScript,"\n") - if (length(globals$fvsRun$uiCustomRunOps)) lapply(names(globals$fvsRun$uiCustomRunOps), function (x,y) -cat ("globals$fvsRun$uiCustomRunOps$",x,"=",y[[x]],"\n",sep=""),globals$fvsRun$uiCustomRunOps) else -cat ("globals$fvsRun$uiCustomRunOps is empty\n") - if ((globals$changeind==0 && !length(globals$currentQuickPlot)) && length(globals$fvsRun$simcnts)>0) - { - if (input$rightPan != "Components" && length(globals$fvsRun$simcnts)>0) - { - updateTabsetPanel(session=session, inputId="rightPan", - selected="Components") - } - if (input$rightPan != "Stands" && length(globals$fvsRun$simcnts)==0) - { - updateTabsetPanel(session=session, inputId="rightPan", - selected="Stands") - } - } - progress$set(message = paste0("Setting values for run ", globals$fvsRun$title), - value = 2) - updateAutoOut(session, globals$fvsRun$autoOut) - updateTextInput(session=session, inputId="title", value=globals$fvsRun$title) -cat ("in Reload, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID,"\n") - updateTextInput(session=session, inputId="defMgmtID", - value=globals$fvsRun$defMgmtID) - for (id in c("addMgmtCats","addMgmtCmps","addModCats","addModCmps", - "addEvCmps","addKeyExt","addKeyWds")) - updateSelectInput(session=session, inputId=id,selected=0) - updateTextInput(session=session, inputId="startyr", - value=globals$fvsRun$startyr) - updateTextInput(session=session, inputId="endyr", - value=globals$fvsRun$endyr) - updateTextInput(session=session, inputId="cyclelen", - value=globals$fvsRun$cyclelen) - updateTextInput(session=session, inputId="cycleat", - value=globals$fvsRun$cycleat) - updateVarSelection(globals,session,input) - progress$set(message = paste0("Setting simulation contents for run ", - globals$fvsRun$title),value = 3) - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - loadVarData(globals,input,dbGlb$dbIcon) - updateVarSelection(globals,session,input) - output$contCnts <- renderUI(HTML(paste0("Run contents: ", - length(globals$fvsRun$stands)," stand(s), ", - length(globals$fvsRun$grps)," group(s)"))) - updateStandTableSelection(session,input,globals) - loadVarData(globals,input,dbGlb$dbIcon) - updateVarSelection(globals,session,input) - # if the update causes a change in the runscript selection, then - # customRunOps will get called automatically. If it is the same - # script then it needs to be called here to update/set the settings. - progress$set(message = "Setting custom run options ",value = 4) - callCustom = length(globals$fvsRun$runScript) && - globals$fvsRun$runScript == input$runScript - updateSelectInput(session=session, inputId="runScript", - selected=globals$fvsRun$runScript) - if (!is.na(callCustom) && callCustom) customRunOps() - progress$close() - }) - }) - - ## autoOut - observe({ - input$autoOut - input$autoSVS - { -cat ("autoOut changed, input$autoSVS=",input$autoSVS,"\n") - out<-list(svsOut=list(svs=input$autoSVS,shape=input$svsPlotShape,nfire=input$svsNFire), - autoOut=as.list(input$autoOut)) - if (identical(out,globals$fvsRun$autoOut)) return() - globals$fvsRun$autoOut <- out - updateAutoOut(session, globals$fvsRun$autoOut) - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - } - }) - - ## inAdd: Add Selected Stands - observe({ - if (input$inAdd > 0) - { -cat ("input$inAdd=",input$inAdd,"\n") - addStandsToRun(session,input,output,selType="inAdd",globals,dbGlb) - updateVarSelection(globals,session,input) - } - }) - ## inAddGrp: Add all stands in selected groups - observe({ - if (input$inAddGrp > 0) - { -cat (" input$inAddGrp=",input$inAddGrp,"\n") - addStandsToRun(session,input,output,selType="inAddGrp",globals,dbGlb) - updateVarSelection(globals,session,input) - } - }) - ## inStdFindBut: Find and select stands in the stand list that match the search string - observe({ - if (input$inStdFindBut > 0) - { -cat ("input$inStdFindBut=",input$inStdFindBut,"\n") - } - }) - - ## run element selection - observe({ - if (length(input$simCont) == 0) return() -cat ("run element selection\n") - if (all(input$simCont == globals$fvsRun$selsim)) return() - mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=isolate(input$simContType=="Just groups")) - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - }) - - ## findStand (set run element to item if found) - observe({ - if (input$searchNext== 0) return() - isolate ({ -cat ("searchNext: string=",input$searchString,"\n") - if (nchar(input$searchString) == 0) return() - elt = findStand(globals,search=input$searchString) -cat ("elt=",elt,"\n") - if (is.null(elt)) return() - if (input$simContType=="Just groups") updateRadioButtons(session=session, - inputId="simContType", selected="Full run") - mkSimCnts(globals$fvsRun,sels=elt,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=elt) - })}) - - ## Edit - observe({ - if (input$editSel == 0) return() - isolate ({ - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - globals$currentEditCmp <- globals$NULLfvsCmp - if (length(input$simCont) == 0) return() - toed = input$simCont[1] - # find component - cmp = findCmp(globals$fvsRun,toed) - if (is.null(cmp)) return() - globals$currentEditCmp = cmp - if (length(cmp$kwdName) == 0) cmp$kwdName="freeEdit" -cat ("Edit, cmp$kwdName=",cmp$kwdName,"toed=",toed,"\n") - eltList = NULL - if (cmp$kwdName=="freeEdit") - { - eltList <- mkFreeformEltList(globals,input,prms,cmp$title,cmp$kwds) - rtn <- if (cmp$atag=="c") list(h5(), - div(myInlineTextInput("cmdTitle","Condition title ", - value=globals$currentEditCmp$title,size=40)),h5()) else - list(h5(),div(myInlineTextInput("cmdTitle","Component title ", - value=globals$currentEditCmp$title,size=40)),h5()) - if(length(globals$currentEditCmp$title)) rtn <- append(rtn,list( - h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) - output$titleBuild <- renderUI(rtn) - } else - { - if (length(cmp$kwdName) && nchar(cmp$kwdName)) - { - if (exists(cmp$kwdName)) #if a function exists, use it. - { - eltList <- eval(parse(text=paste0(cmp$kwdName, - "(globals$currentEditCmp$title,prms,globals,input,output)"))) - if (is.null(eltList)) return(NULL) - eltList <- eltList[[1]] - rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", - value=globals$currentEditCmp$title,size=40)),h5()) - if(length(globals$currentEditCmp$title)) rtn <- append(rtn,list( - h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) - output$titleBuild <- renderUI(rtn) - } else { - pk <- match (cmp$kwdName,names(prms)) - if (!is.na(pk)) # FreeForm Edit, used if pk does not match a parms. - { # Launch general purpose builder when pk matches a parms. - pkeys <- prms[[pk]] - eltList <- mkeltList(pkeys,prms,globals,input,output, - cmp$atag=="c",FALSE,globals$currentEditCmp$title) - } - } - } - } - if (is.null(eltList)) - { - rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", - value=globals$currentEditCmp$title,size=40)),h5()) - rtn <- append(rtn,list( - h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) - output$titleBuild <- renderUI(rtn) - eltList <- mkFreeformEltList(globals,input,prms,globals$currentEditCmp$title, - globals$currentEditCmp$kwds) - } - eltList <- append(eltList,list( - tags$style(type="text/css", "#cmdCancel {color:red;}"), - actionButton("cmdCancel","Cancel"), - tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), - actionButton("cmdSaveInRun","Save in run"))) - output$cmdBuild <- renderUI(eltList) - output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - if (input$rightPan != "Components") { - updateTabsetPanel(session=session, - inputId="rightPan",selected="Components") - updateSelectInput(session=session, - inputId="compTabSet", selected="Management") - } - if (input$rightPan == "Components" && input$compTabSet !="Management") { - updateSelectInput(session=session, - inputId="compTabSet", selected="Management") - output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - } - for (id in c("addMgmtCats","addMgmtCmps","addModCats","addModCmps", - "addEvCmps","addKeyExt","addKeyWds")) - updateSelectInput(session=session, inputId=id, selected=0) - }) - }) - # install callback functionality for the textarea that has the focus - # to get start and end selection poistions. - observe({ - if (length(input$freeEdit)) - { - session$sendCustomMessage(type="getStartEnd", "freeEdit") - } - }) - ## focusedElement - observe({ - if (length(input$focusedElement) && - input$focusedElement %in% c("freeEdit","condDisp")) - session$sendCustomMessage(type="getStartEnd", input$focusedElement) - }) - ## freeSpecies - observe({ - if (length(input$freeSpecies) && nchar(input$freeSpecies)) - insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeSpecies) - }) - ## freeVars - observe({ - if (length(input$freeVars) && nchar(input$freeVars)) - insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeVars) - }) - ## freeOps - observe({ - if (length(input$freeOps) && nchar(input$freeOps)) - insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeOps) - }) - ## freeFuncs - observe({ - if (length(input$freeFuncs) && nchar(input$freeFuncs) && input$freeFuncs != " ") - isolate({ - pkeys = prms[[paste0("evmon.function.",input$freeFuncs)]] - if (is.null(pkeys)) insertStringIntoFocusedTextarea(input, - input$focusedElement,paste0(input$freeFuncs,"()")) else - { - eltList <- mkeltList(pkeys,prms,globals,globals$fvsRun,funcflag=TRUE) - eltList <- append(eltList,list( - actionButton("fvsFuncInsert","Insert function"), - actionButton("fvsFuncCancel","Cancel function"),h6())) - output$fvsFuncRender <- renderUI(eltList) - } - }) - }) - ## fvsFuncCancel - observe({ - if (length(input$fvsFuncCancel) && input$fvsFuncCancel) - { - output$fvsFuncRender <- renderUI (NULL) - updateSelectInput(session=session, inputId="freeFuncs",selected=1) - } - }) - ## fvsFuncInsert - observe({ - if (length(input$fvsFuncInsert) && input$fvsFuncInsert) - isolate({ - pkeys = prms[[paste0("evmon.function.",input$freeFuncs)]] - ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) - reopn = NULL - fn = 0 - repeat - { - fn = fn+1 - pkey = paste0("f",fn) - fps = getPstring(pkeys,pkey,globals$activeVariants[1]) - if (is.null(fps)) break - pkey = paste0("func.f",fn) - instr = input[[pkey]] - reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) - names(reopn)[fn] = pkey - } - string = mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) - insertStringIntoFocusedTextarea(input,input$focusedElement,string) - }) - }) - - ## insertStringIntoFocusedTextarea - insertStringIntoFocusedTextarea <- function(input,textarea,string) - { - isolate({ - if (is.null(textarea)) textarea="freeEdit" - if (!is.null(string) && nchar(trim(string)) > 0) - { - if (length(input$selectionStart)) - { - start = input$selectionStart - end = input$selectionEnd - } else { start=0;end=0 } - len = nchar(input[[textarea]]) -cat ("insertStringIntoFocusedTextarea textarea=",textarea," string=",string," start=",start," end=",end," len=",len,"\n") - if (nchar(string) == 0) return() - if (start == end && end == len) { # prepend - updateTextInput(session, textarea, value = paste0(input[[textarea]],string)) - } else if (start == 0 && end == start) { # append - updateTextInput(session, textarea, value = paste0(string,input[[textarea]])) - } else if (end >= start) { # insert/replace - str = input[[textarea]] - updateTextInput(session, textarea, value = - paste0(substring(input[[textarea]],1,max(1,start)),string, - substring(input[[textarea]],min(end+1,len)))) - } - } - updateSelectInput(session=session, inputId="freeOps", selected=1) - updateSelectInput(session=session, inputId="freeVars",selected=1) - updateSelectInput(session=session, inputId="freeSpecies",selected=1) - updateSelectInput(session=session, inputId="freeFuncs",selected=1) - output$fvsFuncRender <- renderUI (NULL) - session$sendCustomMessage(type="refocus", textarea) - }) - } - - ## Cut - observe({ - if (input$cutCmp == 0) return() - isolate ({ -cat ("Cut length(input$simCont) = ",length(input$simCont),"\n") - if (length(input$simCont) == 0) return() - if (moveToPaste(input$simCont[1],globals,globals$fvsRun)) - { - globals$foundStand=0L - updateReps(globals$fvsRun) - mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - output$contCnts <- renderUI(HTML(paste0("Run contents: ", - length(globals$fvsRun$stands)," stand(s), ", - length(globals$fvsRun$grps)," group(s)"))) - updateSelectInput(session=session, inputId="selpaste", - choices=globals$pastelistShadow, - selected=if (length(globals$pastelistShadow)) - globals$pastelistShadow[[1]] else 0) - } - globals$changeind <- 1 - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - output$contChange <- renderText(HTML("*Run*")) - }) - }) - - - ## Copy - observe({ - if (input$copyCmp == 0) return() - isolate ({ - toCpy = findCmp(globals$fvsRun,input$simCont[1]) - if (is.null(toCpy)) return() - toCpy = mkfvsCmp(kwds=toCpy$kwds,kwdName=toCpy$kwdName, - exten=toCpy$exten,variant=toCpy$variant,uuid=uuidgen(), - atag=toCpy$atag,title=toCpy$title,reopn=toCpy$reopn) - globals$pastelist <- append(globals$pastelist,toCpy,after=0) - globals$pastelistShadow <- append(globals$pastelistShadow,toCpy$uuid,after=0) - names(globals$pastelistShadow)[1] = toCpy$title - updateSelectInput(session=session, inputId="selpaste", - choices=globals$pastelistShadow, - selected=if (length(globals$pastelistShadow)) - globals$pastelistShadow[[1]] else 0) - }) - }) - - - ## Paste - observe({ - if (input$paste == 0) return() - isolate ({ - if (length(input$simCont) == 0) return() - if (length(input$selpaste) == 0) return() - if (nchar(input$selpaste) == 0) return() - pidx = findIdx (globals$pastelist, input$selpaste) -cat("paste, pidx=",pidx,"\n") - if (is.null(pidx)) return() - topaste = globals$pastelist[[pidx]] - if (length(grep("^SpGroup",topaste$kwds))) - { -cat("paste, SpGroup hit\n") - cntr <- 0 - if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else - globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 - globals$GenGrp[length(globals$GrpNum)] <- topaste$reopn[[1]] - } -cat("paste, class(topaste)=",class(topaste),"\n") - if (class(topaste) != "fvsCmp") return() - topaste = mkfvsCmp(kwds=topaste$kwds,kwdName=topaste$kwdName, - exten=topaste$exten,variant=topaste$variant,uuid=uuidgen(), - atag=topaste$atag,title=topaste$title,reopn=topaste$reopn) - idx = pasteComponent(globals,input$simCont[1],topaste) - if (!is.null(idx)) - { - mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - output$contCnts <- renderUI(HTML(paste0("Run contents: ", - length(globals$fvsRun$stands)," stand(s), ", - length(globals$fvsRun$grps)," group(s)"))) - } - globals$foundStand=0L - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - }) - }) - - - ## Change to freeform - observe({ - if (input$mkfree == 0) return() - isolate ({ - globals$currentEditCmp <- globals$NULLfvsCmp - updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0) - if (length(input$simCont) == 0) return () - toed = input$simCont[1] - cmp = findCmp(globals$fvsRun,toed) - if (is.null(cmp)) return() - cmp$kwdName="freeEdit" - if (substring(cmp$title,1,10) != "Freeform: ") cmp$title=paste("Freeform: ",cmp$title) - cmp$reopn=character(0) - mkSimCnts(globals$fvsRun,sels=toed,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - output$titleBuild <-output$condBuild <- output$cmdBuild <- - output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - }) - }) - - ## Command Set - observe({ -cat ("compTabSet, input$compTabSet=",input$compTabSet, - " input$simCont=",length(input$simCont),"\n") - if(!length(globals$currentEditCmp$kwds) || input$compTabSet !="Management") - { - output$titleBuild <-output$condBuild <- output$cmdBuild <- - output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) - } - if (length(globals$fvsRun$FVSpgm) == 0) return(NULL) - if (! globals$fvsRun$FVSpgm %in% names(globals$activeFVS)) return(NULL) - switch (input$compTabSet, - "Management" = - { - if (length(globals$mgmtsel) == 0) globals$mgmtsel <- mkMgmtCats(globals) - updateSelectInput(session=session, inputId="addMgmtCats", - choices=mkpair(globals$mgmtsel), selected = 0) - updateSelectInput(session=session, inputId="addMgmtCmps", - choices=list()) - }, - "Modifiers" = - { - if (length(globals$mmodsel) == 0) globals$mmodsel <- mkModMCats(globals) - updateSelectInput(session=session, inputId="addModCats", - choices=mkpair(globals$mmodsel), selected = 0) - updateSelectInput(session=session, inputId="addModCmps", - choices=list()) - }, - "Event Monitor"= - { - if (length(globals$mevsel) == 0) globals$mevsel <- mkEvMonCats(globals) - updateSelectInput(session=session, inputId="addEvCmps", - selected = 0,choices=mkpair(globals$mevsel[[1]])) - }, - "Economic"= - { - renderComponent(input,output,"ecn") - }, - "Keywords" = - { - if (length(globals$extnsel) == 0) mkextkwd(prms,globals) - updateSelectInput(session=session, inputId="addKeyExt", - label="Extensions", choices=globals$extnsel, selected = 0) - updateSelectInput(session=session, inputId="addKeyWds", - label="Keywords", choices=list()) - }, - "Editor" = - { - customCmps = NULL - if(length(globals$currentEditCmp$kwds) > 0) closeCmp() - if (length(globals$customCmps) == 0)loadObject(dbGlb$prjDB,"customCmps") - if (!is.null(customCmps)){ - globals$customCmps = customCmps - updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(customCmps)), - selected=names(customCmps)[1]) - } - eltList <- mkFreeformEltList(globals,input,prms,globals$currentEditCmp$title, - globals$currentEditCmp$kwds) - output$condBuild <- renderUI(NULL) - output$cmdBuild <-renderUI(eltList) - output$fvsFuncRender <- renderUI (NULL) - output$cmdBuildDesc <- renderUI(paste0("Description: This Editor menu allows you to", - " utilize the advanced features of the freeform text format for creating custom", - " component sets by directly adding & editing keyword records and Event Monitor", - " functions. You can upload an existing keyword component file (.kcp), or keyword", - " component archive (FVS_kcps.Rdata) and then save it into the Run Contents window", - " on the left (Save in run), and also save it in the component collection (Save in", - " component collection). You can also create your own component sets by appending", - " items from the Run Contents on the left (Append selected component from run)", - " and then saving them into your component collection (Save in component collection).", - " Finally, you can download a text file of your component set (Download(KCP)).")) - }, - NULL) - }) - ## kcpEdit - observe({ - if (length(input$kcpEdit)) - { - session$sendCustomMessage(type="getStartEnd", "kcpEdit") - } - }) - ## freeSpeciesKCP - observe({ - if (length(input$freeSpeciesKCP) && nchar(input$freeSpeciesKCP)) isolate({ - if (length(input$kcpEdit) == 0) return() - insertStrinIntokcpEdit(input,input$freeSpeciesKCP) - }) - }) - ## freeVarsKCP - observe({ - if (length(input$freeVarsKCP) && nchar(input$freeVarsKCP)) isolate({ - if (length(input$kcpEdit) == 0) return() - insertStrinIntokcpEdit(input,input$freeVarsKCP) - }) - }) - ## freeOpcKCP - observe({ - if (length(input$freeOpsKCP) && nchar(input$freeOpsKCP)) - isolate({ - if (length(input$kcpEdit) == 0) return() - insertStrinIntokcpEdit(input,input$freeOpsKCP) - }) - }) - ## freeFuncsKCP - observe({ - if (length(input$freeFuncsKCP) && nchar(input$freeFuncsKCP) && input$freeFuncsKCP != " ") - isolate({ - if (length(input$kcpEdit) == 0) return() - pkeys = prms[[paste0("evmon.function.",input$freeFuncsKCP)]] - if (is.null(pkeys)) insertStrinIntokcpEdit(input, - paste0(input$freeFuncsKCP,"()")) else - { - eltList <- mkeltList(pkeys,prms,globals,input,output,funcflag=TRUE) - eltList <- append(eltList,list( - actionButton("fvsFuncInsertKCP","Insert function"), - actionButton("fvsFuncCancelKCP","Cancel function"),h6())) - output$fvsFuncRender <- renderUI(eltList) - } - }) - }) - ## fvsFuncCancelKCP - observe({ - if (length(input$fvsFuncCancelKCP) && input$fvsFuncCancelKCP) - { - output$fvsFuncRender <- renderUI (NULL) - updateSelectInput(session=session, inputId="freeFuncsKCP",selected=1) - } - }) - ## fvsFuncInsertKCP - observe({ - if (length(input$fvsFuncInsertKCP) && input$fvsFuncInsertKCP) - isolate({ - pkeys = prms[[paste0("evmon.function.",input$freeFuncsKCP)]] - ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) - reopn = NULL - fn = 0 - repeat - { - fn = fn+1 - pkey = paste0("f",fn) - fps = getPstring(pkeys,pkey,globals$activeVariants[1]) - if (is.null(fps)) break - pkey = paste0("func.f",fn) - instr = input[[pkey]] - reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) - names(reopn)[fn] = pkey - } - string = mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) - insertStrinIntokcpEdit(input,string) - }) - }) - ## insertStrinIntokcpEdit - insertStrinIntokcpEdit <- function(input,string) - { - if (is.null(string) || nchar(string) == 0 || string == " ") return() - isolate({ - if (length(input$selectionStart)) - { - start = input$selectionStart - end = input$selectionEnd - } else { start=0;end=0 } - len = nchar(input$kcpEdit) -cat ("insertStrinIntokcpEdit string=",string," start=",start," end=",end," len=",len,"\n") - if (nchar(string) == 0) return() - if (start == end && end == len) { # prepend - updateTextInput(session, "kcpEdit", value = paste0(input$kcpEdit,string)) - } else if (start == 0 && end == start) { # append - updateTextInput(session, "kcpEdit", value = paste0(string,input$kcpEdit)) - } else if (end >= start) { # insert/replace - str = input$kcpEdit - updateTextInput(session, "kcpEdit", value = - paste0(substring(input$kcpEdit,1,max(1,start)),string, - substring(input$kcpEdit,min(end+1,len)))) - } - updateSelectInput(session=session, inputId="freeOpsKCP", selected=1) - updateSelectInput(session=session, inputId="freeVarsKCP",selected=1) - updateSelectInput(session=session, inputId="freeSpeciesKCP",selected=1) - updateSelectInput(session=session, inputId="freeFuncsKCP",selected=1) - output$fvsFuncRender <- renderUI (NULL) - }) - } - - ## addMgmtCats - observe({ - if (is.null(input$addMgmtCats)) return() - if (length(globals$mgmtsel)==0) globals$mgmtsel<-mkMgmtCats(globals) - updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0, - choices=globals$mgmtsel[[as.numeric(input$addMgmtCats)]]) - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) - }) - ## addModCats - observe({ - if (is.null(input$addModCats)) return() - if (length(globals$mmodsel) == 0) globals$mmodsel <- mkModMCats(globals) - updateSelectInput(session=session, inputId="addModCmps", selected = 0, - choices=globals$mmodsel[[as.numeric(input$addModCats)]]) - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) - }) - ## addKeyExt - observe({ - if (is.null(input$addKeyExt)) - updateSelectInput(session=session, inputId="addKeyWds", selected = 0, - choices=NULL) else - { - if (length(globals$mevsel) == 0) globals$mevsel <- mkEvMonCats(globals) - updateSelectInput(session=session, inputId="addKeyWds", selected = 0, - choices=globals$kwdsel[[input$addKeyExt]]) - } - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) - }) - ## addMgmtCmps - observe({ - if (length(input$addMgmtCmps) && - nchar(input$addMgmtCmps)) renderComponent(input,output,"mgt") - }) - ## addModCmps - observe({ - if (length(input$addModCmps) && - nchar(input$addModCmps)) renderComponent(input,output,"mod") - }) - ## addKeyWds - observe({ - if (length(input$addKeyWds) && - nchar(input$addKeyWds)) renderComponent(input,output,"key") - }) - ## addEvent - observe({ - if (length(input$addEvCmps) && - nchar(input$addEvCmps)) renderComponent(input,output,"evn") - }) - - ## renderComponent - renderComponent <- function(input,output,inCode="default") - { -cat ("renderComponent, inCode=",inCode,"\n") - isolate ({ - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) - globals$currentEditCmp <- globals$NULLfvsCmp - globals$currentCndPkey <- character(0) - switch (as.character(inCode), - "mgt" = - { - if (is.null(input$addMgmtCats)) return(NULL) - titIndx = try(match(input$addMgmtCmps, - globals$mgmtsel[[as.numeric(input$addMgmtCats)]])) - if (class(titIndx)=="try-error") return(NULL) - title = names(globals$mgmtsel[[as.numeric(input$addMgmtCats)]])[titIndx] - globals$currentCmdPkey = globals$mgmtsel[[as.numeric(input$addMgmtCats)]][titIndx] - }, - "mod" = - { - titIndx = try(match(input$addModCmps, - globals$mmodsel[[as.numeric(input$addModCats)]])) - if (class(titIndx)=="try-error") return(NULL) - title = names(globals$mmodsel[[as.numeric(input$addModCats)]])[titIndx] - globals$currentCmdPkey = globals$mmodsel[[as.numeric(input$addModCats)]][titIndx] - }, - "key" = - { - titIndx = try(match(input$addKeyWds, - globals$kwdsel[[input$addKeyExt]])) - if (class(titIndx)=="try-error") return(NULL) - title = names(globals$kwdsel[[input$addKeyExt]])[titIndx] - globals$currentCmdPkey = globals$kwdsel[[input$addKeyExt]][titIndx] - }, - "evn" = - { - globals$currentCmdPkey=globals$mevsel[[1]][as.numeric(input$addEvCmps)] - title = names(globals$currentCmdPkey) - }, - "ecn" = - { - title = "Economic analysis" - globals$currentCmdPkey = "econ Econ_reports" - }, - return(NULL) - ) -cat ("globals$currentCmdPkey=",globals$currentCmdPkey," title=",title,"\n") - cmdp = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) - if(length(cmdp)>1)cmdp <- cmdp[2] else cmdp <- cmdp[1] - # the cmdp can be a function name, or a ".Win" can be appended to form a - # function name. If a function does not exist, then try finding a prms entry. - if (exists(cmdp)) funName = cmdp - funName = paste0(cmdp,".Win") - if (!exists(funName)) funName = cmdp - if (!exists(funName)) funName = NULL -cat ("funName=",funName,"\n") - if (!is.null(funName)) - { - globals$winBuildFunction <- funName - ans = eval(parse(text=paste0(globals$winBuildFunction, - "(title,prms,globals,input,output)"))) - if (is.null(ans)) return(NULL) - ans[[1]] <- append(ans[[1]],list( - tags$style(type="text/css", "#cmdCancel {color:red;}"), - actionButton("cmdCancel","Cancel"), - tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), - actionButton("cmdSaveInRun","Save in run"))) - if (length(grep("freeEdit",ans[[1]]))==0) ans[[1]] <- append(ans[[1]], - list(tags$style(type="text/css","#cmdChgToFree {color:black}"), - actionButton("cmdChgToFree","Change to freeform"))) - rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", value=title,size=40)),h5()) - output$titleBuild <- renderUI(rtn) - output$cmdBuild <- renderUI (if (length(ans[[1]])) ans[[1]] else NULL) - output$cmdBuildDesc <- renderUI (if (length(ans[[2]])) ans[[2]] else NULL) - } else { - globals$winBuildFunction <- character(0) - indx = match(cmdp,names(prms)) - if (is.na(indx)) return() - pkeys <- prms[[indx]] - eltList <- try(mkeltList(pkeys,prms,globals,input,output,FALSE,FALSE,title)) - if (class(eltList)=="try-error") - { - output$cmdBuildDesc = renderUI (HTML(paste0( - '
Error:
Programming for "',title,'" is incorrect.
'))) - return() - } - eltList <- append(eltList,list( - tags$style(type="text/css", "#cmdCancel {color:red;}"), - actionButton("cmdCancel","Cancel"), - tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), - actionButton("cmdSaveInRun","Save in run"), - actionButton("cmdChgToFree","Change to freeform"))) - output$cmdBuild <- renderUI (if (length(eltList)) eltList else NULL) - des <- getPstring(pkeys,"description",globals$activeVariants[1]) - output$cmdBuildDesc <- renderUI (if (!is.null(des) && nchar(des) > 0) - HTML(paste0("
Description:
",gsub("\n","
",des))) else NULL) - } - }) - } - - ## Thin from below window observer function - observe({ - if(is.null(input$tbf2)) return() - if(input$tbf2 == "1" || input$tbf2 == "2") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf3').prop('disabled',false)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf4').prop('disabled',false)")) - - if(input$tbf2 == "1" && input$tbf3 > 0 && input$tbf4 <= 0){ - updateTextInput(session=session,inputId ="tbf4", - value=round(sqrt(43560/as.numeric(input$tbf3)),digits=4)) - } - if(input$tbf2 == "2" && input$tbf3 <= 0 && input$tbf4 > 0){ - updateTextInput(session=session,inputId ="tbf3", - value=round(43560/(as.numeric(input$tbf4)^2),digits=2)) - } - if(input$tbf2 == "1" && input$tbf3 > 0 && input$tbf4 >0){ - updateTextInput(session=session,inputId ="tbf4", - value=round(sqrt(43560/as.numeric(input$tbf3)),digits=4)) - } - if(input$tbf2 == "2" && input$tbf3 > 0 && input$tbf4 >0){ - updateTextInput(session=session,inputId ="tbf3", - value=round(43560/(as.numeric(input$tbf4)^2),digits=2)) - } - - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf3').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf4').prop('disabled',true)")) - } - if(input$tbf2 == "3") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf5').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf5').prop('disabled',true)")) - } - if(input$tbf2 == "4") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf6').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf6').prop('disabled',true)")) - } - if(input$tbf2 == "5") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf7').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#tbf7').prop('disabled',true)")) - } - }) - - ## Thin from above window observer function - observe({ - if(length(input$taf2)==0) return() - if(input$taf2 == "1" || input$taf2 == "2") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf3').prop('disabled',false)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf4').prop('disabled',false)")) - - if(input$taf2 == "1" && input$taf3 > 0 && input$taf4 <= 0){ - updateTextInput(session=session,inputId ="taf4", - value=round(sqrt(43560/as.numeric(input$taf3)),digits=4)) - } - if(input$taf2 == "2" && input$taf3 <= 0 && input$taf4 > 0){ - updateTextInput(session=session,inputId ="taf3", - value=round(43560/(as.numeric(input$taf4)^2),digits=2)) - } - if(input$taf2 == "1" && input$taf3 > 0 && input$taf4 >0){ - updateTextInput(session=session,inputId ="taf4", - value=round(sqrt(43560/as.numeric(input$taf3)),digits=4)) - } - if(input$taf2 == "2" && input$taf3 > 0 && input$taf4 >0){ - updateTextInput(session=session,inputId ="taf3", - value=round(43560/(as.numeric(input$taf4)^2),digits=2)) - } - - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf3').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf4').prop('disabled',true)")) - } - if(input$taf2 == "3") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf5').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf5').prop('disabled',true)")) - } - if(input$taf2 == "4") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf6').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf6').prop('disabled',true)")) - } - if(input$taf2 == "5") { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf7').prop('disabled',false)")) - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#taf7').prop('disabled',true)")) - } -}) - - ## schedule box toggled. - observe({ - if (length(input$schedbox) == 0) return() -cat("input$schedbox=",input$schedbox,"\n") - if (input$schedbox == 1) - { - updateTextInput(session, globals$schedBoxPkey, - label = "Year or cycle number: ", - value = globals$schedBoxYrLastUsed) - output$conditions <- renderUI(NULL) - if (length(globals$toggleind)) globals$currentCndPkey <- character(0) - } else if (input$schedbox == 2) - { - updateTextInput(session, globals$schedBoxPkey, - label = "Number of years after condition is found true: ", value = "0") - cndlist = unlist(prms$conditions_list) - names(cndlist) = unlist(lapply(prms$conditions_list,attr,"pstring")) - cndlist = as.list(cndlist) - globals$toggleind <- "1" -cat("globals$currentCmdPkey=",globals$currentCmdPkey,"\n") - if (length(globals$currentCmdPkey)) - { - n = suppressWarnings(as.numeric(globals$currentCmdPkey)) - default = getPstring(prms[[if (is.na(n)) globals$currentCmdPkey else n]], - "defaultCondition",globals$activeVariants[1]) - if (is.null(default)) default="cycle1" - } else default = "cycle1" - output$conditions <- renderUI(list( - selectInput("condList", "Create a condition", cndlist, - selected = default, multiple = FALSE, selectize = FALSE), - uiOutput("condElts"))) - } else { - globals$currentCndPkey <- character(0) - updateTextInput(session, globals$schedBoxPkey, - label = "Number of years after condition is found true ", value = "0") - output$conditions <- renderUI( - selectInput("condList","Existing conditions", globals$existingCmps, - selected = NULL, multiple = FALSE, selectize = FALSE)) - } - }) - - ## schedule by condition selection - observe({ - if (length(input$schedbox) == 0) return() - if (length(input$condList) == 0) return() - if (length(globals$toggleind) && input$schedbox == 1) return() -cat("make condElts, input$condList=",input$condList,"\n") - if (input$condList == "none") output$condElts <- renderUI(NULL) else - { - cnpkey <- paste0("condition.",input$condList) - idx <- match(cnpkey,names(prms)) - globals$currentCndPkey <- if (is.na(idx)) character(0) else cnpkey - ui = if (identical(globals$currentCndPkey,character(0))) NULL else - { - eltList <- mkeltList(prms[[globals$currentCndPkey]],prms, - globals,input,output,cndflag=TRUE) - if (length(eltList) == 0) NULL else eltList - } - if (!is.null(ui)) - { - title = getPstring(prms$conditions_list,input$condList) - if (!is.null(title)) - { - ui <- append(ui,list(myInlineTextInput("condTitle","Condition title", - value=title, size=40)),after=1) - output$condElts <- renderUI(ui) - } - } - } - }) - - ## cmdChgToFree - observe({ - if (length(input$cmdChgToFree) == 0 || input$cmdChgToFree==0) return() - isolate({ -cat ("cmdChgToFree=",input$cmdChgToFree,"\n") - # process the condition first...if there is one. - if (length(globals$toggleind)>0 && length(globals$currentCndPkey) && - !is.null(input$schedbox) && input$schedbox == 2) - { -cat ("cmdChgToFree processing condition\n") - kwds = mkCondKeyWrd(globals,prms,input) - attr(kwds$kwds,"keywords") = "condDisp" - globals$currentCndPkey=kwds$kwds - updateTextInput(session, "condTitle",value=paste0("Freeform: ",input$condTitle)) - condUI <- list(myInlineTextInput("condTitle","Condition title", - value=paste0("Freeform: ",input$condTitle), size=40), - tags$style(type="text/css", - "#condDisp{font-family:monospace;font-size:90%;height:1in;width:100%;cursor:auto;}"), - tags$script('$(document).ready(function(){ $("textarea").on("focus", function(e){ Shiny.setInputValue("focusedElement", e.target.id);}); }); '), - tags$textarea(id="condDisp",kwds$kwds), - myInlineTextInput("cmdTitle","Component title", - value=paste0("Freeform: ",input$cmdTitle), size=40)) - output$titleBuild <- renderUI(NULL) - } else { - titleUI <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", paste0("Freeform: ",input$cmdTitle),size=40)),h5()) - output$titleBuild <- renderUI(titleUI) - condUI <- NULL - } -cat ("cmdChgToFree processing component\n") - if (length(globals$winBuildFunction)) - { - kwPname = globals$winBuildFunction - pkeys = character(0) - } else { - kwPname = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) - pkeys = if (length(kwPname)>1) prms[[kwPname[2]]] else prms[[kwPname[1]]] - } - kwds = buildKeywords(character(0),pkeys,kwPname,globals) - attr(kwds$kwds,"keywords") = "freeEdit" - attr(kwds$kwds,"extension") = kwds$ex - globals$currentCmdPkey = kwds$kwds - globals$winBuildFunction = character(0) - cmdUI <- mkFreeformEltList(globals,input,prms,paste0("Freeform: ",input$cmdTitle), - kwds$kwds) - cmdUI <- append(cmdUI,list( - tags$style(type="text/css", "#cmdCancel {color:red;}"), - actionButton("cmdCancel","Cancel"), - tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), - actionButton("cmdSaveInRun","Save in run"))) - output$condBuild <- renderUI(condUI) - output$cmdBuild <- renderUI(cmdUI) - output$cmdBuildDesc <- renderUI(NULL) - session$sendCustomMessage(type="refocus", "freeEdit") - }) - }) - ## command Cancel - observe({ - if (length(input$cmdCancel) && input$cmdCancel == 0) return() - closeCmp() - }) - ## closeCmp - closeCmp <- function () - { - globals$currentEditCmp <- globals$NULLfvsCmp - globals$schedBoxPkey <- character(0) - updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0) - updateSelectInput(session=session, inputId="addModCmps", selected = 0) - updateSelectInput(session=session, inputId="addKeyWds", selected = 0) - updateSelectInput(session=session, inputId="addEvCmps",selected = 0) - output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) - } - ## mkCondKeyWrd - mkCondKeyWrd <- function (globals,prms,input) - { - kwPname = globals$currentCndPkey -cat ("mkCondKeyWrd, kwPname=",kwPname,"\n") - pkeys = prms[[kwPname]] - ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) - if (is.null(ansFrm)) ansFrm = - getPstring(pkeys,"parmsForm",globals$activeVariants[1]) - reopn = NULL - fn = 0 - repeat - { - fn = fn+1 - pkey = paste0("f",fn) - fps = getPstring(pkeys,pkey,globals$activeVariants[1]) - if (is.null(fps)) break - instr = input[[paste0("cnd.",pkey)]] - reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) - names(reopn)[fn] = pkey - } - instr = input[["waitYears"]] - reopn = c(reopn,as.character(if (is.null(instr)) character(0) else instr)) - names(reopn)[length(names(reopn))] = "waitYears" - kwds = sprintf("%-10s%10s\n","If",if (is.null(instr)) " " else instr) - kwds = paste0(kwds,mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]), - "\nThen") - list(reopn=reopn,kwds=kwds) - } - ## buildKeywords - buildKeywords <- function(oReopn,pkeys,kwPname,globals) - { -cat ("in buildKeywords, oReopn=",oReopn," kwPname=",kwPname,"\n") - if (length(pkeys) == 0 && nchar(kwPname) || (length(globals$currentEditCmp$kwds) && - length(pkeys) > 0 && exists(paste0(kwPname,".mkKeyWrd")))) - { - # try to find a function that can make the keywords - fn = paste0(kwPname,".mkKeyWrd") - ans = if (exists(fn)) eval(parse(text=paste0(fn,"(input,output)"))) else NULL - } else { - # build from prms entry - ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) - if (is.null(ansFrm)) - { - kw = if (length(kwPname) > 1) kwPname[2] else kwPname[1] - kw = unlist(strsplit(kw,".",fixed=TRUE)) - kw = kw[length(kw)] - ansFrm = paste0(substr(paste0(kw," "),1,10), - "!1,10!!2,10!!3,10!!4,10!!5,10!!6,10!!7,10!") - } - reopn = NULL - fn = 0 - repeat - { - fn = fn+1 - pkey = paste0("f",fn) - fps = getPstring(pkeys,pkey,globals$activeVariants[1]) - if (is.null(fps)) break - instr = if (length(globals$currentEditCmp$atag) && - globals$currentEditCmp$atag=="c") - input[[paste0("cnd.",pkey)]] else input[[pkey]] - if(is.null(instr))instr=" " - if(instr=="blank")instr=" " - if(length(grep("noInput",fps)))instr=" " - reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) - names(reopn)[fn] = pkey - } - kwds = if ("waitYears" %in% names(oReopn)) - { - instr = input[["waitYears"]] - if (!is.null(instr)) - { - reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) - names(reopn)[length(names(reopn))] = "waitYears" - kwds = sprintf("%-10s%10s\n","If",if (is.null(instr)) " " else instr) - paste0(kwds,mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]), - "\nThen") - } - } else mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) - ans = list(ex=if (length(kwPname) > 1) kwPname[1] else if (length(grep("keyword.",kwPname))) gsub("[.].*","",gsub("keyword.","",kwPname)) - else "base", kwds=kwds,reopn=reopn) - if (length(kwPname) > 1 && length(grep("keyword.",kwPname))){ - kwd <- gsub("[.].*","",gsub("keyword.","",kwPname)) - if(kwd[2]=="estbstrp"){ - ans[1] <- if(length(grep("strp",globals$activeExtens))) "strp" else "estb" - } - } - } - ans - } - ## Save in run - observe({ - if (length(input$cmdSaveInRun) && input$cmdSaveInRun == 0) return() - isolate ({ - if (identical(globals$currentEditCmp,globals$NULLfvsCmp) && - identical(globals$currentCndPkey,character(0)) && - identical(globals$currentCmdPkey,character(0))) return() - if (length(globals$currentEditCmp$reopn) && - globals$currentEditCmp$reopn == "pasteOnSave") - { - globals$currentEditCmp$reopn = character(0) - globals$currentEditCmp$kwds = input$freeEdit - if (!is.null(input$cmdTitle) && nchar(input$cmdTitle)) - globals$currentEditCmp$title = input$cmdTitle - idx = pasteComponent(globals,input$simCont[1],globals$currentEditCmp) - if (!is.null(idx)) - { - mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - } - globals$currentEditCmp <- globals$NULLfvsCmp - closeCmp() - return() - } - if (identical(globals$currentCndPkey,character(0))) newcnd = NULL else - if (is.null(attr(globals$currentCndPkey,"keywords"))) - { - kwds = mkCondKeyWrd(globals,prms,input) - newcnd = mkfvsCmp(uuid=uuidgen(),atag="c",exten="base", - kwdName=globals$currentCndPkey,title=input$condTitle, - kwds=kwds$kwds,reopn=kwds$reopn) - } else { - newcnd = mkfvsCmp(uuid=uuidgen(),atag="c", - exten="base",kwdName="freeEdit",title=input$condTitle, - kwds=if (attr(globals$currentCndPkey,"keywords")=="condDisp") - input$condDisp else input$freeForm, - reopn=character(0)) - } - # make or edit a keyword. This section is used for both - # building a keyword and editing a keyword or a condition. - # if this is true, then we are building a new component - if (identical(globals$currentEditCmp,globals$NULLfvsCmp)) - { - if (length(globals$winBuildFunction)) - { - kwPname = globals$winBuildFunction - pkeys = character(0) - } else { - if (!is.null(attr(globals$currentCmdPkey,"keywords"))) - { - kwPname = attr(globals$currentCmdPkey,"keywords") - pkeys=NULL - } else { - kwPname = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) - pkeys = if (length(kwPname)>1) prms[[kwPname[2]]] else prms[[kwPname[1]]] - } - } - oReopn = character(0) - } else { # we are editing the component - kwPname = globals$currentEditCmp$kwdName - oReopn = globals$currentEditCmp$reopn -cat ("Editing a component: kwPname=",kwPname," oReopn=",oReopn,"\n") - pkeys = if (length(kwPname)) prms[[kwPname]] else NULL - if (is.null(pkeys) && length(oReopn) == 0) #this is freeform... - { -cat ("Editing as freeform\n") - globals$currentEditCmp$kwds = input$freeEdit - globals$currentEditCmp$reopn = character(0) - globals$currentEditCmp$title = input$cmdTitle - mkSimCnts(globals$fvsRun,sels=input$simCont[[1]], - justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - closeCmp() - return() - } - } -cat ("Building a component: kwPname=",kwPname,"\n") - ans = if (length(kwPname)==1 && kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), - reopn=NULL,kwds=input$freeEdit) else buildKeywords(oReopn,pkeys, kwPname,globals) - gensps <- grep("SpGroup", ans$kwds) - if(length(gensps)) - { - cntr <- 0 - if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else - globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 - grlist <- list() - for (spg in 1:length(ans$reopn)) if(try(ans$reopn[spg])!=" ") - { - cntr<-cntr+1 - grlist[cntr]<-ans$reopn[spg] - } - # prevent duplicate SpGroup names due to editing & saving non-name changes - grlist[1] <- gsub(" ","", grlist[1]) - tmpk <- match(grlist[1], globals$GenGrp) - if (is.na(tmpk) && !length(globals$currentEditCmp$kwds)) - globals$GenGrp[length(globals$GrpNum)]<-grlist - if (is.na(tmpk) && length(globals$currentEditCmp$kwds)) - { - globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] - globals$GenGrp <- globals$GenGrp[-length(globals$GenGrp)] - globals$GenGrp[length(globals$GrpNum)]<-grlist - } - if (!is.na(tmpk) && length(globals$currentEditCmp$kwds)) - globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] - } - if (identical(globals$currentEditCmp,globals$NULLfvsCmp)) - { - newcmp = mkfvsCmp(uuid=uuidgen(),atag="k",kwds=ans$kwds,exten=ans$ex, - variant=globals$activeVariants[1],kwdName= if (length(kwPname)>1) kwPname[2] else kwPname[1], - title=input$cmdTitle, - reopn=if (is.null(ans$reopn)) character(0) else ans$reopn) - # find the attachment point. - sel = if (length(globals$schedBoxPkey) && - input$schedbox == 3) input$condList else input$simCont[[1]] - grp = findIdx(globals$fvsRun$grps,sel) - std = if (is.null(grp)) findIdx(globals$fvsRun$stands,sel) else NULL - cmp = NULL - if (is.null(grp) && is.null(std)) - { - for (grp in 1:length(globals$fvsRun$grps)) - { - cmp = findIdx(globals$fvsRun$grps[[grp]]$cmps,sel) - if (!is.null(cmp)) break - } - if (is.null(cmp)) grp = NULL - if (is.null(grp)) for (std in 1:length(globals$fvsRun$stands)) - { - cmp = findIdx(globals$fvsRun$stands[[std]]$cmps,sel) - if (!is.null(cmp)) break - } - } - if (length(globals$schedBoxPkey) && input$schedbox == 3) - { - #tag the component as being linked to the condition. - newcmp$atag = sel - #adjust insert point. - if (is.null(std)) for (i in (cmp+1):length(globals$fvsRun$grps[[grp]]$cmps)) - { - if (i > length(globals$fvsRun$grps[[grp]]$cmps)) break - if (globals$fvsRun$grps[[grp]]$cmps[[i]]$atag == sel) cmp = i - } else for (i in (cmp+1):length(globals$fvsRun$stands[[std]]$cmps)) - { - if (i > length(globals$fvsRun$stands[[std]]$cmps)) break - if (globals$fvsRun$stands[[std]]$cmps[[i]]$atag == sel) cmp = i - } - } - # save schedBoxYrLastUsed - if (length(globals$schedBoxPkey) && input$schedbox == 1 && - length(input[[globals$schedBoxPkey]])) globals$schedBoxYrLastUsed <- - input[[globals$schedBoxPkey]] - # if there is a newcnd, then attach it first. - if (!is.null(newcnd)) - { - newcmp$atag = newcnd$uuid - if (is.null(grp)) - { - globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$stands[[std]]$cmps, newcnd) else - append(globals$fvsRun$stands[[std]]$cmps, newcnd, after=cmp) - } else { - globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$grps[[grp]]$cmps, newcnd) else - append(globals$fvsRun$grps[[grp]]$cmps, newcnd, after=cmp) - } - if (!is.null(cmp)) cmp <- cmp+1 - } - # attach the new component - if (is.null(grp)) - { - globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$stands[[std]]$cmps, newcmp) else - append(globals$fvsRun$stands[[std]]$cmps, newcmp, after=cmp) - } else { - globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$grps[[grp]]$cmps, newcmp) else - append(globals$fvsRun$grps[[grp]]$cmps, newcmp, after=cmp) - } - } else { - globals$currentEditCmp$kwds=ans$kwds - globals$currentEditCmp$title=input$cmdTitle -cat ("saving, kwds=",ans$kwds," title=",input$cmdTitle," reopn=",ans$reopn,"\n") - globals$currentEditCmp$reopn=if (is.null(ans$reopn)) character(0) else ans$reopn - globals$currentEditCmp=globals$NULLfvsCmp - } - mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - closeCmp() - globals$schedBoxPkey <- character(0) - }) - }) - - ## time--start year - observe({ - if(!length(input$simCont) || !length(globals$fvsRun$startyr) || - globals$fvsRun$startyr==input$startyr) return() - globals$fvsRun$startyr <- input$startyr - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - }) - ## time--end year - observe({ - if(!length(input$simCont) || !length(globals$fvsRun$endyr) || - globals$fvsRun$endyr==input$endyr) return() - globals$fvsRun$endyr <- input$endyr - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - }) - ## time--cycle length - observe({ - if(!length(input$simCont) || !length(globals$fvsRun$cyclelen) || globals$fvsRun$cyclelen==input$cyclelen) return() - globals$fvsRun$cyclelen <- input$cyclelen - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - }) - ## time--cycle breaks - observe({ - if(!length(input$simCont) || (length(globals$fvsRun$cycleat) && - length(input$cycleat) && globals$fvsRun$cycleat==input$cycleat)) return() - globals$fvsRun$cycleat <- input$cycleat - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - }) - - - ## runwaitback - observe( - output$bkgCpuPrompt <- renderUI(if (input$runwaitback=="Wait for run") NULL else - list(myInlineNumericInput("bkgNcpu","Background processes", - value=as.character(max(1,floor(detectCores()/2))), min="1", - max=as.character(detectCores()), step="1",size=10,labelstyle="font-weight:normal;"), - HTML(paste0("

A background run is divided into sets of ", - "separate processes that are run at once. The max ", - "number of processes is limited to ",detectCores(),", the number of CPUs ", - "cores in this computer.

"))) - )) - - - ## Save and Run - observe({ - if (input$saveandrun == 0) return() - isolate ({ - if (length(globals$fvsRun$stands) > 0) - { -cat("Nulling uiRunPlot at Save and Run\n") - output$uiRunPlot <- output$uiErrorScan <- renderUI(NULL) - globals$currentQuickPlot = character(0) - # 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))){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The common starting year of ",input$startyr, - " is more than 50 years from the current year of ", thisYr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - if ((input$startyr !="") && (input$startyr < globals$fvsRun$stands[[i]]$invyr)){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The common starting year of ",input$startyr, - " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - } - # 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)))) || - ((input$endyr !="") && nchar(input$endyr) > 4))){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The common ending year of ", input$endyr, - " is more than 40 growth cycles from the current year of ", thisYr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - if ((input$endyr !="") && ((as.numeric(input$endyr) < - as.numeric(globals$fvsRun$stands[[i]]$invyr)))){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The common ending year of ", input$endyr, - " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - } - # other cycle length check - if (((input$cyclelen !="" && ((as.numeric(input$cyclelen)) > 50))) || - ((input$cyclelen !="") && nchar(input$cyclelen) > 4)){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The growth interval of ", input$cyclelen, - " years is greater than the maximum 50 years")) - 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)), - what=0,quiet=TRUE) - # Cycle break checks - if (length(cycleat)){ - for(i in 1:length(globals$fvsRun$stands)){ - for(j in 1:length(cycleat)){ - if ((cycleat[j] > (thisYr + 400))){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The additional reporting year of ", cycleat[j], - " is more than 400 years from the current year of", thisYr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - if ((cycleat[j] < as.numeric(globals$fvsRun$stands[[i]]$invyr))){ - session$sendCustomMessage(type = "infomessage", - message = paste0("The additional reporting year of ", cycleat[j], - " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) - updateTabsetPanel(session=session,inputId="rightPan",selected="Time") - return() - } - } - } - } - progress <- shiny::Progress$new(session,min=1, - max=length(globals$fvsRun$stands)+10) - progress$set(message = "Run preparation: ", - detail = "Saving FVS Run", value = 1) - saveRun(input,session) - updateSelectInput(session=session, inputId="runSel", - choices=globals$FVS_Runs,selected=globals$FVS_Runs[[1]]) - - killIfRunning(globals$fvsRun$uuid) - # if rerunning a run that is currently selected in the "View Outputs", - # then clear those tools. - if (globals$fvsRun$uuid %in% input$runs) initTableGraphTools(globals,session,output,fvsOutData) - progress$set(message = "Run preparation: ", - detail = "Deleting old ouputs", value = 2) - removeFVSRunFiles(globals$fvsRun$uuid) - updateSelectInput(session=session, inputId="bkgRuns", - choices=getBkgRunList(),selected=0) - progress$set(message = "Run preparation: ", - detail = "Write .key file and prepare program", value = 3) -cat ("runwaitback=",input$runwaitback,"\n") - - if (input$runwaitback!="Wait for run") - { - ncpu=suppressWarnings(if(is.null(input$bkgNcpu)) NA else - as.numeric(input$bkgNcpu)) - if (is.na(ncpu)) ncpu=1 - progress$set(message = "Run preparation: ", - detail = "Starting backgrouind run", value = length(globals$fvsRun$stands)+10) - updateTextInput(session=session, inputId="bkgNcpu",value=as.character(ncpu)) - msg=extnSimulateRun(runUUID=globals$fvsRun$uuid,fvsBin=globals$fvsBin, - ncpu=ncpu) - if(msg=="wrong active database"){ -cat ("Run data query returned no data to run.\n") - progress$set(message = "Error: Keyword file was not created. Try re-importing - the inventory database associated with this run.", - detail = msg, value = 3) - Sys.sleep(5) - progress$close() - return() - } - refreshTimmer <- reactiveTimer(500,session=session) - progress$close() - output$contChange <- renderUI("Run") - return() - } - msg=writeKeyFile(globals,dbGlb$dbIcon) - fc = paste0(globals$fvsRun$uuid,".key") - if (!file.exists(fc)) - { - if(msg=="Wrong active database."){ -cat ("Wrong active database.\n") - progress$set(message = "Error: Wrong active database. Try re-importing - the inventory database associated with this run.", - detail = NA, value = 3) - return() - } else { -cat ("keyword file was not created.\n") - progress$set(message = "Error: Keyword file was not created.",detail = msg, value = 3) - Sys.sleep(5) - progress$close() - return() - } - } - if(msg=="Stand not found in FVS_ClimAttrs table."){ -cat ("Stand not found in FVS_ClimAttrs table.\n") - progress$set(message = "Error: Stand(s) not found in the existing FVS_ClimAttrs table. Check climate data - to ensure all stands in the run are included.", - detail = NA, value = 3) - return() - } - if(msg=="No Climate attributes data found."){ -cat ("No climate attributes data found.\n") - progress$set(message = "Error: No climate attributes data found. Make sure to either upload it using - the Upload Climate-FVS data menu, or check the file name on the ClimData keyword.", - detail = NA, value = 3) - return() - } - if (!dir.exists(globals$fvsBin)) - { - progress$set(message = paste0("Error: ",globals$fvsBin," does not exist."), - detail = "", value = 3) - Sys.sleep(5) - progress$close() - return() - } - dir.create(globals$fvsRun$uuid) - fvschild = makePSOCKcluster(1) - #on exit of the reactive context - on.exit({ - 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('", - globals$fvsRun$FVSpgm,"',bin='",globals$fvsBin,"'))") -cat ("load FVSpgm cmd=",cmd,"\n") - rtn = try(eval(parse(text=cmd))) - if (class(rtn) == "try-error") return() - # if not using the default run script, load the one requested. - if (globals$fvsRun$runScript != "fvsRun") - { - rsFn = paste0("customRun_",globals$fvsRun$runScript,".R") - if (!file.exists(rsFn)) rsFn = system.file("extdata", rsFn, - package="fvsOL") - if (!file.exists(rsFn)) return() - cmd = paste0("clusterEvalQ(fvschild,source('",rsFn,"'))") -cat ("run script load cmd=",cmd,"\n") - rtn = try(eval(parse(text=cmd))) - if (class(rtn) == "try-error") return() - runOps <- if (is.null(globals$fvsRun$uiCustomRunOps)) list() else - globals$fvsRun$uiCustomRunOps - rtn = try(clusterExport(fvschild,list("runOps"),envir=environment())) - if (class(rtn) == "try-error") return() - } - foo = paste0(globals$fvsRun$uuid,".key") - cmd = paste0("clusterEvalQ(fvschild,",'fvsSetCmdLine("--keywordfile=',foo,'"))') -cat ("load run cmd=",cmd,"\n") - rtn = try(eval(parse(text=cmd))) - if (class(rtn) == "try-error") return() -cat ("at for start\n") - allSum = list() - for (i in 1:length(globals$fvsRun$stands)) - { - detail = paste0("Stand ",i," StandId=",globals$fvsRun$stands[[i]][["sid"]]) - progress$set(message = "FVS running", detail = detail, value = i+4) - rtn = if (globals$fvsRun$runScript != "fvsRun") - { - cmd = paste0("clusterEvalQ(fvschild,",globals$fvsRun$runScript,"(runOps))") -cat ("custom run cmd=",cmd,"\n") - try(eval(parse(text=cmd))) - } else { -cat ("running normal run cmd\n") - try(clusterEvalQ(fvschild,fvsRun())) - } -cat ("rtn class for stand i=",i," is ",class(rtn),"\n") - if (class(rtn) == "try-error") - { - cat ("run try error\n") - return() - } - rtn = rtn[[1]] - if (rtn != 0) break - ids = try(clusterEvalQ(fvschild,fvsGetStandIDs())) - if (class(ids) == "try-error") break - ids = ids[[1]] - rn = paste0("SId=",ids["standid"],";MId=",ids["mgmtid"]) -cat ("rn=",rn,"\n") - rtn = try(clusterEvalQ(fvschild,fvsSetupSummary(fvsGetSummary()))) - if (class(rtn) == "try-error") break - allSum[[i]] = rtn[[1]] - names(allSum)[i] = rn - } -cat ("rtn,class=",class(rtn),"\n") - try(clusterEvalQ(fvschild,fvsRun())) - progress$set(message = "Scanning output for errors", detail = "", - value = length(globals$fvsRun$stands)+4) - outf=paste0(globals$fvsRun$uuid,".out") - errScan = try(extnErrorScan(outf)) - if (class(errScan) == "try-error") errScan = - "Error scan failed likely due to invalid multibyte strings in output" - output$uiErrorScan <- renderUI(list( - h6(paste0("Run made with: ",globals$fvsRun$FVSpgm)," ",attr(errScan,"pgmRV")), - h5("FVS error scan: "), - tags$style(type="text/css", paste0("#errorScan { overflow:auto; ", - "height:150px; font-family:monospace; font-size:90%;}")), - HTML(paste(errScan,"
")))) - if (length(dir(globals$fvsRun$uuid)) == 0) - unlink(globals$fvsRun$uuid,recursive = TRUE, force = TRUE) - progress$set(message = if (length(allSum) == length(globals$fvsRun$stands)) - "FVS finished" else - "FVS run failed", detail = "", - value = length(globals$fvsRun$stands)+5) - Sys.sleep(.1) -cat ("length(allSum)=",length(allSum),"\n") - if (length(allSum) == 0) {Sys.sleep(.4); return()} - progress$set(message = "FVS finished", - detail = "Merging output to master database", - value = length(globals$fvsRun$stands)+6) - res = addNewRun2DB(globals$fvsRun$uuid,dbGlb$dbOcon) - unlink(paste0(globals$fvsRun$uuid,".db")) - unlink(paste0(globals$fvsRun$uuid,"_genrpt.txt")) - progress$set(message = "Building plot", detail = "", - value = length(globals$fvsRun$stands)+6) - modn = names(allSum) - toch = unique(modn) - if (length(toch) != length(modn)) - { - for (chg in toch) - { - chrr = chg == modn - if ((nch <- sum(chrr)) < 2) next - chg = unlist(strsplit(chg,";")) - modn[chrr] = sprintf("%s r%03i;%s",chg[1],1:nch,chg[2]) - } - names(allSum) = modn - } - X <- Y <- Stand <- NULL - unitConv = if (substring(globals$fvsRun$FVSpgm,4) %in% c("bc","on")) - 0.0699713 else 1 # note FT3pACRtoM3pHA = 0.0699713 - for (i in 1:length(allSum)) - { - X = c(X,allSum[[i]][,"Year"]) - Y = c(Y,allSum[[i]][,"TCuFt"]) * unitConv - ltag = gsub(x=names(allSum)[i],pattern=";.*$",replacement="") - ltag = gsub(x=ltag,pattern="^SId=",replacement="") - Stand=c(Stand,c(rep(ltag,nrow(allSum[[i]])))) - } - toplot = data.frame(X = X, Y=Y, Stand=as.factor(Stand)) - toMany = nlevels(toplot$Stand) > 9 - colors = autorecycle(cbbPalette,nlevels(toplot$Stand)) - yUnits = expression(Total~(ft^{3}/a)) - if (substring(globals$fvsRun$FVSpgm,4) %in% c("cs","ls","ne","sn")) - yUnits = expression(Merchantable~(ft^{3}/a)) - else if (substring(globals$fvsRun$FVSpgm,4) %in% c("bc","on")) - yUnits = expression(Total~(m^{3}/ha)) - plt = ggplot(data = toplot) + scale_colour_manual(values=colors) + - geom_line (aes(x=X,y=Y,color=Stand)) + - labs(x="Year", y=yUnits) + - theme(text = element_text(size=6), - legend.position=if (toMany) "none" else "right", - axis.text = element_text(color="black")) - width=if (toMany) 3 else 4 - height=2.5 - CairoPNG("www/quick.png", width=width, height=height, units="in", res=150) - print(plt) - dev.off() - output$uiRunPlot <- renderUI( - plotOutput("runPlot",width="100%",height=paste0((height+1)*144,"px"))) - output$runPlot <- renderImage(list(src="www/quick.png", width=(width+1)*144, - height=(height+1)*144), deleteFile=TRUE) -cat ("setting currentQuickPlot, input$runSel=",input$runSel,"\n") - globals$currentQuickPlot = globals$fvsRun$uuid - globals$changeind <- 0 - output$contChange <- renderUI("Run") - updateTabsetPanel(session=session, inputId="leftPan",selected="Load") - } - }) - }) - -## bkgKill - observe({ - if (input$bkgKill == 0) return() - isolate ({ - if (!is.null(input$bkgRuns)) - { - uuid=sub(".pidStatus","",input$bkgRuns) - killIfRunning(uuid) - removeFVSRunFiles(uuid) - } - updateSelectInput(session=session, inputId="bkgRuns", - choices=getBkgRunList(),selected=0) - }) - }) - -## refreshTimmer - refreshTimmer <- reactiveTimer(2000,session=session) - observe({ - if (refreshTimmer()) - { - # 2000 millisceconds = 2 seconds - choices=getBkgRunList() - refreshTimmer <- if (length(choices)==0) reactiveTimer(Inf,session=session) else - reactiveTimer(2000,session=session) - updateSelectInput(session=session, inputId="bkgRuns", - choices=getBkgRunList(),selected=isolate(input$bkgRuns)) - } - }) - ## Download handlers - ## Download dlRenderData - - output$dlRenderData <- downloadHandler( - filename=function () paste0("table",input$dlRDType), - content=function (tf = tempfile()) - { - if (input$dlRDType == ".csv") - { - if (nrow(fvsOutData$render) > 0) - write.csv(fvsOutData$render,file=tf,row.names=FALSE) else - cat (file=tf,'"No data"\n') - } else { - if (nrow(fvsOutData$render) > 0) - { - excelRowLimit=1048576 - if (nrow(fvsOutData$render) > excelRowLimit) - write.xlsx(fvsOutData$render[1:excelRowLimit,],file=tf,colNames = TRUE) else - write.xlsx(fvsOutData$render,file=tf,colNames = TRUE) - } else write.xlsx(file=tf) - } - }, contentType=if (length(input$table) && input$dlRDType==".csv") "text/csv" else - "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") - ### NB: length(input$table) is tested only to force this downloadHandler to fire. - ## Download dlFVSDatadb - output$dlFVSDatadb <- downloadHandler( - filename="FVS_Data.db", - content = function (tf = tempfile()) file.copy("FVS_Data.db",tf)) - ## Download dlFVSOutdb - output$dlFVSOutdb <- downloadHandler( - filename="FVSOut.db", - content = function (tf = tempfile()) file.copy("FVSOut.db",tf)) - ## Download dlFVSOutxlsx - output$dlFVSOutxlsx <- downloadHandler( - filename= function () paste0(globals$fvsRun$title,"_FVSoutput.xlsx"), - content = function (tf = paste0(tempfile(),".xlsx")) - { - # limit the number of rows exported to Excel to 1,048,576 - excelRowLimit=1048576 - runuuid = globals$fvsRun$uuid - if (is.null(runuuid)) return() - tabs = myListTables(dbGlb$dbOcon) - if (!("FVS_Cases" %in% tabs)) return() - cases = dbGetQuery(dbGlb$dbOcon,paste0("select CaseID from FVS_Cases ", - "where KeywordFile = '",globals$fvsRun$uuid,"';")) - if (nrow(cases) == 0) return() -cat ("download run as xlsx, ncases=",nrow(cases),"\n") - tmp = paste0("tmp",gsub("-","",runuuid),Sys.getpid(),"genoutput") - dbExecute(dbGlb$dbOcon,paste0("attach database ':memory:' as ",tmp)) - casesToGet = paste0(tmp,".casesToGet") - dbWriteTable(dbGlb$dbOcon,name=DBI::SQL(casesToGet),value=cases,overwirte=TRUE) - out = list() - cmpYes = if ("CmpMetaData" %in% tabs) - { - meta = try(dbReadTable(dbGlb$dbOcon,"CmpMetaData")) - class(meta) == "data.frame" && meta$KeywordFile == runuuid - } - for (tab in tabs) - { - qry = if (!is.null(cmpYes) && cmpYes && substr(tab,1,3) == "Cmp") - paste0("select * from ",tab," limit ",excelRowLimit,";") else - paste0("select * from ",tab," where ",tab,".CaseID in", - " (select CaseID from ",casesToGet,") limit ",excelRowLimit,";") - dat = try(dbGetQuery(dbGlb$dbOcon,qry)) - if (class(dat) == "try-error") next - if (nrow(dat) == 0) next - out[[tab]] = dat -cat ("qry=",qry," class(dat)=",class(dat),"\n") - } - dbExecute(dbGlb$dbOcon,paste0("detach database ",tmp,";")) - if (length(out)) write.xlsx(file=tf,out) - }, contentType=NULL) - ## dlPrjBackup - output$dlPrjBackup <- downloadHandler(filename=function () - isolate({ - bckupPick <- input$pickBackup - if (file.exists(bckupPick)) bckupPick else "NoBackup.txt" - }), - content=function (tf = tempfile()) - { - sfile = input$pickBackup - if (file.exists(sfile)) file.copy(sfile,tf) else - cat (file=tf,"Backup does not exist.\n") - }, contentType="zip") - - ## DownLoad - output$dlFVSRunout <- downloadHandler( - filename=function() paste0(globals$fvsRun$title,"_FVSoutput.txt"), - content=function (tf = tempfile()) - { - sfile = paste0(input$runSel,".out") - if (file.exists(sfile)) - { - file.copy(sfile,tf) - # use perl to change line endings, ignore if an error is detected - if (!isLocal()) try(system(paste0("perl -pi -e 's/\\n/\\r\\n/' ",tf))) - } else cat (file=tf,"Output not yet created.\n") - }, contentType="text") - ## Download keywords - output$dlFVSRunkey <- downloadHandler( - filename=function()paste0(globals$fvsRun$title,"_FVSkeywords.txt"), - content=function (tf = tempfile()) - { - sfile = paste0(input$runSel,".key") - if (file.exists(sfile)) file.copy(sfile,tf) else - cat (file=tf,"Keywords not yet created.\n") - }, contentType="text") - - ## Download FVSProjectData.zip - output$dlFVSRunZip <- downloadHandler( - filename="FVSProjectData.zip", - content = function (tf = tempfile()) - { - tempDir = paste0(dirname(tf),"/tozip") - if (dir.exists(tempDir)) lapply(paste0(tempDir,"/",dir(tempDir)),unlink) else - dir.create(tempDir) - spatdat = "SpatialData.RData" - for (ele in input$dlZipSet) - { -cat ("building download, ele=",ele,"\n") - switch (ele, - outdb = { - from="FVSOut.db" - to=file.path(tempDir,from) - if (file.exists(from)) file.copy(from=from,to=to) else - cat (file=to,"Output database does not exist.\n") - }, - key = { - from=paste0(input$runSel,".key") - to=file.path(tempDir,paste0(globals$fvsRun$title,"_FVSkeywords.txt")) - if (file.exists(from)) file.copy(from=from,to=to) - }, - out = { - from=paste0(input$runSel,".out") - to=paste0(tempDir,"/",globals$fvsRun$title,"_FVSoutput.txt") - if (file.exists(from)) file.copy(from=from,to=to) - }, - subdir= { - from=input$runSel - if (dir.exists(from)) - { - to = file.path(tempDir,paste0(globals$fvsRun$title,"_SVS")) - dir.create (to) - file.copy(from=from,to=to,recursive = TRUE) - file.copy(from=paste0(from,"_index.svs"),to=to) - } - }, - FVS_Data = file.copy(from="FVS_Data.db" , - to=file.path(tempDir,"FVS_Data.db")), - fvsProjdb = { - rdat="FVSProject.db" - if (file.exists(rdat)) file.copy(from=rdat,to=file.path(tempDir,rdat)) - }, - SpatialData = { - spatdat = "SpatialData.RData" - if (file.exists(spatdat)) file.copy(from=spatdat, - to=file.path(tempDir,spatdat)) - } - - )} - curdir = getwd() - setwd(tempDir) - zipr(tf,dir()) - unlink(tempDir,recursive = TRUE) - setwd(curdir) - }, contentType="application/zip") - - ## kcpUpload - observe({ - if (is.null(input$kcpUpload)) return() - data=scan(file=input$kcpUpload$datapath,sep="\n",what="",quiet=TRUE) - if (input$kcpUpload$name=="FVS_kcps.RData") data <- data[4:length(data)] - if (length(data)==0) return() - isolate ({ - addnl = TRUE - if (length(globals$customCmps) == 0 && input$kcpUpload$name=="FVS_kcps.RData") - { - load(input$kcpUpload$datapath) - globals$customCmps = customCmps - addnl = FALSE - } - if (length(globals$customCmps) && !is.null(globals$customCmps) && input$kcpEdit !=""){ - updateSelectInput(session=session, inputId="kcpSel", selected = 0) - } - updateTextInput(session=session, inputId="kcpTitle", value= - paste("From:",input$kcpUpload$name)) - if(addnl){ - updateTextInput(session=session, inputId="kcpEdit", value= - paste(data,collapse="\n")) - } else { - updateTextInput(session=session, inputId="kcpEdit", value=globals$customCmps[1]) - save(file="FVS_kcps.RData",customCmps) - } - }) - }) - - ## kcpSel - observe({ - if (length(input$kcpSel) == 0) return() -cat ("kcpSel called, input$kcpSel=",input$kcpSel,"\n") - if (is.null(input$kcpSel)) - { - updateTextInput(session=session, inputId="kcpTitle",value="") - updateTextInput(session=session, inputId="kcpEdit",value="") - } else { - sel = match(trim(input$kcpSel),trim(names(globals$customCmps))) - updateTextInput(session=session, inputId="kcpTitle", - value=names(globals$customCmps)[sel]) - updateTextInput(session=session, inputId="kcpEdit", - value=globals$customCmps[[sel]]) - } - }) - - ## kcpNew - observe({ - if (length(input$kcpNew) && input$kcpNew > 0) - { - isolate ({ - updateSelectInput(session=session, inputId="kcpSel", selected = 0) - updateTextInput(session=session, inputId="kcpTitle", value="") - updateTextInput(session=session, inputId="kcpEdit", value="") - globals$kcpAppendConts <- list() - globals$condKeyCntr <- 0 - }) -cat ("kcpNew called, input$kcpNew=",input$kcpNew,"\n") - } - }) - - ## kcpAppend - observe({ - if (length(input$kcpAppend) && input$kcpAppend > 0) - { - isolate ({ - topaste = findCmp(globals$fvsRun,input$simCont[1]) - if (is.null(topaste)) return() - if (nchar(input$kcpTitle) == 0) - updateTextInput(session=session, inputId="kcpTitle", - value=topaste$title) - updateTextInput(session=session, inputId="kcpEdit", value= - paste0(input$kcpEdit,"* ",topaste$title,"\n",topaste$kwds,"\n")) - session$sendCustomMessage(type="refocus", "kcpEdit") - indx <- match(input$simCont,globals$fvsRun$simcnts) - if (!length(globals$kcpAppendConts)){ - globals$kcpAppendConts[1] <- globals$fvsRun$simcnts[indx] - names(globals$kcpAppendConts)[1] <- names(globals$fvsRun$simcnts)[indx] - }else - globals$kcpAppendConts[(length(globals$kcpAppendConts)+1)] <- globals$fvsRun$simcnts[indx] - names(globals$kcpAppendConts)[length(globals$kcpAppendConts)] <- names(globals$fvsRun$simcnts)[indx] - # first conditional added - if (length(grep("^-> Cnd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && - (!length(globals$opencond) || globals$opencond==0)){ - globals$opencond <- 1 - globals$condKeyCntr <- 0 - } - # first conditional keyword added - if (length(grep("^--> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)])))){ - globals$condKeyCntr <- globals$condKeyCntr + 1 - } - if (length(grep("^-> Cnd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && - (length(globals$condKeyCntr) && globals$condKeyCntr > 0)){ - globals$opencond <- 0 - globals$condKeyCntr <- 0 - updateTextInput(session=session, inputId="kcpEdit", value= - paste0(input$kcpEdit,"ENDIF\n","* ",topaste$title,"\n",topaste$kwds,"\n")) - } - if (length(grep("^-> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)])))&& - (length(globals$condKeyCntr) && globals$condKeyCntr > 0)){ - globals$opencond <- 0 - globals$condKeyCntr <- 0 - updateTextInput(session=session, inputId="kcpEdit", value= - paste0(input$kcpEdit,"ENDIF\n","* ",topaste$title,"\n",topaste$kwds,"\n")) - } - }) - } - }) - - ## kcpSaveInRun - observe({ - if (length(input$kcpSaveInRun) && input$kcpSaveInRun > 0) - { - isolate ({ -cat ("kcpSaveInRun\n") - if (nchar(input$kcpTitle) == 0) - { - newTit = paste0("Editor: Component ",length(globals$customCmps)+1) - updateTextInput(session=session, inputId="kcpTitle", value=newTit) - } else newTit = paste0("Editor: ",trim(input$kcpTitle)) - newcmp = mkfvsCmp(uuid=uuidgen(),atag="k",kwds=input$kcpEdit,exten="base", - variant=globals$activeVariants[1],kwdName="FreeEdit", - title=newTit,reopn=character(0)) - # find the attachment point. - sel = input$simCont[[1]] - grp = findIdx(globals$fvsRun$grps,sel) - std = if (is.null(grp)) findIdx(globals$fvsRun$stands,sel) else NULL - cmp = NULL - if (is.null(grp) && is.null(std)) - { - for (grp in 1:length(globals$fvsRun$grps)) - { - cmp = findIdx(globals$fvsRun$grps[[grp]]$cmps,sel) - if (!is.null(cmp)) break - } - if (is.null(cmp)) grp = NULL - if (is.null(grp)) for (std in 1:length(globals$fvsRun$stands)) - { - cmp = findIdx(globals$fvsRun$stands[[std]]$cmps,sel) - if (!is.null(cmp)) break - } - } - # attach the new component - if (is.null(grp)) - { - globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$stands[[std]]$cmps, newcmp) else - append(globals$fvsRun$stands[[std]]$cmps, newcmp, after=cmp) - } else { - globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) - append(globals$fvsRun$grps[[grp]]$cmps, newcmp) else - append(globals$fvsRun$grps[[grp]]$cmps, newcmp, after=cmp) - } - mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - globals$changeind <- 1 - output$contChange <- renderText(HTML("*Run*")) - globals$schedBoxPkey <- character(0) - }) - } - }) - - ## kcpSaveCmps - observe({ - if (length(input$kcpSaveCmps) && input$kcpSaveCmps > 0) - { - isolate ({ -cat ("kcpSaveCmps called, kcpTitle=",input$kcpTitle," isnull=", -is.null(input$kcpTitle),"\n") - if (nchar(input$kcpTitle) == 0) - { - newTit = paste0("Component ",length(globals$customCmps)+1) - updateTextInput(session=session, inputId="kcpTitle", value=newTit) - } else newTit = trim(input$kcpTitle) - globals$customCmps[[newTit]] = input$kcpEdit - customCmps = globals$customCmps - skip1 <- strsplit(as.character(customCmps),"\n")[[1]][length(strsplit(as.character(customCmps),"\n")[[1]])] - skip <- length(grep("ENDIF", toupper(skip1))) - if(length(grep("^--> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && !skip) - { - updateTextInput(session=session, inputId="kcpEdit", value= - paste0(customCmps,"EndIf\n")) - customCmps <-as.list(paste0(customCmps,"EndIf\n")) - names(customCmps) <- names(globals$customCmps) - globals$customCmps = customCmps - } - storeOrUpdateObject(dbGlb$prjDB,customCmps) - updateSelectInput(session=session, inputId="kcpSel", - choices=names(globals$customCmps), - selected=newTit) - mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - }) - } - }) - - ## kcpDelete - observe({ - if (length(input$kcpDelete) && input$kcpDelete > 0) - { - isolate ({ -cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") - if (length(globals$customCmps)) - { - if(is.null(input$kcpSel)){ - - updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(globals$customCmps)), - selected=names(globals$customCmps)[1]) - return() - } - if(length(globals$customCmps)==1){ - customCmps=NULL - removeObject(dbGlb$prjDB,"customCmps") - globals$customCmps <- list() - updateSelectInput(session=session, inputId="kcpSel", choices=list()) - updateTextInput(session=session, inputId="kcpTitle", value="") - updateTextInput(session=session, inputId="kcpEdit", value="") - return() - } - sel = na.omit(match(trim(input$kcpSel),trim(names(globals$customCmps)))) - if (length(sel) && input$kcpSel==input$kcpTitle) globals$customCmps[[sel[1]]] = NULL - customCmps = globals$customCmps - storeOrUpdateObject(dbGlb$prjDB,customCmps) - updateSelectInput(session=session, inputId="kcpSel", choices=names(customCmps)) - if(input$kcpSel!=input$kcpTitle){ - sel = match(trim(input$kcpSel),trim(names(globals$customCmps))) - updateTextInput(session=session, inputId="kcpTitle", - value=names(globals$customCmps)[sel]) - updateTextInput(session=session, inputId="kcpEdit", - value=globals$customCmps[[sel]]) - } - } else { - customCmps=NULL - removeObject(dbGlb$prjDB,"customCmps") - globals$customCmps <- list() - updateSelectInput(session=session, inputId="kcpSel", choices=list()) - updateTextInput(session=session, inputId="kcpTitle", value="") - updateTextInput(session=session, inputId="kcpEdit", value="") - } - }) - } - }) - - ## Download KCP - output$kcpDownload <- downloadHandler(filename=function () - paste0(input$kcpTitle,".kcp"), - content=function (tf = tempfile()) - { - write(input$kcpEdit,tf) - }, contentType="text") - - observe({ - if (input$topPan == "Visualize") - { -cat ("Visualize hit\n") - allRuns = globals$FVS_Runs - runChoices = list() - for (has in names(allRuns)) - { - fn = paste0(allRuns[[has]],"_index.svs") - if (file.exists(fn)) runChoices[[has]] = allRuns[[has]] else - { - fn = file.path(paste0(allRuns[[has]],"-set1"), - paste0(allRuns[[has]],"_index.svs")) - if (file.exists(fn)) runChoices[[has]] = allRuns[[has]] - } - } - updateSelectInput(session=session, inputId="SVSRunList1", - choices=runChoices,selected=0) - updateSelectInput(session=session, inputId="SVSRunList2", - choices=runChoices,selected=0) - updateSelectInput(session=session, inputId="SVSImgList1", choices=list(), - selected=0) - updateSelectInput(session=session, inputId="SVSImgList2", choices=list(), - selected=0) - session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm1').hide();$('#SVSdynIm1').hide();")) - output$SVSqImg1Pers = renderUI(NULL) - output$SVSqImg1Top = renderUI(NULL) - output$SVSqImg1Side = renderUI(NULL) - output$SVSImg1 = renderRglwidget(NULL) - session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm2').hide();$('#SVSdynIm2').hide();")) - output$SVSqImg2Pers = renderUI(NULL) - output$SVSqImg2Top = renderUI(NULL) - output$SVSqImg2Side = renderUI(NULL) - output$SVSImg2 = renderRglwidget(NULL) - } - }) - - ## mkSVSchoices - mkSVSchoices <- function(svsRun) - { - fns = paste0(svsRun,"_index.svs") - if (!file.exists(fns)) - { - fns = NULL - i = 1 - repeat - { - fn = file.path(paste0(svsRun,"-set",i),paste0(svsRun,"_index.svs")) - if (!file.exists(fn)) break - fns = c(fns,fn) - i = i+1 - } - } - index=NULL - for (fn in fns) - { - ind=read.table(file=fn,as.is=TRUE) - if (dirname(fn)!=".") ind[,2]=file.path(dirname(fn),ind[,2]) - index = rbind(index,ind) - } - inv=grep ("Inventory conditions",index[,1]) - if (length(inv)>1) - { - firsts=substr(index[inv,1],1,regexpr(" ",index[inv,1])-1) - names(inv)=firsts - rptrs = cbind(inv,c(inv[2:length(inv)]-1,nrow(index))) - rptrs = data.frame(ids=rownames(rptrs),start=rptrs[,1],stop=rptrs[,2]) - rptrs = rptrs[order(rptrs[,1],rptrs[,2],decreasing=c(FALSE,FALSE),method="radix"),] - dups=table(firsts) - if (any(dups>1)) - { - dups=dups[dups>1] - d2 = rep(1,length(dups)) - for (i in 1:nrow(rptrs)) - { - id=grep(rptrs[i,1],names(dups)) - if (length(id)) - { - index[rptrs[i,2]:rptrs[i,3],1]= - sub(" ",sprintf(" r%03i ",d2[id]),index[rptrs[i,2]:rptrs[i,3],1]) - d2[id]=d2[id]+1 - } - } - } - index = index[unlist(c(apply(rptrs,1,function (x) x[2]:x[3]))),] - } - choices = as.list(index[,2]) - names(choices) = index[,1] - choices - } - - ## SVSRunList1 - observe({ - if (length(input$SVSRunList1)) - { -cat ("Visualize input$SVSRunList1=",input$SVSRunList1,"\n") - choices = mkSVSchoices(input$SVSRunList1) - updateSelectInput(session=session, inputId="SVSImgList1", choices=choices, - selected = 0) - session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm1').hide();$('#SVSdynIm1').hide();")) - output$SVSqImg1Pers = renderUI(NULL) - output$SVSqImg1Top = renderUI(NULL) - output$SVSqImg1Side = renderUI(NULL) - output$SVSImg1 = renderRglwidget(NULL) - } - }) - - ## SVSRunList2 - observe({ - if (length(input$SVSRunList2)) - { -cat ("Visualize input$SVSRunList2=",input$SVSRunList2,"\n") - choices = mkSVSchoices(input$SVSRunList2) - updateSelectInput(session=session, inputId="SVSImgList2", choices=choices, - selected = 0) - session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm2').hide();$('#SVSdynIm2').hide();")) - output$SVSqImg2Pers = renderUI(NULL) - output$SVSqImg2Top = renderUI(NULL) - output$SVSqImg2Side = renderUI(NULL) - output$SVSImg2 = renderRglwidget(NULL) - } - }) - - ## renderSVSImage - renderSVSImage <- function (id,imgfile,subplots=TRUE,downTrees=TRUE, - fireLine=TRUE,rangePoles=TRUE,plotColor="gray") - { -cat ("renderSVSImage, subplots=",subplots," downTrees=",downTrees, - " fireLine=",fireLine," rangePoles=",rangePoles,"\n") - for (dd in rgl.dev.list()) try(rgl.close()) - open3d(useNULL=TRUE) - svs = scan(file=paste0(imgfile),what="character",sep="\n",quiet=TRUE) - treeform = grep ("#TREEFORM",svs) - if (length(treeform)) - { - treeform = scan(text=svs[treeform],what="character",quiet=TRUE)[2] - treeform = tolower(scan(text=treeform,sep=".",what="c",quiet=TRUE)[1]) - if (! (treeform %in% names(treeforms))) - { - output[[id]] <- NULL -cat ("treeform=",treeform," is absent from treeforms, exiting.\n") - return() - } - } - treeform = treeforms[[treeform]] - rcirc = grep ("^#CIRCLE",svs) - if (length(rcirc)) - { -# rgl.viewpoint(theta = 1, phi = -45, fov = 30, zoom = .8, interactive = TRUE) - rgl.viewpoint(theta = 1, phi = -40, fov = 0, zoom = .9, interactive = TRUE) - args = as.numeric(scan(text=svs[rcirc[1]],what="character",quiet=TRUE)[2:4]) -cat ("args=",args,"\n") - plotDef = circle3D(x0=args[1],y0=args[2],r=args[3],col=plotColor,alpha=0.7) - if (subplots && length(rcirc)>1) - { - for (cir in rcirc[2:length(rcirc)]) - { - ca = as.numeric(scan(text=svs[cir],what="character",quiet=TRUE)[2:4]) - circle3D(x0=ca[1],y0=ca[2],r=ca[3],alpha=1,fill=FALSE,col="black") - } - } - pltshp=1 - } else { # assume square, look for arguments of the rectangle. - rgl.viewpoint(theta = 1, phi = -45, fov = 30, zoom = .9, interactive = TRUE) - rect = grep ("^#RECTANGLE",svs) - if (length(rect)) - { - args = as.numeric(scan(text=svs[rect],what="character",quiet=TRUE)[4]) - plotDef = matrix(c(0,0,0,0,args,0,args,args,0,args,0,0,0,0,0),ncol=3,byrow=TRUE) - polygon3d(plotDef,col=plotColor,alpha=0.7) - } - pltshp=0 - } - if (subplots) - { - subplts = grep("^#LINE",svs) - if (length(subplts)) - { - crds = as.numeric(scan(text=substring(svs[subplts],6),what="character",quiet=TRUE)) - crds = cbind(matrix(crds,ncol=2,byrow=TRUE),0) - segments3d(crds,col="black",add=TRUE) - } - } - rpols = grep("^RANGEPOLE",svs) - if (length(rpols)) - { - if (rangePoles) - { - poles = c() - for (line in rpols) - { - pole = as.numeric(scan(text=svs[line],what="character",quiet=TRUE)[c(21,22,7)]) - poles = c(poles,c(pole[1:2],0,pole)) - } - poles = matrix(poles,ncol=3,byrow=TRUE) - segments3d(poles,col="red",lwd=4,add=TRUE) - } - svs=svs[-rpols] - } - calls = 0 - frlineS = grep("^#FIRE_LINE",svs) -cat ("length(frlineS)=",length(frlineS),"fireLine=",fireLine,"\n") - if (length(frlineS)) - { - if (fireLine) - { - fl = as.numeric(scan(text=substring(svs[frlineS],11),what="numeric",quiet=TRUE)) - frline=NULL - if (pltshp) - { - xx = seq(0,args[3]*2,length.out=length(fl)) - r = sqrt(((xx-args[3])^2) + ((fl-args[3])^2)) - k = r<=args[3] - if (any(k)) - { - frline = matrix(c(xx[k],fl[k],rep(0,sum(k))),ncol=3,byrow=FALSE) - frline = frline[nrow(frline):1,] - kep1=which.min(((plotDef[,1]-frline[1,1])**2)+((plotDef[,2]-frline[1,2])**2)) - kep2=which.min(((plotDef[,1]-frline[nrow(frline),1])**2)+((plotDef[,2]-frline[nrow(frline),2])**2)) - frline[1,]=plotDef[kep1,] - frline[nrow(frline),]=plotDef[kep2,] - brnReg = rbind(frline[2:(nrow(frline)-1),],plotDef[kep2:nrow(plotDef),]) - if (kep1<(nrow(plotDef)/2)) brnReg = rbind(plotDef[1:kep1,],brnReg) - polygon3d(brnReg,col="black",alpha=0.5) - } - } else { - frline = matrix(c(seq(0,args[1],length.out=length(fl)), - fl,rep(0,length(fl))),ncol=3,byrow=FALSE) - brnReg = rbind(plotDef[1,],frline,plotDef[4:5,]) - polygon3d(brnReg,col="black",alpha=0.5) - } - if (!is.null(frline)) - { - lines3d(frline,col="red",lwd=4,add=TRUE) - nn=500 - fls = approx(frline[,1],frline[,2],rule=2,n=nn) - fls$z = runif(nn)*3 - fls$y = jitter(fls$y,amount=5) - fls = matrix(c(fls$x,fls$y,fls$z),ncol=3,byrow=FALSE) - fls = t(apply(fls,1,function (x) c(x[1]-x[3],x[2],0,x[1],x[2],x[3]*3, - x[1]+x[3],x[2],0))) - verts = NULL - for (row in 1:nrow(fls)) - { - tlt=runif(1)*40 - rot=runif(1)*360 - mat = matrix(fls[row,],ncol=3,byrow=TRUE) - xs = max(mat[,1])-(diff(range(mat[,1]))*.5) - ys = max(mat[,2])-(diff(range(mat[,2]))*.5) - zs = max(mat[,3])-(diff(range(mat[,3]))*.5) - mat[,1] = mat[,1]-xs - mat[,2] = mat[,2]-ys - mat[,3] = mat[,3]-zs - mat = matRotat(mat,tlt,tlt,rot) - mat[,1] = mat[,1]+xs - mat[,2] = mat[,2]+ys - mat[,3] = mat[,3]+zs - mat[,3] = ifelse(mat[,3]<0,0,mat[,3]) - verts = rbind(verts,mat) - } - triangles3d(verts,col="red") - } - } - svs = svs[-frlineS] - } - progress <- shiny::Progress$new(session,min=1,max=length(svs)+4) - flames = grep("^@flame.eob",svs) -cat("N flames=",length(flames)," fireLine=",fireLine,"\n") - if (length(flames)) - { - if (fireLine) - { - calls = calls+1 - progress$set(message = "Generate flames",value = calls) - allv = NULL - nflsm = 5 - tmp=NULL - for (fl in svs[flames]) - { - fdat = as.numeric(scan(text=substring(fl,30),what="numeric",quiet=TRUE)) - # ht,tilt,rotation,width,x,y,z - fdat = fdat[c(1,2,3,5,15,16,17)] - names(fdat)=c("ht","tlt","rot","wid","x","y","z") - tmp=rbind(tmp,fdat[c("x","y","z")]) - hw=fdat["wid"]*.5 - hwr=rnorm(nflsm,hw,.5) - hwr=ifelse(hwr<(hw*.1),hw*.1,hw) - ht=fdat["ht"] - htr=rnorm(nflsm,ht,1) - htr=ifelse(ht<(htr*.1),ht*.1,ht) - tlt=runif(nflsm)*2*fdat["tlt"] - fbr=rnorm(nflsm,fdat["z"],.5) - fbr=ifelse(fbr<0,0,fbr) - rot=runif(nflsm)*360 - for (i in 1:nflsm) - { - verts = cbind(x=c(-hwr[i],hwr[i],0), - y=c(0,0,0), - z=c(0,0,htr[i])) - verts = matRotat(verts,xa=tlt[i],ya=tlt[i],za=rot[i]) - verts[,1]=verts[,1]+fdat["x"] - verts[,2]=verts[,2]+fdat["y"] - verts[,3]=verts[,3]+rnorm(1,fbr[i],1) - allv = rbind(allv,verts) - } - } - triangles3d(allv[,1],allv[,2],allv[,3],col=c("yellow","red")) - } - svs = svs[-flames] - } -cat("Residual length of svs=",length(svs),"\n") - drawnTrees = list() - trees = list() - for (line in svs) - { - calls = calls+1 - progress$set(message = "Generate trees",value = calls) - c1 = substr(line,1,1) - if (c1 == "#" || c1 == ";") next - tree = scan(text=line,what="character",quiet=TRUE) - if (!downTrees && tree[9]!="0") next - sp = tree[1] - tree=tree[-1] - tree = as.numeric(tree) - names(tree) = c("TrNum","TrCl","CrCl","Stus","DBH","Ht","Lang", - "Fang","Edia","Crd1","Cr1","CrD2","Cr2","CrD3","Cr3", - "CrD4","Cr4","Ex","Mk","Xloc","Yloc","Z") - tree = as.list(tree[c(2,3,4,5,6,7,8,10,11,20,21)]) - tree$sp = sp - ll = matrix(c(tree$Xloc,tree$Yloc,0),nrow=1) - tree$Xloc = ll[1,1] - tree$Yloc = ll[1,2] - drawn = svsTree(tree,treeform) - if (!is.null(drawn)) drawnTrees[[length(drawnTrees)+1]] = drawn -####TESTING if (calls > 60) break - } - progress$set(message = "Display trees",value = length(svs)+1) - displayTrees(drawnTrees) - progress$set(message = "Sending image to browser",value = length(svs)+2) - output[[id]] <- renderRglwidget(rglwidget(scene3d())) - # this code forces the scene to be loaded prior to calling the custom message - # and that is critical to getting all this to work. - callBack <- function() - { - session$sendCustomMessage(type="makeTopSideImages", - c(id,paste0(id,"Pers"),paste0(id,"Top"),paste0(id,"Side"))) - progress$close() - if (id=="SVSImg1") session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm1').show();$('#SVSdynIm1').show();")) else - session$sendCustomMessage(type="jsCode", - list(code= "$('#SVSstaIm2').show();$('#SVSdynIm2').show();")) - } - session$onFlushed(callBack, once = TRUE) - } - - ## SVSImgList1 - observe({ - if (length(input$SVSImgList1)) - { -cat ("Visualize SVSImgList1=",input$SVSImgList1," SVSdraw1=",input$SVSdraw1,"\n") - fn=input$SVSImgList1 - if (!file.exists(fn)) return() - # actual images are loaded into these two img items in the browser when CustomMessage makeTopSideImages is sent - output$SVSqImg1Pers <- renderUI(HTML('Perspective View')) - output$SVSqImg1Top <- renderUI(HTML('Top View')) - output$SVSqImg1Side <- renderUI(HTML('Side View')) - renderSVSImage('SVSImg1',fn, - subplots="subplots" %in% input$SVSdraw1,downTrees="downTrees" %in% input$SVSdraw1, - fireLine="fireLine" %in% input$SVSdraw1,rangePoles="rangePoles" %in% input$SVSdraw1, - plotColor=input$svsPlotColor1) - } - }) - - ## SVSImgList2 - observe({ - if (length(input$SVSImgList2)) - { -cat ("Visualize SVSImgList2=",input$SVSImgList2," SVSdraw1=",input$SVSdraw2,"\n") - fn=input$SVSImgList2 - if (!file.exists(fn)) return() - # actual images are loaded into these two img items in the browser when CustomMessage makeTopSideImages is sent - output$SVSqImg2Pers <- renderUI(HTML('Perspective View')) - output$SVSqImg2Top <- renderUI(HTML('Top View')) - output$SVSqImg2Side <- renderUI(HTML('Side View')) - renderSVSImage('SVSImg2',fn, - subplots="subplots" %in% input$SVSdraw2,downTrees="downTrees" %in% input$SVSdraw2, - fireLine="fireLine" %in% input$SVSdraw2,rangePoles="rangePoles" %in% input$SVSdraw2, - plotColor=input$svsPlotColor2) - } - }) - ## "View On Maps" processing - observe({ - if (input$topPan == "View On Maps") - { -cat ("View On Maps hit\n") - require(rgdal) - theRuns = try(dbGetQuery(dbGlb$dbOcon, - paste0("select distinct RunTitle, KeywordFile from FVS_Cases", - " order by RunDateTime desc"))) - if (class(theRuns)!="try-error" && nrow(theRuns)>0) - { - allRuns=theRuns[,2] - names(allRuns)=theRuns[,1] - updateSelectInput(session=session, inputId="mapDsRunList", - choices=allRuns) - } else updateSelectInput(session=session, inputId="mapDsRunList",choices=list()) - updateSelectInput(session=session, inputId="mapDsTable", choices=list()) - updateSelectInput(session=session, inputId="mapDsVar", choices=list()) - updateSelectInput(session=session, inputId="MapYear", choices=list()) - output$leafletMap = renderLeaflet(NULL) - output$leafletMessage=renderText(NULL) - } - }) - ## mapDsRunList - observe({ - if (length(input$mapDsRunList) && input$topPan == "View On Maps") - { -cat ("mapDsRunList input$mapDsRunList=",input$mapDsRunList,"\n") - cases = try(dbGetQuery(dbGlb$dbOcon, - paste0("select CaseID,StandID from FVS_Cases where KeywordFile = '", - input$mapDsRunList,"'"))) - if (class(cases)=="try-error") return() - # if there are reps (same stand more than once), just use the first rep, ignore the others - cases = cases[!duplicated(cases$StandID),] - dbExecute(dbGlb$dbOcon,"drop table if exists temp.mapsCases") - dbWriteTable(dbGlb$dbOcon,DBI::SQL("temp.mapsCases"),cases[,1,drop=FALSE]) - tabs = setdiff(myListTables(dbGlb$dbOcon), - c("CmpSummary","FVS_Cases","CmpSummary_East")) - tables = list() - for (tab in tabs) - { - tb <- dbGetQuery(dbGlb$dbOcon,paste0("PRAGMA table_info('",tab,"')")) - if (length(intersect(c("caseid","standid","year"),tolower(tb$name))) != 3) next - cnt = try(dbGetQuery(dbGlb$dbOcon,paste0("select count(*) from ",tab, - " where CaseID in (select CaseID from temp.mapsCases) limit 1"))) - if (class(cnt) == "try-error") next - if (cnt[1,1]) tables=append(tables,tab) - } - if (length(tables)) names(tables) = tables - updateSelectInput(session=session, inputId="mapDsTable", choices=tables, - selected=0) - updateSelectInput(session=session, inputId="mapDsVar", choices=list(), - selected=0) - output$leafletMap = renderLeaflet(NULL) - } - }) - ## mapDsTable - observe({ - if (length(input$mapDsTable)) - { - cat ("mapDsRunList input$mapDsTable=",input$mapDsTable,"\n") - vars = setdiff(dbListFields(dbGlb$dbOcon,input$mapDsTable), - c("CaseID","StandID","Year")) - sps = na.omit(match(c("SpeciesFVS","SpeciesPLANTS","SpeciesFIA"),vars)) - if (length(sps)==3) vars = vars[-sps] - vars = vars[! vars == "Characteristic"] - vars = as.list(vars) - names(vars) = vars - updateSelectInput(session=session, inputId="mapDsVar", choices=vars, - selected=0) - output$leafletMap = renderLeaflet(NULL) - } - }) - - ## mapDsVar - observe({ - if (length(input$mapDsVar) && !is.na(match(input$mapDsVar,setdiff( - dbListFields(dbGlb$dbOcon,input$mapDsTable), c("CaseID","StandID","Year"))))) - { -cat ("mapDsRunList input$mapDsTable=",isolate(input$mapDsTable), - " input$mapDsVar=",input$mapDsVar," input$mapDsType=",input$mapDsType,"\n") - # prepare display data - dispData = try(dbGetQuery(dbGlb$dbOcon,paste0("select * from ", - isolate(input$mapDsTable), - " where CaseID in (select CaseID from temp.mapsCases)"))) - if (class(dispData)=="try-error" || nrow(dispData)==0) return() - dispData = dispData[,-1] #remove CaseID - # if species is a variable, pick the one to display and ditch the others - sps = na.omit(match(c("SpeciesFVS","SpeciesPLANTS","SpeciesFIA"),names(dispData))) - if (length(sps)==3) - { - spk = match(paste0("Species",input$spCodes),names(dispData)) - names(dispData)[spk]="Species" - dispData = dispData[,-sps[sps!=spk]] - spk = "Species" - } else { spk = NULL } - keys = setdiff(colnames(dispData),c("StandID","Year","Characteristic",spk)) - for (var in keys) - { - if (class(dispData[,var]) == "character") - { - x = suppressWarnings(as.numeric(dispData[,var])) - if (!any(is.na(x))) dispData[,var] = x - } - } - dvs = intersect(names(dispData), - c("StandID","Year","Characteristic",spk,input$mapDsVar)) - isp = match("Species",dvs) - if (!is.na(isp) && isp != 3) dvs=c(dvs[1:2],"Species",dvs[-c(1,2,isp)]) - dispData = dispData[,dvs] - uidsToGet = unique(dispData$StandID) -cat ("length(uidsToGet)=",length(uidsToGet),"\n") - if (!length(uidsToGet)) return() - uidsFound = NULL - library(sf) - spatdat = "SpatialData.RData" - if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && - file.exists(spatdat)) load(spatdat,envir=dbGlb) - pts = NULL - ptsLbs = NULL - polys = NULL - if (exists("SpatialData",envir=dbGlb,inherit=FALSE)) - { - matchVar = attr(dbGlb$SpatialData,"MatchesStandID") -cat ("1 matchVar=",matchVar,"\n") - # when matchVar is NULL, it means that there is a list of maps that will be searched - # for the spatial data. If it is not null, then there is only one item, so use it. - mapList = if (is.null(matchVar)) dbGlb$SpatialData else list(d=dbGlb$SpatialData) - pts = NULL - polyLbs = NULL - ptsLbs = NULL - for (map in mapList) - { - if (!length(uidsToGet)) break - matchVar = attr(map,"MatchesStandID") -cat ("2 matchVar=",matchVar,"\n") - # if the map has class sp, it needs to be converted. This code was added in Nov 2022 - # and can be removed once all the map data is converted to package sf. Note that - # this code allows for some members of the SpatialData to be sf and others sp. - qsp = attr(class(map),"package") - if (!is.null(qsp) && qsp == "sp") map=st_as_sf(map) - uids=intersect(uidsToGet, map[[matchVar]]) - if (length(uids) == 0) next - uidsFound = c(uidsFound,uids) - pp = st_transform(map[match(uids,map[[matchVar]]),],st_crs("epsg:4326")) - if (length(grep("POLYGON",st_geometry_type(pp)[1]))) - { - polys = if (is.null(polys)) pp else rbind(polys,pp) - polyLbs= if (is.null(polyLbs)) uids else rbind(polyLbs,uids) - } - if (length(grep("POINT",st_geometry_type(pp)[1]))) - { - pts = if (is.null(pts)) pp else rbind(pts,pp) - ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) - } - uidsToGet = setdiff(uidsToGet,uids) - } - } -cat ("left to get: length(uidsToGet)=",length(uidsToGet), - " number found: length(uidsFound)=",length(uidsFound),"\n") - if (length(uidsToGet)) - { - isolate({ - if (globals$fvsRun$uuid == input$mapDsRunList) - inInit = globals$fvsRun$refreshDB else - { - saveFvsRun=loadFVSRun(dbGlb$prjDB,input$mapDsRunList) - if (!is.null(saveFvsRun)) - { - inInit = saveFvsRun$refreshDB - rm(saveFvsRun) - } else inInit=NULL - } - }) - if (is.null(inInit)) inInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") -cat ("mapDsRunList trying to use the table=",inInit,"\n") - dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.uidsToGet"),data.frame(stds=uidsToGet),overwrite=TRUE) - sid = if (inInit %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) - "StandPlot_ID" else "Stand_ID" - qry = paste0("select distinct ",sid," as Stand_ID,Latitude,Longitude from ",inInit, - " where ",sid," in (select * from temp.uidsToGet)") - latLng = try(dbGetQuery(dbGlb$dbIcon,qry)) - dbExecute(dbGlb$dbIcon,"drop table if exists temp.uidsToGet") - if (class(latLng)!="try-error" && nrow(latLng)) - { - idxLng = grep("Longitude",names(latLng),ignore.case=TRUE) - idxLat = grep("Latitude",names(latLng),ignore.case=TRUE) -cat ("mapDsRunList idxLng=",idxLng," idxLat=",idxLat," names=",names(dbGlb$SpatialData),"\n") - if (length(idxLng) && length(idxLat)) - { - latLng[,idxLng] = as.numeric(latLng[,idxLng]) - latLng[,idxLat] = as.numeric(latLng[,idxLat]) - latLng = na.omit(latLng) - } else latLng = NULL - } else latLng = NULL - if (is.null(latLng) || nrow(latLng) == 0) - { -cat ("mapDsRunList trying PlotInit\n") - inInit = getTableName(dbGlb$dbIcon,"FVS_PlotInit") - if (!is.null(inInit)) - { - latLng = try(dbGetQuery(dbGlb$dbIcon, - paste0("select Stand_ID,avg(Latitude) as Latitude, ", - "avg(Longitude) as Longitude from ",inInit, - " group by Stand_ID;"))) - if (class(latLng)!="try-error") - { - latLng$Longitude = as.numeric(latLng$Longitude) - latLng$Latitude = as.numeric(latLng$Latitude) - latLng = na.omit(latLng) - if (nrow(latLng) > 0) latLng = subset(latLng, Latitude != 0 & Longitude != 0) - } else latLng = NULL - } else latlng = NULL - } - if (!is.null(latLng) && nrow(latLng)>0) - { -cat ("mapDsRunList names(latLng)=",names(latLng)," class(latLng)=",class(latLng),"\n") - idxLng = grep("Longitude",names(latLng),ignore.case=TRUE) - idxLat = grep("Latitude",names(latLng),ignore.case=TRUE) - idxID = grep("Stand_ID",names(latLng),ignore.case=TRUE) -cat (" idxLng=",idxLng," idxLat=",idxLat," idxID=",idxID,"\n") - latLng = latLng[,c(idxID,idxLng,idxLat)] - names(latLng)=c("Stand_ID","Longitude","Latitude") - keep = na.omit(match(uidsToGet,latLng[,"Stand_ID"])) -cat ("rows to keep=",length(keep),"\n") - if (length(keep)) - { - latLng[,"Longitude"] = ifelse(latLng[,"Longitude"]>0, - -latLng[,"Longitude"], latLng[,"Longitude"]) - latLng = latLng[keep,,drop=FALSE] - uniq = unique(latLng[,2:3]) - if (nrow(uniq) < nrow(latLng)) - { - newlatLng = NULL - for (row in 1:nrow(uniq)) - { - sub=subset(latLng,latLng[,2]==uniq[row,1] & latLng[,3]==uniq[row,2]) - if (nrow(sub) > 1) - { - sub = sub[order(sub[,1]),] - delta=nrow(sub)/2*5 - sub[,3] = sub[,3]+seq(-delta,delta,5)[1:nrow(sub)]*.00005 - } - newlatLng = rbind(newlatLng,sub) - } - latLng = newlatLng - } - uids = latLng[,"Stand_ID"] - uidsFound = c(uidsFound,uids) - latLng = st_as_sf(latLng, coords = c("Longitude","Latitude")) - latLng <- try(st_set_crs(latLng, - st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))) - if ("try-error" %in% class(latLng)) - { - output$leafletMessage=renderText("Error setting projection in location data.") - return() - } - pp = st_transform(latLng,st_crs("epsg:4326")) - pts= if (is.null(pts)) pp else rbind(pts,pp) - ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) - } - } - } - if (!length(uidsFound)) - { - output$leafletMessage=renderText("Couldn't find the stands in the spatial data") - return() - } - progress <- shiny::Progress$new(session,min=1,max=length(uidsFound)) - labs = list() - url = paste0(session$clientData$url_protocol,"//", - session$clientData$url_hostname, - session$clientData$url_pathname) - for (sid in uidsFound) - { - tab = subset(dispData,StandID == sid)[,-1] - labs[[length(labs)+1]] = - if (input$mapDsType == "table") - { - HTML(paste0('

StandID=',sid,df2html(tab))) - } else { - pvar = input$mapDsVar[1] - tab = subset(dispData,StandID == sid)[,intersect(names(dispData),c("Year","Species",pvar))] - pfile=paste0("www/s",sid,".png") -cat ("pfile=",pfile," nrow=",nrow(tab)," sid=",sid,"\n") - CairoPNG(file=pfile,height=1.7,width=2.3,units="in",res=100,bg = "transparent") - if (length(intersect(c("Species","Characteristic"),names(tab))) || - length(table(tab$Year)) == 1) tab$Year = as.factor(tab$Year) - p = ggplot(tab,aes_string(x="Year",y=pvar)) + geom_point() + theme( - legend.position="none", - text=element_text(size=8),axis.text=element_text(face="bold"), - panel.background=element_rect(fill=grDevices::rgb(1, 1, 1, .2, maxColorValue = 1)), - plot.background =element_rect(fill=grDevices::rgb(1, 1, 1, .5, maxColorValue = 1))) - if (!is.factor(tab$Year)) p = p+geom_line() - print(p) - dev.off() - url = paste0(session$clientData$url_protocol,"//", - session$clientData$url_hostname, - session$clientData$url_pathname) - pfile=if (isLocal()) paste0("/www/s",sid,".png") else - paste0(url,"www/s",sid,".png") - HTML(paste0('',sid,'')) - } - progress$set(message = paste0("Preparing ",sid), value = length(labs)) - } - progress$close() - map = leaflet() %>% addTiles() %>% - addTiles(urlTemplate = - paste0("https://mts1.google.com/vt/lyrs=",input$mapDsProvider, - "&hl=en&src=app&x={x}&y={y}&z={z}&s=G"),attribution = 'Google') - lops = labelOptions(opacity=.7) - pops = popupOptions(maxWidth = 2000,autoClose=FALSE,closeButton=TRUE,closeOnClick=FALSE,textOnly=TRUE) - if (length(pts)) - { - lbidx = match(ptsLbs,uidsFound) - map = map %>% addCircleMarkers(data=pts, radius = 6, color="#FFFF00", - stroke = FALSE, fillOpacity = 0.5, popup=labs[lbidx], - popupOptions = pops, label=labs[lbidx], labelOptions = lops) - } - if (length(polys)) - { - lbidx = match(polyLbs,uidsFound) - map = map %>% addPolygons(data=polys, color = "#FFFF00", - weight = 3, smoothFactor = 0.1, opacity = .3, fillOpacity = 0.2, - popup=labs[lbidx], popupOptions = pops, label=labs[lbidx], - labelOptions = lops, - highlightOptions = c(weight = 5, color = "#666", dashArray = NULL, - fillOpacity = 0.3, opacity = .6, bringToFront = TRUE)) - } - output$leafletMap = renderLeaflet(map) - } - }) - - ## Tools, related to Copy - observe({ - if (input$toolsPan == "Copy projects") - { - backups = dir (pattern="ProjectBackup") - if (length(backups)) - { - backups = sort(backups,decreasing=TRUE) - names(backups) = backups - } else backups=list() - updateSelectInput(session=session, inputId="pickBackup", - choices = backups, selected=NULL) - } - }) - - - ## deleteRun - observe({ - if(input$deleteRun > 0) - { - isolate({ - tit = globals$fvsRun$title - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "deleteRunDlg", - message = paste0('Delete run "', - globals$fvsRun$title,'" (and all related outputs)?'))) - }) - } - }) - observe({ - if (input$deleteRunDlgBtn > 0) - { - isolate({ -cat ("delete run",globals$fvsRun$title," uuid=",globals$fvsRun$uuid, - " runSel=",input$runSel,"lenRuns=",length(globals$FVS_Runs),"\n") - killIfRunning(globals$fvsRun$uuid) - removeFVSRunFiles(globals$fvsRun$uuid,all=TRUE) - deleteRelatedDBRows(globals$fvsRun$uuid,dbGlb$dbOcon) - removeFVSRun(dbGlb$prjDB,input$runSel) - if (file.exists("projectId.txt")) - { - prjid = scan("projectId.txt",what="",sep="\n",quiet=TRUE) - write(file="projectId.txt",prjid) - } - globals$saveOnExit = FALSE - globals$reloadAppIsSet=1 - session$reload() - }) - } - }) - - ## deleteAllOutputs - observe({ - if(input$deleteAllOutputs > 0) - { - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "deleteAllOutputsDlg", - message = "Delete all outputs?")) - } - }) - observe({ - if (input$deleteAllOutputsDlgBtn == 0) return() - isolate({ -cat ("delete all outputs\n") - dbGlb$dbOcon <- dbDisconnect(dbGlb$dbOcon ) - unlink("FVSOut.db") - for (uuid in globals$FVS_Runs) removeFVSRunFiles(uuid) - dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),"FVSOut.db") - }) - }) - - ## deleteAllRuns - observe({ - if(input$deleteAllRuns > 0) - { - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "deleteAllRunsDlg", - message = "Delete all runs and outputs?")) - } - }) - observe({ - if (input$deleteAllRunsDlgBtn == 0) return() - isolate({ -cat ("delete all runs and outputs\n") - rmfiles=dir(pattern="[.]pidStatus$") - for (tokill in rmfiles) killIfRunning(sub(".pidStatus","",tokill)) - dbGlb$dbOcon <- dbDisconnect(dbGlb$dbOcon) - unlink("FVSOut.db") - globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) - for (uuid in globals$FVS_Runs) - { - removeFVSRunFiles(uuid,all=TRUE) - removeFVSRun(dbGlb$prjDB,uuid) - } - globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) - dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),"FVSOut.db") - globals$saveOnExit = FALSE - globals$reloadAppIsSet=1 - session$reload() - }) - }) - - ## delZipBackup - observe({ - if(input$delZipBackup > 0) - { - fl = isolate(input$pickBackup) - if (is.null(fl)) return() - if (file.exists(fl)) - { - unlink(fl) - backups = dir (pattern="ProjectBackup") - if (length(backups)) - { - backups = sort(backups,decreasing=TRUE) - names(backups) = backups - } else backups=list() - updateSelectInput(session=session, inputId="pickBackup", - choices = backups, selected=NULL) - } - } - }) - - - ## mkZipBackup - observe({ - if(input$mkZipBackup > 0) - { - flst=dir() - del = grep("^ProjectBackup",flst) - if (length(del)) flst = flst[-del] - del = grep("^www",flst) - if (length(del)) flst = flst[-del] - del = grep("^projectIsLocked",flst) - if (length(del)) flst = flst[-del] - delFVSbin = grep ("^FVSbin",flst) - if (length(delFVSbin)) flst = flst[-delFVSbin] - createdFVSbin=FALSE - if (isolate(input$prjBckCnts)=="projFVS") - { - if (globals$fvsBin != "FVSbin") - { - if (!dir.exists("FVSbin")) dir.create("FVSbin") - fvsPgms = list.files(fvsBin,pattern=paste0(.Platform$dynlib.ext,"$"), - full.names=TRUE) - file.copy(fvsPgms,"FVSbin") - createdFVSbin=TRUE - } - fvsPgms = list.files("FVSbin",pattern=paste0(.Platform$dynlib.ext,"$")) - fvsPgms = paste0("FVSbin","/",fvsPgms) - flst = c(flst,fvsPgms) - } - zfile=paste0("ProjectBackup_",format(Sys.time(),"%Y-%m-%d_%H_%M_%S"),".zip") - # close the input and output databases if they are openned - ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) - icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) - if (ocon) dbDisconnect(dbGlb$dbOcon) - if (icon) dbDisconnect(dbGlb$dbIcon) - progress <- shiny::Progress$new(session,min=1,max=length(flst)) - for (i in 1:length(flst)) - { - x = flst[i] - progress$set(message = paste0("Adding ",x," to ",zfile), value = i) - rtn=if (file.exists(zfile)) try(zipr_append(zfile,x)) else try(zipr(zfile,x)) - if (class(rtn)=="try-error") - { - progress$set(message = paste0("Failed to add ",x," to ",zfile), value = i+1) - Sys.sleep(.2) - } - } - if (createdFVSbin) unlink("FVSbin") - if (ocon) dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbOcon@dbname) - if (icon) dbGlb$dbIcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbIcon@dbname) - Sys.sleep(.2) - progress$close() - backups = dir (pattern="ProjectBackup") - if (length(backups)) - { - backups = sort(backups,decreasing=TRUE) - names(backups) = backups - } else backups=list() - updateSelectInput(session=session, inputId="pickBackup", - choices = backups, selected=NULL) - } - }) - - ## Upload Project Backup--upZipBackup - observe({ - if (!isLocal()) return() - if (is.null(input$upZipBackup)) return() - prjBackupUpload = input$upZipBackup$name -cat ("prjBackupUpload=",prjBackupUpload,"\n") - progress <- shiny::Progress$new(session,min=1,max=5) - progress$set(message = "Begining project backup upload",value = 2) - ind <- grep("ProjectBackup_",prjBackupUpload) - fext <- tools::file_ext(basename(input$upZipBackup$name)) - if (!length(ind) && fext !="zip") - { - output$delPrjActionMsg = renderText("Uploaded file is not a valid project backup zip file") - unlink(input$upZipBackup$datapath) - progress$close() - return() - } - fdir = dirname(input$upZipBackup$datapath) - progress$set(message = "Copying project backup to current project directory",value = 4) - file.copy(input$upZipBackup$datapath,prjBackupUpload) - backups = dir(pattern="ProjectBackup") - if (length(backups)) - { - backups = sort(backups,decreasing=TRUE) - names(backups) = backups - updateSelectInput(session=session, inputId="pickBackup", - choices = backups, selected=backups[length(backups)]) - } else updateSelectInput(session=session, inputId="pickBackup", - choices = list(), selected=NULL) - output$delPrjActionMsg = renderText("Project backup added to above list of backups to process") - progress$close() - }) - - ## restorePrjBackup - observeEvent(input$restorePrjBackup, - { - if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() - cnts = zip_list(input$pickBackup) - if (length(cnts)==0) return() - if(length(grep("FVSbin",cnts$filename)) || length(grep("^FVS[a-z]*.so$",cnts$filename)) || - length(grep("^FVS[a-z]*.dll$",cnts$filename))) - { - output$btnA <-renderUI(HTML("Project files only")) - output$btnB <-renderUI(HTML("Project files and FVS software")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#restorePrjBackupDlgBtnC').show()")) - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "restorePrjBackupDlg", - message = paste0("WARNING: restoring this project backup will overwrite", - " any existing project files in this current project. If you don't", - " want to lose existing project files, consider restoring to a new empty", - " project instead. This backup also contains FVS software that will", - " overwrite your currently installed version with the software in the", - " backup, if selected. What contents would you like to restore?"))) - globals$prjFilesOnly = FALSE - } else { - output$btnA <- renderUI(HTML("Yes")) - output$btnB <-renderUI(HTML("No")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#restorePrjBackupDlgBtnC').hide()")) - globals$prjFilesOnly = TRUE - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "restorePrjBackupDlg", - message = paste0("WARNING: restoring this project backup will overwrite", - " any existing project files in this current project. If you don't", - " want to lose existing project files, consider restoring to a new", - " empty project instead. Are you sure?"))) - } - }) - - observeEvent(input$restorePrjBackupDlgBtnA,{ - isolate({ - if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() - progress <- shiny::Progress$new(session,min=1,max=5) - progress$set(message = "Unzipping project backup",value = 2) - fvsWorkBackup = input$pickBackup -cat ("restorePrjBackupDlgBtB fvsWorkBackup=",fvsWorkBackup,"\n") - if (file.exists(fvsWorkBackup)) - { - progress$set(message = "Checking backup contents",value = 3) - ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) - icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) - if (ocon) dbDisconnect(dbGlb$dbOcon) - if (icon) dbDisconnect(dbGlb$dbIcon) - td <- tempdir() - rtn = try(unzip (paste0(getwd(),"/",fvsWorkBackup),exdir=td, - overwrite=TRUE,junkpaths=FALSE)) - if (class(rtn)=="try-error") return() - zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) - del=NULL - for (todel in c("^www","^rFVS","R$",".html$",".zip$","treeforms.RData", - "^FVSbin","prms.RData",".log$")) del = c(del,grep (todel,zipConts)) - if (length(del)) lapply(paste0(td,"/",zipConts[del]),unlink,recursive=TRUE) - pgms=if(.Platform$OS.type == "windows") dir(td,pattern="^FVS[a-z]*.dll$") else dir(td,pattern="^FVS[a-z]*.so$") - if (length(pgms)) lapply(paste0(td,"/",pgms),unlink,recursive=TRUE) - curcnts=dir() - tokeep = grep("^ProjectBackup",curcnts) - tokeep = c(tokeep,grep("^projectId",curcnts)) - curcnts = curcnts[tokeep] - lapply(paste0(td,"/",curcnts),unlink,recursive=TRUE) - progress$set(message = "Copying backup contents",value = 4) - zipConts <- dir(td,recursive=TRUE) - lapply(zipConts,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) - unlink(td,recursive=TRUE) - } - if (ocon) dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbOcon@dbname) - if (icon) dbGlb$dbIcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbIcon@dbname) - globals$reloadAppIsSet=1 - globals$saveOnExit=FALSE - progress$close() - session$reload() - }) - }) - - observeEvent(input$restorePrjBackupDlgBtnB,{ - isolate({ - if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() - if(globals$prjFilesOnly){ - globals$prjFilesOnly = FALSE - return() - } - progress <- shiny::Progress$new(session,min=1,max=5) - progress$set(message = "Unzipping project backup",value = 2) - fvsWorkBackup = input$pickBackup -cat ("restorePrjBackupDlgBtnA fvsWorkBackup=",fvsWorkBackup,"\n") - if (file.exists(fvsWorkBackup)) - { - progress$set(message = "Checking backup contents",value = 3) - ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) - icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) - if (ocon) dbDisconnect(dbGlb$dbOcon) - if (icon) dbDisconnect(dbGlb$dbIcon) - curdir=getwd() - td <- paste0(tempdir(),"/pbk") - suppressWarnings(dir.create(td)) - setwd(td) - lapply(dir(),function(x) unlink(x,recursive=TRUE,force=TRUE)) - rtn = try(unzip (paste0(curdir,"/",fvsWorkBackup),exdir=td, - overwrite=TRUE,junkpaths=FALSE)) - if (class(rtn)=="try-error") return() - zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) - del=NULL - # TODO: most of this list is related to old versions the software (pre "package") - # and can be reviewed (many dropped) in the future, say 2024 or so. - for (todel in c("^www","^rFVS","R$",".html$",".zip$","treeforms.RData", - "prms.RData",".log$","FVS_Data.db.default","FVS_Data.db.empty", - "databaseDescription.xlsx","projectIsLocked.txt",".png$", - "SpatialData.RData.default" )) del = c(del,grep (todel,zipConts)) - if (length(del)) lapply(paste0(td,"/",zipConts[del]),unlink,recursive=TRUE) - mkFVSProjectDB() - zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) - pgms=if(.Platform$OS.type == "windows") dir(td,pattern="^FVS[a-z]*.dll$") else dir(td,pattern="^FVS[a-z]*.so$") - if (length(pgms)) - { - frompgms=paste0(td,"/",pgms) - todir=paste0(td,"/FVSbin") - dir.create(todir) - topgms=paste0(todir,"/",pgms) - file.rename(from=frompgms,to=topgms) - } - setwd(curdir) - curcnts=dir() - tokeep = grep("^ProjectBackup",curcnts) - tokeep = c(tokeep,grep("^projectId",curcnts)) - curcnts = curcnts[tokeep] - lapply(paste0(td,"/",curcnts),unlink,recursive=TRUE) - if (globals$fvsBin != "FVSbin" && length(topgms)) - { - progress$set(message = "Copying backup contents",value = 4) - zipContsFVS <- dir(paste0(td,"/FVSbin"),pattern="^FVS[a-z]*.dll$") - zipContsPrj <- zipConts[-(match(zipContsFVS,zipConts))] - lapply(zipContsFVS,function(x,td) file.copy(from=paste0(td,"/FVSbin/",x),to=globals$fvsBin,overwrite=TRUE),td) - lapply(zipContsPrj,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) - } else { - progress$set(message = "Copying backup contents",value = 4) - dir.create("FVSbin") - zipConts <- dir(td,recursive=TRUE) - lapply(zipConts,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) - } - unlink(td,recursive=TRUE) - } - globals$reloadAppIsSet=1 - globals$saveOnExit=FALSE - progress$close() - session$reload() - }) - }) - - observeEvent(input$restorePrjBackupDlgBtnC, - updateSelectInput(session=session, inputId="pickBackup", selected=NULL) - ) - - - ## PrjDelete - observe({ - if(input$PrjDelete > 0) - { - isolate({ - if (is.null(input$PrjDelSelect)) - { - output$delPrjActionMsg <- renderUI(HTML("No project selected.")) - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "PrjDeleteDlg", message= - paste0('Select a project to delete, press Yes or No to continue.'))) - } else { -cat ("PrjDelete, input$PrjDelSelect=",input$PrjDelSelect,"\n") - prjList=getProjectList() - nm = names(prjList)[charmatch(input$PrjDelSelect,prjList)] - output$delPrjActionMsg <- NULL - msg = if(length(grep("ProjectBackup_",dir("../",input$PrjDelSelect)))) - " contains project backups within it that you may want to download first. " else "" - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "PrjDeleteDlg", message = - paste0(nm,msg,"Are you sure you still want to delete this project?"))) - } - }) - } - }) - observe({ - if (input$PrjDeleteDlgBtn > 0) - { -cat("delete project button.") - isolate({ - if (is.null(input$PrjDelSelect)) - { - output$delPrjActionMsg <- renderUI(HTML("No project selected.")) - } else { - delPrj=paste0("../",input$PrjDelSelect) - if (file.exists(paste0(delPrj,"/projectIsLocked.txt"))) - { - output$delPrjActionMsg <- renderUI(HTML("Cannot delete a locked project.")) - } else { - if (nchar(delPrj)<4 || !dir.exists(delPrj)) - { - output$delPrjActionMsg <- renderUI(HTML("Project directory not found.")) - } else { - unlink(delPrj, recursive=TRUE) - output$delPrjActionMsg <- renderUI(HTML("Project deleted")) - updateProjectSelections() - } - } - } - }) - } - }) - - ## topHelp - observe({ - if (input$topPan == "Help") - { - if (! exists("fvshelp")) data(fvsOnlineHelpRender) - if (! exists("fvshelp")) fvshelp="

No help is available

" - output$uiHelpText <- renderUI(HTML(fvshelp)) - } - }) - - ## df2html - df2html <- function(sdat=NULL) - { - if (is.null(sdat) || nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - sdat[sdat == " "]=NA - html = paste0('") - for (i in 1:nrow(sdat)) - { - tbrow=unlist(lapply(sdat[i,],function (x) if (is.character(x)) x else format(x,digits=3))) - html = paste0(html,"") - } - paste0(html,"
', - paste0(colnames(sdat),collapse=''),"
",paste0(tbrow,collapse=""),"
") - } - - ## xlsx2html - xlsx2html <- function(tab=NULL,xlsxfile=NULL,cols=NULL,addLink=FALSE) - { - if (is.null(xlsxfile) || !file.exists(xlsxfile)) return(NULL) - cleanlines=function(line) - { - line=gsub(pattern="\n",replacement="",x=line,fixed=TRUE) - gsub(pattern="\r",replacement="",x=line,fixed=TRUE) - } - if (!file.exists(xlsxfile) || is.null(tab)) return(NULL) - if (tab %in% getSheetNames(xlsxfile)) - { - sdat = try(read.xlsx(xlsxFile=xlsxfile,sheet=tab)) - if (class(sdat) == "try-error") return (NULL) - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - if (!is.null(cols) && max(cols)<=ncol(sdat)) sdat = sdat[,cols] - sdat[sdat == " "]=NA - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - sdat = sdat[,!apply(sdat,2,function(x) all(is.na(x)))] - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - sdat = sdat[ !apply(sdat,1,function(x) all(is.na(x))),] - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - html = paste0("",tab,"") - html = paste0(html,'

") - for (i in 1:nrow(sdat)) - { - tbrow=cleanlines(as.character(sdat[i,])) - if (addLink) tbrow[1] = paste0('',tbrow[1],'') - html = paste0(html,"") - } - html = paste0(html,"
', - paste0(cleanlines(colnames(sdat)),collapse=""),"
",paste0(tbrow,collapse=""),"

") - return (html) - } else return (NULL) - } - - ## mkTableDescription - mkTableDescription <- function (tab) - { - html = NULL - xlsxfile=system.file("extdata", "databaseDescription.xlsx", package="fvsOL") - if (!is.null(tab) && nchar(tab)>0 && !is.null(xlsxfile) && file.exists(xlsxfile)) - { - sheets = sort(getSheetNames(xlsxfile), decreasing=FALSE) - if ("OutputTableDescriptions" %in% sheets) - { - tabs = read.xlsx(xlsxFile=xlsxfile,sheet="OutputTableDescriptions") - row = charmatch(toupper(tab),toupper(tabs[,1])) - html = paste0("",tab," ",tabs[row,2]) - mhtml = xlsx2html(tab,xlsxfile=xlsxfile,cols=c(1,4)) - if (!is.null(mhtml)) html = paste0(html,mhtml) - } - if ("GuideLinks" %in% sheets) - { - tabs = read.xlsx(xlsxFile=xlsxfile,sheet="GuideLinks") - row = charmatch(toupper(tab),toupper(tabs[,1])) - if(!is.null(html))html = paste0(html,"

Link to reference document for table ",tabs[row,1],"

") - } - } - HTML(html) - } - ## tabDescSel - observe({ - tab = input$tabDescSel -cat ("tabDescSel, tab=",tab,"\n") - output$tabDesc <- renderUI(mkTableDescription(tab)) - }) - ## tabDescSel2 - observe({ - tab = input$tabDescSel2 -cat ("tabDescSel2, tab=",tab,"\n") - output$tabDesc2 <- renderUI(mkTableDescription(tab)) - }) - - ## uploadData button - observe({ - if (input$uploadData > 0) - { - updateTabsetPanel(session=session, inputId="topPan", - selected="Manage Projects") - updateTabsetPanel(session=session, inputId="toolsPan", - selected="Import input data") - updateTabsetPanel(session=session, inputId="inputDBPan", - selected="Upload inventory data") - } - }) - - ## data upload code - observe({ - if(input$toolsPan == "Import input data") - { - updateTabsetPanel(session=session, inputId="inputDBPan", - selected="Upload inventory data") - output$step1ActionMsg <- NULL - output$step2ActionMsg <- NULL - } - }) - observe({ - if(input$inputDBPan == "Upload inventory data") - { -cat ("Upload inventory data\n") - output$step1ActionMsg <- NULL - output$step2ActionMsg <- NULL - } - }) - - ## initNewInputDB - initNewInputDB <- function (session,output,dbGlb) - { - updateSelectInput(session=session, inputId="editSelDBtabs", choices=list()) - updateSelectInput(session=session, inputId="editSelDBvars", choices=list()) - updateSelectInput(session=session, inputId="inVars", choices=list()) - updateSelectInput(session=session, inputId="Groups", choices=list()) - updateSelectInput(session=session, inputId="Stands", choices=list()) - output$tbl <- renderRHandsontable(NULL) - output$stdSel <- output$navRows <- renderUI(NULL) - dbGlb$rows <- NULL - dbGlb$rowSelOn <- dbGlb$navsOn <- FALSE - resetActiveFVS(globals) - } - - ## installDefaultData - installDefaultData <- function(empty=FALSE) - { - dbDisconnect(dbGlb$dbIcon) - if (empty) - { - frm=system.file("extdata", "FVS_Data.db.empty", package="fvsOL") - file.copy(frm,"FVS_Data.db",overwrite=TRUE) - unlink("SpatialData.RData") - } else { - frm=system.file("extdata", "FVS_Data.db.default", package="fvsOL") - file.copy(frm,"FVS_Data.db",overwrite=TRUE) - frm=system.file("extdata", "SpatialData.RData.default",ppackage="fvsOL") - file.copy(frm,"SpatialData.RData",overwrite=TRUE) - } - dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") - initNewInputDB(session,output,dbGlb) - loadStandTableData(globals, dbGlb$dbIcon) - updateStandTableSelection(session,input,globals) - loadVarData(globals,input,dbGlb$dbIcon) - updateVarSelection(globals,session,input) - } - ## installTrainDB - observe({ - if (input$installTrainDB == 0) return() - installDefaultData() - output$step1ActionMsg <- NULL - output$step2ActionMsg <- output$mapActionMsg <- renderText(HTML(paste0("Training database installed", - " (the inventory data and the related spatial data)."))) - }) - ## installTrainDB2 - observe({ - if (input$installTrainDB2 == 0) return() - installDefaultData() - output$mapActionMsg <- renderText(HTML(paste0("Training database installed", - " (the inventory data and the related spatial data)."))) - }) - ## installEmptyDB - observe({ - if (input$installEmptyDB == 0) return() - installDefaultData(empty=TRUE) - output$step1ActionMsg <- NULL - output$step2ActionMsg <- renderText(HTML("Empty database installed and spatial data deleted.")) - dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") - }) - ## Upload new database - observe({ - if (is.null(input$uploadNewDB)) return() - output$step1ActionMsg <- NULL - output$step2ActionMsg <- NULL - fext = tools::file_ext(basename(input$uploadNewDB$name)) -cat ("fext=",fext,"\n") - session$sendCustomMessage(type="jsCode", - list(code= "$('#input$installNewDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#input$addNewDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installTrainDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installEmptyDB').prop('disabled',true)")) - if (! (fext %in% c("accdb","mdb","db","sqlite","xlsx","zip"))) - { - output$step1ActionMsg = renderText("Uploaded file is not suitable database types described in Step 1.") - unlink(input$uploadNewDB$datapath) - return() - } else { - session$sendCustomMessage(type="jsCode", - list(code= "$('#installNewDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#addNewDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installTrainDB').prop('disabled',true)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installEmptyDB').prop('disabled',true)")) - } - fdir = dirname(input$uploadNewDB$datapath) - progress <- shiny::Progress$new(session,min=1,max=20) - if (fext == "zip") - { - progress$set(message = "Unzip data", value = 1) - unzip(input$uploadNewDB$datapath, junkpaths = TRUE, exdir = fdir) - unlink(input$uploadNewDB$datapath) - fname = dir(dirname(input$uploadNewDB$datapath)) - if (length(fname)>1) - { - output$step1ActionMsg = renderText(".zip contains more than one file.") - lapply (dir(dirname(input$uploadNewDB$datapath),full.names=TRUE),unlink) - progress$close() - return() - } else if (length(fname) == 0) { - output$actionMsg = renderText(".zip was empty.") - progress$close() - return() - } - fext = tools::file_ext(fname) - if (! (fext %in% c("accdb","mdb","db","sqlite","xlsx"))) - { - output$step1ActionMsg = renderText(".zip did not contain one of the suitable file types described in Step 1.") - lapply (dir(dirname(input$uploadNewDB$datapath),full.names=TRUE),unlink) - progress$close() - return() - } - } else fname = basename(input$uploadNewDB$datapath) -cat ("fext=",fext," fname=",fname," fdir=",fdir,"\n") - curDir=getwd() - setwd(fdir) - if (fext %in% c("accdb","mdb")) - { - progress$set(message = "Process schema", value = 2) -cat("curDir=",curDir," input dir=",getwd(),"\n") - pgm = if (exists("mdbToolsDir")) file.path(normalizePath(mdbToolsDir),"mdb-schema") else "mdb-schema" - if (.Platform$OS.type == "windows") pgm=paste0(pgm,".exe") - cmd = paste0(pgm," ",fname) -cat ("cmd=",cmd,"\n") - schema = if (.Platform$OS.type == "windows") try(shell(cmd,intern=TRUE)) else - try(system(cmd,intern=TRUE)) - if (class(schema)=="try-error" || !exists("schema") || length(schema) < 2 || schema[1] =="Unknown Jet version.") - { - setwd(curDir) - progress$close() - if (schema[1] =="Unknown Jet version.") output$step1ActionMsg = renderText("Unknown Jet version. Possible corrupt database.") else - output$step1ActionMsg = renderText("Error when attempting to extract data from Access database.") - session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") - return() - } - tbls = grep ("CREATE TABLE",schema,ignore.case=TRUE) - schema = schema[tbls[1]:length(schema)] - schema = gsub("\t"," ",schema,fixed=TRUE) - schema = gsub("[","]",schema,fixed=TRUE) - tbls = grep ("CREATE TABLE",schema,ignore.case=TRUE) - tbln=unlist(lapply(schema[tbls],function(x) if (length(grep("]",x,fixed=TRUE))) - scan(text=x,what="character",sep="]",quiet=TRUE)[2] else - scan(text=x,what="character",quiet=TRUE)[3])) - schema = gsub(" Long Integer"," Integer",schema,ignore.case=TRUE) - schema = gsub(" Int"," Integer",schema,ignore.case=TRUE) - schema = gsub(" Integereger"," Integer",schema,ignore.case=TRUE) - schema = gsub(" Memo.*)"," Text",schema,ignore.case=TRUE) - schema = gsub(" Memo"," Text",schema,ignore.case=TRUE) - schema = gsub(" Text.*)"," Text",schema,ignore.case=TRUE) - schema = gsub(" Double"," Real",schema,ignore.case=TRUE) - schema = gsub(" SHORT_DATE_TIME,"," Text,",schema,ignore.case=TRUE) - schema = gsub(" FLOAT,"," Real,",schema,ignore.case=TRUE) - schema = gsub(" NOT NULL"," ",schema,,ignore.case=TRUE) - schema = gsub(" Single"," Real",schema) - schema = gsub("]",'"',schema,fixed=TRUE) - cat ("begin;\n",file="sqlite3.import") - cat (paste0(schema,"\n"),file="sqlite3.import",append=TRUE) - cat ("commit;\n",file="sqlite3.import",append=TRUE) - progress$set(message = "Extract data", value = 3) - if(!length(grep("FVS_StandInit",tbln,ignore.case=TRUE))){ - setwd(curDir) - progress$close() - output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") - session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") - return() - } - pgm = if (exists("mdbToolsDir")) file.path(normalizePath(mdbToolsDir),"mdb-export") else "mdb-export" - if (.Platform$OS.type == "windows") pgm=paste0(pgm,".exe") - for (tab in tbln) - { - progress$set(message = paste0("Export table ",tab), value = 3) - cat ("begin;\n",file="sqlite3.import",append=TRUE) - cmd = paste0 (pgm," -I sqlite ",fname," ",tab," >> sqlite3.import") - cat ("cmd=",cmd,"\n") - result = if (.Platform$OS.type == "windows") shell(cmd,intern=TRUE) else system(cmd,intern=TRUE) - cat ("commit;\n",file="sqlite3.import",append=TRUE) - } - cat (".quit\n",file="sqlite3.import",append=TRUE) - progress$set(message = "Import data to Sqlite3", value = 4) - pgm = if (exists("sqlite3exe")) sqlite3exe else "sqlite3" - cmd = paste0(pgm," FVS_Data.db < sqlite3.import") -cat ("cmd=",cmd,"\n") - if (.Platform$OS.type == "windows") shell(cmd) else system(cmd) -cat ("cmd done.\n") - dbo = dbConnect(dbDrv,"FVS_Data.db") - } else if (fext == "xlsx") - { - progress$set(message = "Get data sheets", value = 3) - sheets = getSheetNames(fname) - sheetsU <- toupper(sheets) - if(!length(grep("FVS_STANDINIT",sheetsU))) - { - setwd(curDir) - progress$close() - output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") - session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") - return() - } - normNames = c("FVS_GroupAddFilesAndKeywords","FVS_PlotInit", - "FVS_StandInit","FVS_TreeInit") - dbo = dbConnect(dbDrv,"FVS_Data.db") - dbdis=system.file("extdata","databaseDescription.xlsx",package="fvsOL") - standNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_StandInit")) - standNT = if (class(standNT) == "try-error") NULL else apply(standNT[,c(1,3)],2,toupper) - treeNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_TreeInit")) - treeNT = if (class(treeNT) == "try-error") NULL else apply(treeNT[,c(1,3)],2,toupper) - plotNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_PlotInit")) - plotNT = if (class(plotNT) == "try-error") NULL else apply(plotNT[,c(1,3)],2,toupper) - i = 3 - for (sheet in sheets) - { - i = i+1 -cat ("sheet = ",sheet," i=",i,"\n") - progress$set(message = paste0("Processing sheet ",i," name=",sheet), value=i) - sdat = read.xlsx(xlsxFile=fname,sheet=sheet) - sdat[[3]] <- gsub("_x000D_", "", sdat[[3]]) - im = grep(sheet,normNames,ignore.case=TRUE) - if (length(im)) sheet = normNames[im] - NT = switch(sheet,"FVS_StandInit"=standNT,"FVS_TreeInit"=treeNT, - "FVS_PlotInit"=plotNT,NULL) - if (!is.null(NT)) - { - std = pmatch(toupper(names(sdat)),NT[,1]) - for (icol in 1:length(sdat)) - { - if (!is.na(std[icol])) sdat[,icol] = - switch(NT[std[icol],2], - "TEXT" = as.character(sdat[,icol]), - "REAL" = as.numeric (sdat[,icol]), - "INTEGER" = as.integer (sdat[,icol])) - } - } - dbWriteTable(conn=dbo,name=sheet,value=sdat) - } - } else { - i = 0 - file.rename(from=fname,to="FVS_Data.db") - dbo = dbConnect(dbDrv,"FVS_Data.db") - tabs = toupper(myListTables(dbo)) - if(!length(grep("FVS_STANDINIT",tabs))) - { - setwd(curDir) - progress$close() - output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") - session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") - return() - } - } - tabs = myListTables(dbo) - fiaData = "FVS_STANDINIT_COND" %in% toupper(tabs) && - "FVS_STANDINIT_PLOT" %in% toupper(tabs) - if (fiaData) - { - fiaMsg=NULL - progress$set(message = "FIA data detected, most checks skipped", value = 1) - # insure that the DSNIn keywords address FVS_Data.db in the FVS_GroupAddFilesAndKeywords table - grpAdd = try(dbGetQuery(dbo,'select * from "fvs_groupaddfilesandkeywords"')) - if (class(grpAdd) != "try.error") - { - kwi = match("FVSKEYWORDS",toupper(names(grpAdd)))[1] - if (!is.na(kwi)) - { - ch = gsub("\nDSNIn\n.{1,}\nStandSQL","\nDSNIn\nFVS_Data.db\nStandSQL",grpAdd[,kwi]) - if (any(ch!=grpAdd[,kwi])) - { - grpAdd[,kwi] = ch - fiaMsg = "FVS_GroupAddFilesAndKeywords FVSKeywords field was modified" - dbWriteTable(dbo,"FVS_GroupAddFilesAndKeywords",grpAdd,overwrite=TRUE) - } - } - } - } else { - # get rid of "NRIS_" part of names if any - for (tab in tabs) - { -cat("loaded table=",tab,"\n") - nn = sub("NRIS_","",tab) - if (nchar(nn) && nn != tab) dbExecute(dbo,paste0("alter table ",tab," rename to ",nn)) - } - tabs = myListTables(dbo) - ltabs = tolower(tabs) - fixTabs=c(grep ("standinit",ltabs,fixed=TRUE),grep ("plotinit",ltabs)) - # if there is a FVS_GroupAddFilesAndKeywords table, grab the unique group codes - grpmsg=NULL - progress$set(message = "Checking FVS_GroupAddFilesAndKeywords", value = 4) - if ("fvs_groupaddfilesandkeywords" %in% ltabs) - { - addgrps=try(dbGetQuery(dbo,'select distinct groups from "fvs_groupaddfilesandkeywords"')) - if (class(addgrps)!="try-error") - { - addgrps=unique(unlist(lapply(addgrps[,1],function (x) scan(text=x,what="character",quiet=TRUE)))) -cat ("addgrps=",paste0(addgrps,collapse=" "),"\n") - for (idx in fixTabs) - { - tab2fix=tabs[idx] - grps=try(dbGetQuery(dbo,paste0("select distinct groups from '",tab2fix,"'"))) - if (class(grps)=="try-error") next - if (is.na(grps[1,1])) next - grps=unique(unlist(lapply(grps[,1],function (x) scan(text=x,what="character",quiet=TRUE)))) - if (any(is.na(match(addgrps,grps))) && !length(match(grps,addgrps))) - { - Tb=try(dbReadTable(dbo,tab2fix)) - if (class(Tb)=="try-error") next - idx=match("groups",tolower(names(Tb))) - if (!is.na(idx) && nrow(Tb)) - { - idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) grep("Plots",addgrps) else grep("Stands",addgrps) - ridxs <- grep(grps[grep("NA",as.list(match(addgrps,grps)))],Tb[,idx]) - Tb[ridxs,idx]=paste0(addgrps[idf]," ",Tb[ridxs,idx]) - if (class(try(dbWriteTable(dbo,tab2fix,Tb,overwrite=TRUE)))!="try-error") - grpmsg=c(grpmsg,tab2fix) - } - } - } - } - } - # checking for required group codes and blank Stand_CN - if ("fvs_standinit" %in% ltabs) - { - qry="update FVS_StandInit set Groups = 'All_Stands '|| Groups where Groups is not null - and Groups not LIKE '%All_Stands%';" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - qry="update FVS_StandInit set Groups = 'All_Stands' where Groups is null;" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - qry="update FVS_StandInit set Stand_CN = (select Stand_ID from FVS_StandInit) where Stand_CN is null;" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - } - if ("fvs_plotinit" %in% ltabs) - { - qry="update FVS_PlotInit set Groups = 'All_Plots '|| Groups where Groups is not null - and Groups not LIKE '%All_Plots%';" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - qry="update FVS_PlotInit set Groups = 'All_Plots' where Groups is null;" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - qry="update FVS_PlotInit set Stand_CN = (select Stand_ID from FVS_PlotInit) where Stand_CN is null;" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - } - if ("fvs_treeinit" %in% ltabs) - { - qry="update FVS_TreeInit set Stand_CN = (select Stand_ID from FVS_TreeInit) where Stand_CN is null;" - rtn=try(dbExecute(dbo,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - } -cat ("checking duplicate stand or standplot ids\n") - progress$set(message = "Checking for duplicate StandID values", value = 5) - # loop over tables and omit duplicate stand or standplot id's from being uploaded - sidmsg=NULL - newID=NULL - for (idx in fixTabs) - { -cat ("checking tabs[idx]=",tabs[idx],"\n") - if (tolower(tabs[idx]) %in% c("fvs_standinit_plot","fvs_standinit_cond", - "fvs_treeinit_plot","fvs_treeinit_cond","fvs_plotinit_plot")) next - tab2fix=tabs[idx] - idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) "standplot_id" else "stand_id" - qry = paste0("select ",idf," from '",tab2fix,"'") -cat ("qry=",qry,"\n") - sidTb=try(dbGetQuery(dbo,qry)) - if (class(sidTb)=="try-error") next - dups = duplicated(sidTb[,1]) - if (all(!dups)) next - keep <- list() - cntr <- 1 - for (i in 1:length(dups)){ - if (dups[i]==FALSE){ - keep[cntr] <- i - cntr <- cntr +1 - } - } - sidTb=try(dbReadTable(dbo,tab2fix)) - if (class(sidTb)=="try-error") next - sidTb=sidTb[as.numeric(keep),] - dbWriteTable(dbo,tab2fix,sidTb,overwrite=TRUE) - sidmsg=c(sidmsg,tab2fix) - } - # remove any leading or trailing spaces in stand id's which blow up the SQL queries at run time - fixTabs=c(grep ("standinit",ltabs,fixed=TRUE),grep ("plotinit",ltabs),grep ("treeinit",ltabs)) - for (idx in fixTabs) - { -cat ("checking tabs[idx]=",tabs[idx],"\n") - if (tolower(tabs[idx]) %in% c("fvs_standinit_plot","fvs_standinit_cond", - "fvs_treeinit_plot","fvs_treeinit_cond","fvs_plotinit_plot")) next - tab2fix=tabs[idx] - idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) "standplot_id" else "stand_id" - qry = paste0("select ",idf," from '",tab2fix,"'") -cat ("qry=",qry,"\n") - sidTb=try(dbGetQuery(dbo,qry)) - if (class(sidTb)=="try-error") next - if(length(sidTb[[1]])==0) next - sidTb <- data.frame(trim(sidTb[[1]])) - names(sidTb) <- toupper(idf) - sidTbAll=try(dbReadTable(dbo,tab2fix)) - if (idf == "standplot_id") oldSID <- grep("StandPlot_ID",names(sidTbAll),ignore.case=TRUE) else - oldSID <- grep("Stand_ID",names(sidTbAll),ignore.case=TRUE) - sidTbAll <- sidTbAll[,-oldSID] - sidTbAll <- append(sidTbAll,sidTb, after=0) - if (class(sidTbAll)=="try-error") next - dbWriteTable(dbo,tab2fix,data.frame(sidTbAll),overwrite=TRUE) - } -cat ("sidmsg=",sidmsg,"\n") - } - progress$set(message = "Getting row counts", value = 6) - rowCnts = unlist(lapply(tabs,function (x) dbGetQuery(dbo, - paste0("select count(*) as '",x,"' from '",x,"';")))) - msg = lapply(names(rowCnts),function(x) paste0(x," (",rowCnts[x]," rows)")) - msg = paste0("Uploaded data:
",paste0(msg,collapse="
")) - if (!fiaData) - { - if (!is.null(grpmsg)) msg=paste0(msg,"
Groups values were modified in table(s): ", - paste0(grpmsg,collapse=", ")) - if (!is.null(sidmsg)) msg=paste0(msg,"
Duplicate Stand_ID or StandPlot_ID values were found in table(s): ", - paste0(sidmsg,collapse=", "),".
All duplicate values after the first value were not kept.") -cat ("calling fixFVSKeywords\n") - progress$set(message = "Checking FVSKeywords", value = 7) - tt = try(fixFVSKeywords(dbo)) - canuse=class(tt) == "NULL" - if (class(tt)=="character") msg = paste0(msg, - "
Checking keywords: ",tt) - progress$set(message = "Checking for minimum column definitions", value = 8) - tt = try(checkMinColumnDefs(dbo,progress,9)) - canuse=canuse && class(tt) == "NULL" - if (class(tt)=="character") msg = paste0(msg,"
Checking columns: ",tt) - if (!canuse) msg = paste0(msg, - "

Data checks indicate there are unresolved problems in the input.

") -cat ("msg=",msg,"\n") - } else msg = paste0(msg,if (!is.null(fiaMsg)) paste0("
",fiaMsg) else "", - "

Data checks are skipped when FIA data is detected.

") - output$step1ActionMsg = renderUI(HTML(msg)) - dbGlb$newFVSData = tempfile() - dbDisconnect(dbo) - file.copy(from="FVS_Data.db",to=dbGlb$newFVSData,overwrite=TRUE) - session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") - session$sendCustomMessage(type="jsCode", - list(code= "$('#installNewDB').prop('disabled',false)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#addNewDB').prop('disabled',false)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installTrainDB').prop('disabled',false)")) - session$sendCustomMessage(type="jsCode", - list(code= "$('#installEmptyDB').prop('disabled',false)")) - setwd(curDir) - progress$close() - }) - ## installNewDB - observe({ - if (input$installNewDB == 0) return() - if (is.null(dbGlb$newFVSData)) return() - dbDisconnect(dbGlb$dbIcon) - file.copy(dbGlb$newFVSData,"FVS_Data.db",overwrite=TRUE) - unlink(dbGlb$newFVSData) - dbGlb$newFVSData=NULL - dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") - progress <- shiny::Progress$new(session,min=1,max=8) - i = 1 - progress$set(message="Checking for FVS_GroupAddFilesAndKeywords",value=i) - # Add an FVS_GroupAddFilesAndKeywords table if needed. - addkeys = getTableName(dbGlb$dbIcon,"FVS_GroupAddFilesAndKeywords") - if (is.null(addkeys)) need = TRUE else - { - gtab = try(dbReadTable(dbGlb$dbIcon,addkeys)) - need = class(gtab) == "try-error" - if (!need) need = nrow(gtab) == 0 - names(gtab) = toupper(names(gtab)) - if (!need) need = all(is.na(gtab$FVSKEYWORDS)) - if (!need) need = all(gtab$FVSKEYWORDS == "") - } - if (need) - { - treeInit = getTableName(dbGlb$dbIcon,"FVS_TreeInit") - if (is.null(treeInit)) treeInit="FVS_TreeInit" - dfinstand=NULL - grps = list("FVS_StandInit"="All All_Stands", - "FVS_PlotInit"="All All_Plots", - "FVS_StandInit_Cond"="All All_Conds") - for (std in names(grps)) - { - stdInit = getTableName(dbGlb$dbIcon,std) - if (is.null(stdInit)) next - linkID = if(stdInit=="FVS_PlotInit") "StandPlot_ID" else "Stand_ID" - dfinstand = rbind(dfinstand, - data.frame(Groups = grps[[std]],Addfiles = "", - FVSKeywords = paste0("Database\nDSNIn\nFVS_Data.db\nStandSQL\n", - "SELECT * FROM ",stdInit,"\nWHERE ",linkID,"= '%StandID%'\n", - "EndSQL\nTreeSQL\nSELECT * FROM ",treeInit,"\n", - "WHERE ",linkID,"= '%StandID%'\nEndSQL\nEND"))) - } - dbWriteTable(dbGlb$dbIcon,"FVS_GroupAddFilesAndKeywords",value=dfinstand,overwrite=TRUE) - } - tabs = myListTables(dbGlb$dbIcon) - for (tb in tabs) - { - i = i+1 - progress$set(message = paste0("Setting up index for table ",tb), value=i) - if (tolower(tb) == "fvs_climattr") - { - rtn = try(dbExecute(dbGlb$dbIcon,"drop index if exists StdScnIndex")) - if (class(try)!="try-error") - { - qry = "create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);" -cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } else if (tolower(tb) == "fvs_standinit_cond" || tolower(tb) == "fvs_treeinit_cond") - { - tbidx = grep(tb,c("FVS_StandInit_Cond","FVS_TreeInit_Cond"),ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") -cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - } else if (tolower(tb) == "fvs_standinit_plot") - { - tbidx = grep(tb,c("FVS_StandInit_Plot","FVS_TreeInit_Plot"),ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") -cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - } else if (tolower(tb) == "fvs_plotinit_plot") - { - tbidx = grep(tb,c("FVS_PlotInit_Plot"), - ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") -cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - } - else if (tolower(tb) == "fvs_treeinit_plot") - { - tbidx = grep(tb,c("FVS_TreeInit_Plot"), - ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") - cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - }else if (tolower(tb) == "fvs_plotinit") - { - tbidx = grep(tb,c("FVS_PlotInit","FVS_TreeInit"), - ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") - cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - }else { - tbidx = grep(tb,c("FVS_StandInit","FVS_TreeInit"), - ignore.case=TRUE) - if (length(tbidx)) - { - tbinx = paste0("idx",tb) - rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - if (class(try)!="try-error") - { - qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") -cat ("index creation, qry=",qry,"\n") - try(dbExecute(dbGlb$dbIcon,qry)) - } - } - } - } - progress$set(message = "Load variant data", value = i+1) - resetActiveFVS(globals) - loadVarData(globals,input,dbGlb$dbIcon) - output$step2ActionMsg = renderText(HTML(paste0("
Uploaded data installed.
", - "WARNING: If existing runs in this project were created using input ", - "data that are not present in the database just installed, ", - "you will need to re-load those data to run them again.
", - "Note that the output from the previous runs will remain in the output database."))) - initNewInputDB(session,output,dbGlb) - progress$close() - }) - - ## addNewDB - observe({ - if (input$addNewDB == 0) return() - output$step2ActionMsg <- NULL - if (is.null(dbGlb$newFVSData)) {output$step1ActionMsg<-NULL;return()} - dbo = dbConnect(dbDrv,dbGlb$newFVSData) - newtabs = myListTables(dbo) - dbDisconnect(dbo) - if (length(newtabs)==0) return() - # set an exclusive lock on the database - dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = EXCLUSIVE") - progress <- shiny::Progress$new(session,min=1,max=length(newtabs)*2+3) - i=2 - progress$set(message = "Getting exclusive database lock", value=1) - trycnt=0 - while (TRUE) - { - trycnt=trycnt+1 - if (trycnt > 1000) - { - dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = NORMAL") - myListTables(dbGlb$dbIcon) # this forces the new locking mode to take effect - output$step2ActionMsg <- renderText("Error: Exclusive lock was not obtained.") - progress$close() - return() - } -cat ("try to get exclusive lock on input database, trycnt=",trycnt,"\n"); - rtn <- try(dbExecute(dbGlb$dbIcon,"create table dummy (dummy int)")) - if (class(rtn) != "try-error") break; - Sys.sleep (1) - } - dbExecute(dbGlb$dbIcon,"drop table if exists dummy") - oldInds = dbGetQuery(dbGlb$dbIcon,"select name from sqlite_master where type='index';")[,1] - for (idx in oldInds) dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",idx,";")) - oldtabs = myListTables(dbGlb$dbIcon) - progress$set(message = "Attaching new database.", value=2) - attach = try(dbExecute(dbGlb$dbIcon,paste0("attach '",dbGlb$newFVSData,"' as addnew;"))) - if (class(attach) == "try-error") - { - output$step2ActionMsg <- renderText("New data could not be added") - unlink(dbGlb$newFVSData) - progress$close() - dbGlb$newFVSData=NULL - } - justNew = setdiff(newtabs,oldtabs) - for (tab in justNew) - { - i=i+1 - progress$set(message = paste0("Loading ",tab), value = i) - qry=paste0("create table ",tab," as select * from addnew.",tab) -cat("qry=",qry,"\n") - rtn = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(rtn)=="try-error") cat ("qry failed:",qry,"\n") - } - newtabs = setdiff(newtabs,justNew) - for (tab in newtabs) - { - i=i+1 - progress$set(message = paste0("Loading ",tab), value = i) - rows=try(dbGetQuery(dbGlb$dbIcon,paste0("select count(*) from ",tab))) - if (class(rows)=="try-error") next - if (class(rows)=="data.frame" && rows[1,1]==0) - { - cat ("no rows in ",tab,"\n") - next - } - newTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma addnew.table_info(",tab,")")) - trgTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma table_info(",tab,")")) - sid1 = toupper(newTdef$name) - sid2 = toupper(trgTdef$name) - if ("STAND_ID" %in% sid1 && "STAND_ID" %in% sid2) - { - qry = paste0("delete from ",tab," where Stand_ID in ", - "(select Stand_ID from addnew.",tab,")") - rtn = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(rtn)=="try-error") cat ("removing duplicated Stand_IDs failed.") - } - if (tolower(tab) == "fvs_groupaddfilesandkeywords") - dbExecute(dbGlb$dbIcon,paste0("delete from ",tab," where 'Groups' in ", - " (select 'Groups' from addnew.",tab,")")) - # homogenize table structure and then do the insert from ... - newTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma addnew.table_info(",tab,")")) - trgTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma table_info(",tab,")")) - newTdef$lcname = tolower(newTdef$name) - trgTdef$lcname = tolower(trgTdef$name) - missingInTrg = setdiff(newTdef$lcname,trgTdef$lcname) - missingIndx = match(missingInTrg,newTdef$lcname) - if (length(missingIndx) && !any(is.na(missingIndx))) - { - for (ii in missingIndx) - { - qry = paste0("alter table '",tab,"' add column ",newTdef$name[ii], - " ",newTdef$type[ii],";") -cat ("alter table qry=",qry,"\n") - rtn = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(rtn)=="try-error") cat ("qry failed\n") - } - } - alln = paste0(newTdef$name,collapse=",") - qry = paste0("insert into ",tab," (",alln,") select ",alln, - " from addnew.",tab,";") -cat ("insert qry=",qry,"\n") - rtn = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(rtn)=="try-error") cat ("qry failed\n") - } - dbExecute(dbGlb$dbIcon,paste0("detach addnew;")) - unlink(dbGlb$newFVSData) - dbGlb$newFVSData=NULL - # fix up the DBH/DIAMETER mess. If DIAMETER is in the data table, then it needs to take on the values - # of DBH if they are also in the table. - cols=tolower(dbGetQuery(dbGlb$dbIcon,"PRAGMA table_info('FVS_TreeInit')")[,"name"]) - if ("dbh" %in% cols && "diameter" %in% cols) - { - qry=paste0("update FVS_TreeInit set DIAMETER = (select DBH where DIAMETER is null ", - "and DBH is not null) where DIAMETER is null and DBH is not null;") - rtn=try(dbExecute(dbGlb$dbIcon,qry)) -cat ("qry=",qry,"\nrtn=",rtn,"\n") - } - tabs = dbGetQuery(dbGlb$dbIcon,"select * from sqlite_master where type='table'")[,"tbl_name"] - i = i+1 - progress$set(message = "Setting up indices", value=i) - for (tb in tabs) - { - i = i+1 - progress$set(message = paste0("Setting up index for table ",tb), value=i) - if (tolower(tb) == "fvs_climttr") - { - dbExecute(dbGlb$dbIcon,"drop index if exists StdScnIndex") - dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") - } else if ("Stand_ID" %in% dbListFields(dbGlb$dbIcon,tb)) - { - tbinx = paste0("idx",tb) - try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) - try(dbExecute(dbGlb$dbIcon,paste0("create index ",tbinx," on ",tb," (Stand_ID);"))) - } - } - dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = NORMAL") - rowCnts = unlist(lapply(tabs,function (x) dbGetQuery(dbGlb$dbIcon, - paste0("select count(*) as ",x," from ",x,";")))) - msg = lapply(names(rowCnts),function(x) paste0(x," (",rowCnts[x]," rows)")) - msg = paste0("Combined (newly installed) database:
",paste0(msg,collapse="
")) - output$step2ActionMsg <- renderText(msg) - loadVarData(globals,input,dbGlb$dbIcon) - initNewInputDB(session,output,dbGlb) - progress$close() - }) - - ## AppendCSV - observe({ - if(input$inputDBPan == "Append .csv data to existing tables") - { -cat ("Upload new rows\n") - tbs <- myListTables(dbGlb$dbIcon) - dbGlb$tbsCTypes <- lapply(tbs,function(x,dbIcon) - { - tb <- dbGetQuery(dbIcon,paste0("PRAGMA table_info('",x,"')")) - tbtypes = toupper(tb[,"type"]) - res = vector("logical",length(tbtypes)) - res[grep ("INT",tbtypes)] = TRUE - res[grep ("FLOAT",tbtypes)] = TRUE - res[grep ("REAL",tbtypes)] = TRUE - names(res) = tb[,"name"] - res[] = !res - }, dbGlb$dbIcon) - names(dbGlb$tbsCTypes) = tbs - if (length(tbs)) - { - idx <- grep ("FVS_ClimAttrs",tbs,ignore.case=TRUE) - if (length(idx)) tbs = tbs[-idx] - idx <- grep ("StandInit",tbs) - if (length(idx) == 0) idx=1 - updateSelectInput(session=session, inputId="uploadSelDBtabs", choices=tbs, - selected=tbs[idx]) - } else updateSelectInput(session=session, inputId="uploadSelDBtabs", - choices=list()) - output$step2ActionMsg <- renderText(if (length(tbs)) "" else - "No tables in existing database.") - initNewInputDB(session,output,dbGlb) - } - }) - ## uploadStdTree - observe({ - if (is.null(input$uploadStdTree)) return() - isolate({ - indat = try(read.csv(file=input$uploadStdTree$datapath,as.is=TRUE,colClasses="character")) - unlink(input$uploadStdTree$datapath) - if (class(indat) == "try-error" || is.null(indat) || nrow(indat)==0) - { - output$uploadActionMsg = renderText("Input empty, no data loaded.") - Sys.sleep(1) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - return() - } - del = apply(indat,1,function (x) - { - x = as.vector(x) - x[is.na(x)] = "" - all(x == "") - }) - indat = indat[!del,,drop=FALSE] - if (nrow(indat)==0) - { - output$uploadActionMsg = renderText("All rows were empty, no data loaded.") - Sys.sleep(1) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - return() - } - cols = na.omit(charmatch(tolower(colnames(indat)), - tolower(names(dbGlb$tbsCTypes[[input$uploadSelDBtabs]])))) - if (length(cols) == 0) - { - output$uploadActionMsg = renderText(paste0("No columns match what is defined for ", - input$uploadSelDBtabs,", no data loaded.")) - Sys.sleep(1) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - return() - } - addCols = attr(cols,"na.action") -cat ("addCols=",addCols,"\n") - if (length(addCols)) - { - types = dbGlb$tbsCTypes[[input$uploadSelDBtabs]] - for (icol in addCols) - { - newVar=names(indat)[icol] - defType=charmatch(tolower(newVar),tolower(names(types))) - dtyp = if (is.na(defType)) "character" else - if (types[defType]) "character" else "real" - qry = paste0("alter table ",input$uploadSelDBtabs," add column ", - newVar," ",dtyp,";") -cat ("add column qry=",qry,"\n") - added = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(added) != "try-error") - { - v = dtyp == "character" - names(v) = newVar - dbGlb$tbsCTypes[[input$uploadSelDBtabs]] = c(dbGlb$tbsCTypes[[input$uploadSelDBtabs]],v) - } - } - } - cols = na.omit(charmatch(tolower(colnames(indat)), - tolower(names(dbGlb$tbsCTypes[[input$uploadSelDBtabs]])))) - types = dbGlb$tbsCTypes[[input$uploadSelDBtabs]][cols] - req = switch(tolower(input$uploadSelDBtabs), - fvs_standinit = c("stand_id","variant","inv_year"), - fvs_plotinit = c("stand_id","variant","inv_year"), - fvs_treeinit = c("stand_id","species","dbh"), - fvs_groupaddfilesandkeywords = c("groups"), - NULL) - if (!is.null(req) && !all(req %in% tolower(names(types)))) - { - output$uploadActionMsg = renderText(paste0("Required columns were missing for ", - input$uploadSelDBtabs,", no data loaded.")) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - return() - } - nums = tolower(names(types[!types])) - lnams = tolower(names(indat)) - for (nn in nums) - { - indx=match(nn,lnams) - indat[,indx] = as.numeric(indat[,indx]) - } - - sids=try(dbGetQuery(dbGlb$dbIcon,paste0("select distinct stand_id from ", - isolate(input$uploadSelDBtabs)))) - sids=if (class(sids)=="try-error") NA else sids[,1] - isid=charmatch("stand_id",tolower(names(indat))) - msg=NULL - if (!(is.na(sids) || is.na(isid))) - { - tokeep=is.na(match(indat[,isid],sids)) - ntokill=sum(!tokeep) - if (ntokill==nrow(indat)) - { - output$uploadActionMsg = renderUI(HTML("All uploaded data have Stand_ID(s) that are already loaded and are ignored.")) - return() - } else { - msg = paste0(ntokill," lines of uploaded data have Stand_ID(s) that are already loaded and are ignored.") - indat = indat[tokeep,,drop=FALSE] - } - } - dbBegin(dbGlb$dbIcon) - err = FALSE - insertCount = 0 - for (i in 1:nrow(indat)) - { - row = indat[i,,drop=FALSE] - row = row[,!is.na(row),drop=FALSE] - if (ncol(row) == 0) next - row = row[,row != "'NA'",drop=FALSE] - if (ncol(row) == 0) next - vals=paste0(lapply(row[1,],function (x) if (class(x)=="character") paste0('"',x,'"') else x),collapse=",") - qry = paste0("insert into ",input$uploadSelDBtabs," (", - paste0(colnames(row),collapse=","),") values (",vals,");") -cat ("insert qry=",qry,"\n") - res = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(res) == "try-error") {err=TRUE; break} else insertCount = insertCount+1 - } - if (err) - { - dbRollback(dbGlb$dbIcon) - output$uploadActionMsg = renderUI(HTML(paste0("Error processing: ",qry))) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - return() - } else { -cat ("insertCount=",insertCount,"\n") - dbCommit(dbGlb$dbIcon) - msg=paste0(msg,"
",insertCount," row(s) inserted into ",isolate(input$uploadSelDBtabs)) - output$uploadActionMsg = renderUI(HTML(msg)) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - loadVarData(globals,input,dbGlb$dbIcon) - } - Sys.sleep(1) - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - # this section removes records that have missing values for standID or group - keyCol = NULL - if (length(grep("standinit",input$uploadSelDBtabs,ignore.case=TRUE)) || - length(grep("treeinit", input$uploadSelDBtabs,ignore.case=TRUE)) || - length(grep("plotinit", input$uploadSelDBtabs,ignore.case=TRUE))) - keyCol = "Stand_ID" - if (length(grep("GroupAddFilesAndKeywords",input$uploadSelDBtabs, - ignore.case=TRUE))) keyCol = "Groups" - if (!is.null(keyCol)) - { - # the key column must not be null, if it is delete the rows. - try(dbExecute(dbGlb$dbIcon,paste0("delete from ", - input$uploadSelDBtabs," where ",keyCol," is null"))) - # update the stand selector list if it exists and if we are not doing groups - if (keyCol != "Groups") - { - dbGlb$sids = dbGetQuery(dbGlb$dbIcon,paste0("select distinct Stand_ID from ", - input$uploadSelDBtabs))[,1] - if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" - if (dbGlb$rowSelOn && length(dbGlb$sids)) - updateSelectInput(session=session, inputId="rowSelector", - choices = as.list(dbGlb$sids), selected=unique(indat[,"Stand_ID"])) else - output$stdSel <- mkStdSel(dbGlb) - - qry <- paste0("select _ROWID_,* from ",input$uploadSelDBtabs) - qry <- if (length(input$rowSelector)) - paste0(qry," where Stand_ID in (", - paste0("'",input$rowSelector,"'",collapse=","),");") else - paste0(qry,";") - dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) - rownames(dbGlb$tbl) = dbGlb$tbl$rowid - for (col in 2:ncol(dbGlb$tbl)) dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) - if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else - { - dbGlb$tbl$Delete = FALSE - dbGlb$rows <- c(dbGlb$rows[1], - min(nrow(dbGlb$tbl),dbGlb$rows[2])) - output$tbl <- renderRHandsontable(rhandsontable( - dbGlb$tbl[dbGlb$rows[1]:dbGlb$rows[2], - union(c("Delete"),input$selectdbvars),drop=FALSE], - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - } - } - } - session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") - initNewInputDB(session,output,dbGlb) - }) - }) - ## delCurClimData - observe({ - if (input$delCurClimData) - { - dbExecute(dbGlb$dbIcon,'drop table if exists "FVS_ClimAttrs"') - output$uploadClimActionMsg = renderText(HTML("FVSClimAttrs table deleted if it existed.")) - } - }) - ## ClimateMsgs - observe({ - if (input$topPan == "Manage Projects" && input$inputDBPan == "Upload Climate-FVS data") - { - exTabs=dbListTables(dbGlb$dbIcon) - if ("FVS_ClimAttrs" %in% exTabs) - { - nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") - nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") - output$uploadClimActionMsg = renderText(HTML(paste0("Existing FVSClimAttrs data contains ", - nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) - } else output$uploadClimActionMsg = renderText(HTML(paste0("There is no existing FVSClimAttrs data."))) - } - }) - ## climateFVSUpload - observe({ - if (is.null(input$climateFVSUpload)) return() - progress <- shiny::Progress$new(session,min=1,max=10) - progress$set(message = "Loading data set",value = 2) - climAtt="FVSClimAttrs.csv" - curdir=getwd() - setwd(dirname(input$climateFVSUpload$datapath)) - if (input$climateFVSUpload$type == "application/zip") - try(unzip(input$climateFVSUpload$datapath, files = climAtt)) else - file.copy(input$climateFVSUpload$datapath,climAtt, - overwrite = TRUE) - if (!file.exists(climAtt)) - { -cat ("no FVSClimAttrs.csv file\n") - output$uploadClimActionMsg = renderText("FVSClimAttrs.csv not found.") - progress$set(message = "FVSClimAttrs.csv not found", value = 6) - Sys.sleep (2) - session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") - progress$close() - setwd(curdir) - unlink(input$climateFVSUpload$datapath) - return() - } -cat ("processing FVSClimAttrs.csv\n") - progress$set(message = "Loading data set (big files take a while)",value = 2) - climd = read.csv(climAtt,nrows=1) - climd = read.csv(climAtt,colClasses=c(rep("character",2), - "integer",rep("numeric",ncol(climd)-3)),as.is=TRUE) - unlink(climAtt) - unlink(input$climateFVSUpload$datapath) - setwd(curdir) - if (names(climd)[2] != "Scenario") - { - output$uploadClimActionMsg = renderText(HTML("FVSClimAttrs.csv does not contain expected column names.")) - progress$set(message = "FVSClimAttrs.csv not as expected", value = 6) - Sys.sleep (2) - session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") - progress$close() - rm(climd) - return() - } - names(climd)[1]="Stand_ID" - cdnames=colnames(climd) - periods=grep(".",cdnames,fixed=TRUE) - if (length(periods)) - { - message = paste0("Illegal period(s) in column name(s): ", - paste0(cdnames[periods],collapse=",")) - progress$set(message,value = 4) - Sys.sleep (.5) - progress$close() - output$uploadClimActionMsg = renderText(HTML(paste0("",message,". Data not loaded."))) - rm(climd) - return() - } - climTab <- myListTables(dbGlb$dbIcon) - if (!("FVS_ClimAttrs" %in% climTab)) - { -cat ("no current FVS_ClimAttrs\n") - progress$set(message = "Building FVS_ClimAttrs table",value = 4) - dbWriteTable(dbGlb$dbIcon,"FVS_ClimAttrs",climd) - rm (climd) - progress$set(message = "Creating FVS_ClimAttrs index",value = 6) - dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') - dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") - nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") - nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") - output$uploadClimActionMsg = renderText(HTML(paste0("FVSClimAttrs data contains ", - nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) - progress$set(message = "Done", value = 9) - Sys.sleep (.5) - progress$close() - return() - } - progress$set(message = "Building temporary FVS_ClimAttrs table",value = 4) - dbWriteTable(dbGlb$dbIcon,"temp.FVS_ClimAttrs",climd,overwrite=TRUE) - rm (climd) - progress$set(message = "Query distinct stands and scenarios",value = 5) - distinct = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID,Scenario from 'temp.FVS_ClimAttrs'") - progress$set(message = "Cleaning previous climate data as needed",value = 6) - dbBegin(dbGlb$dbIcon) - results = apply(distinct,1,function (x,dbIcon) - { - dbExecute(dbIcon,paste0('delete from FVS_ClimAttrs where Stand_ID = "', - x[1],'" and Scenario = "',x[2],'"')) - }, dbGlb$dbIcon) - dbCommit(dbGlb$dbIcon) - dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') - # get the table: - progress$set(message = "Inserting new data",value = 8) - oldAttrs = dbGetQuery(dbGlb$dbIcon,"select * from FVS_ClimAttrs limit 1") - if (nrow(oldAttrs) == 0) - { -cat ("simple copy from new, all rows were deleted\n") - dbExecute(dbGlb$dbIcon,"drop table FVS_ClimAttrs") - dbExecute(dbGlb$dbIcon,"create table 'FVS_ClimAttrs' as select * from 'temp.FVS_ClimAttrs'") - } else { - newAttrs = dbGetQuery(dbGlb$dbIcon,"select * from 'temp.FVS_ClimAttrs' limit 1") - if (!identical(colnames(oldAttrs),colnames(newAttrs))) - { -cat ("need to match columns, cols are not identical\n") - oldAttrs=colnames(oldAttrs)[-(1:3)] - newAttrs=colnames(newAttrs) - ssid = newAttrs[1:3] - newAttrs = newAttrs[-(1:3)] - oldsp=unlist(lapply(oldAttrs,function (x) if (toupper(x) == x) x else NULL)) - newsp=unlist(lapply(newAttrs,function (x) if (toupper(x) == x) x else NULL)) - bothsp = union(oldsp,newsp) - oldot=setdiff(oldAttrs,bothsp) - newot=setdiff(newAttrs,bothsp) - bothot = union(oldot,newot) - newall = c(bothsp,bothot) - oldmiss= setdiff(newall,oldAttrs) - newmiss= setdiff(newall,newAttrs) - newall = c(ssid,newall) - selnew = paste0(newall,collapse=",") -cat ("length(newmiss)=",length(newmiss)," selnew=",selnew,"\n") - if (length(newmiss) > 0) - { - dbBegin(dbGlb$dbIcon) - for (mis in newmiss) dbExecute(dbGlb$dbIcon, - paste0('alter table "temp.FVS_ClimAttrs" add "',mis,'" real')) - dbCommit(dbGlb$dbIcon) - } -cat ("length(oldmiss)=",length(oldmiss),"\n") - if (length(oldmiss) > 0) - { - dbBegin(dbGlb$dbIcon) - for (mis in oldmiss) dbExecute(dbGlb$dbIcon, - paste0('alter table FVS_ClimAttrs add "',mis,'" real')) - dbCommit(dbGlb$dbIcon) - } - } - attrs = colnames(dbGetQuery(dbGlb$dbIcon,"select * from 'FVS_ClimAttrs' limit 1")) - sel = paste0(attrs,collapse=",") - qry=paste0("insert into FVS_ClimAttrs (",sel,") select ",sel," from 'temp.FVS_ClimAttrs'") -cat("insert qry=",qry,"\n") - dbExecute(dbGlb$dbIcon,qry) - } - dbExecute(dbGlb$dbIcon,'drop table "temp.FVS_ClimAttrs"') - progress$set(message = "Recreating FVS_ClimAttrs index",value = 9) - dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') - dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") - nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") - nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") - output$uploadClimActionMsg = renderText(HTML(paste0("FVSClimAttrs data contains ", - nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) - progress$set(message = "Done", value = 10) - Sys.sleep (2) - session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") - progress$close() - }) - - ## View and edit existing tables - observe({ - if(input$inputDBPan == "View and edit existing tables" && input$topPan == "Manage Projects") - { -cat ("dataEditor View and edit existing tables\n") - tbs <- myListTables(dbGlb$dbIcon) - dbGlb$tbsCTypes <- lapply(tbs,function(x,dbIcon) - { - tb <- dbGetQuery(dbIcon,paste0("PRAGMA table_info('",x,"')")) - tbtypes = toupper(tb[,"type"]) - res = vector("logical",length(tbtypes)) - res[grep ("INT",tbtypes)] = TRUE - res[grep ("FLOAT",tbtypes)] = TRUE - res[grep ("REAL",tbtypes)] = TRUE - names(res) = tb[,"name"] - res[] = !res - }, dbGlb$dbIcon) - names(dbGlb$tbsCTypes) = tbs - idx <- grep ("StandInit",tbs,ignore.case=TRUE) - if (length(idx) == 0) idx=1 - updateSelectInput(session=session, inputId="editSelDBtabs", choices=tbs, - selected=tbs[idx]) - } - }) - - ## editSelDBtabs - observe({ -cat ("editSelDBtabs, input$editSelDBtabs=",input$editSelDBtabs, - " input$mode=",input$mode,"\n") - if (length(input$editSelDBtabs)) - { - dbGlb$tblName <- input$editSelDBtabs - fixEmptyTable(dbGlb) - msg=checkMinColumnDefs(dbGlb$dbIcon) -cat ("msg=",msg,"\n") - dbGlb$tbl <- NULL - dbGlb$tblCols <- names(dbGlb$tbsCTypes[[dbGlb$tblName]]) - if (length(grep("Stand_ID",dbGlb$tblCols,ignore.case=TRUE))) - { - rtn = try(dbGetQuery(dbGlb$dbIcon, - paste0("select distinct Stand_ID from '",dbGlb$tblName,"'"))) - if (class(rtn)=="try-error") - { -cat ("stand_ID query error.\n") - return() - } else dbGlb$sids = rtn[,1] - if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" - if (length(dbGlb$sids) > 0) - { - if (dbGlb$rowSelOn) updateSelectInput(session=session, - inputId="rowSelector",choices = dbGlb$sids) else - output$stdSel <- mkStdSel(dbGlb) - } - } else { - dbGlb$sids <- NULL - output$stdSel <- renderUI(NULL) - dbGlb$rowSelOn <- FALSE - } - updateSelectInput(session=session, inputId="editSelDBvars", - choices=as.list(dbGlb$tblCols),selected=dbGlb$tblCols) - html=NULL - xlsxFile=system.file("extdata", "databaseDescription.xlsx", package="fvsOL") - tabs = try(read.xlsx(xlsxFile=xlsxFile,sheet="InputTableDescriptions")) - if (class(tabs) != "try-error") - { - row = charmatch(toupper(input$editSelDBtabs),toupper(tabs[,1])) - if (!is.na(row)) - { - tab = tabs[row,1] - html = paste0("",tab," ",tabs[row,2]) - mhtml = xlsx2html(tab,xlsxfile=xlsxFile) - if (!is.null(mhtml)) html = paste0(html,mhtml) - } - } - output$inputTabDesc <- renderUI(HTML(html)) - } -cat ("editSelDBtabs returns\n") - }) - - ## editSelDBvars - observe({ - if (length(input$editSelDBvars)) - { -cat ("editSelDBvars, input$editSelDBvars=",input$editSelDBvars," mode=",input$mode,"\n") - ndr = suppressWarnings(as.numeric(input$disprows)) - if (is.na(ndr) || is.nan(ndr) || ndr < 1 || ndr > 500) ndr = 20 - dbGlb$disprows <- ndr - switch(input$mode, - "New rows"= - { - dbGlb$rows <- NULL - tbl <- as.data.frame(matrix("",ncol=length(input$editSelDBvars), - nrow=dbGlb$disprows)) - colnames(tbl) <- input$editSelDBvars - output$tbl <- renderRHandsontable(rhandsontable(tbl, - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE,width="100%")) - output$stdSel <- output$navRows <- renderUI(NULL) - dbGlb$rowSelOn <- dbGlb$navsOn <- FALSE - }, - Edit = - { - qry <- paste0("select _ROWID_,* from '",dbGlb$tblName,"'") - qry <- if (length(intersect("stand_id",tolower(dbGlb$tblCols))) && - length(input$rowSelector)) - paste0(qry," where Stand_ID in (", - paste0("'",input$rowSelector,"'",collapse=","),");") else - paste0(qry,";") - dbGlb$tbl <- suppressWarnings(dbGetQuery(dbGlb$dbIcon,qry)) - lnames = tolower(colnames(dbGlb$tbl)) - stdSearch = trim(input$editStandSearch) - if (nchar(stdSearch)>0) - { - keep = try(grep (stdSearch,dbGlb$tbl[,charmatch("stand_id",lnames)])) - if (class(keep) != "try-error" && length(keep)) dbGlb$tbl = dbGlb$tbl[keep,] - } - rownames(dbGlb$tbl) = dbGlb$tbl$rowid - for (col in 2:ncol(dbGlb$tbl)) - if (! ("character" %in% class(dbGlb$tbl[[col]]))) - dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) - if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else - { - dbGlb$tbl$Delete = FALSE - dbGlb$rows <- c(1,min(nrow(dbGlb$tbl),dbGlb$disprows)) - output$tbl <- renderRHandsontable( - rhandsontable(dbGlb$tbl[1:min(nrow(dbGlb$tbl),dbGlb$disprows), - union(c("Delete"),input$editSelDBvars),drop=FALSE], - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - if (!dbGlb$navsOn) - { - dbGlb$navsOn <- TRUE - output$navRows <- renderUI(list( - actionButton("previousRows","<< previous rows"), - actionButton("nextRows","next rows >>"), - textOutput("rowRng",inline=TRUE))) - } - output$rowRng <- renderText(paste0(dbGlb$rows[1]," to ", - dbGlb$rows[2]," of ",nrow(dbGlb$tbl))) - if (!dbGlb$rowSelOn && length(dbGlb$sids)) - output$stdSel <- mkStdSel(dbGlb) - } - } - ) - } - }) - - ## nextRows - observe({ - if (length(input$nextRows) && input$nextRows > 0) - { - if (is.null(dbGlb$tbl)) return() - input$disprows - newBot <- min(dbGlb$rows[2]+dbGlb$disprows,nrow(dbGlb$tbl)) - newTop <- max(newBot-dbGlb$disprows-1,1) - dbGlb$rows <- c(newTop,newBot) - output$tbl <- renderRHandsontable(rhandsontable(dbGlb$tbl[newTop:newBot, - union(c("Delete"),isolate(input$editSelDBvars)), - drop=FALSE],readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - output$rowRng <- renderText(paste0(newTop," to ", - newBot," of ",nrow(dbGlb$tbl))) - } - }) - - ## previousRows - observe({ - if (length(input$previousRows) && input$previousRows > 0) - { - if (is.null(dbGlb$tbl)) return() - input$disprows - newTop <- max(dbGlb$rows[1]-dbGlb$disprows,1) - newBot <- min(newTop+dbGlb$disprows-1,nrow(dbGlb$tbl)) - dbGlb$rows <- c(newTop,newBot) - output$tbl <- renderRHandsontable(rhandsontable(dbGlb$tbl[newTop:newBot, - union(c("Delete"),isolate(input$editSelDBvars)), - drop=FALSE],readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - output$rowRng <- renderText(paste0(newTop," to ", - newBot," of ",nrow(dbGlb$tbl))) - } - }) - - # commitChanges - observe({ - if (input$commitChanges > 0) - { - isolate({ -cat ("commitChanges, mode=",input$mode,"len tbl=",length(input$tbl),"\n") - dd = lapply(input$tbl$params$data,function (jj) - lapply(jj,function(x) if (is.null(x)) NA else x)) - inputTbl = matrix(unlist(dd), - ncol=length(input$tbl$params$columns),byrow=TRUE) - inputTbl[inputTbl=="NA"] = NA - colnames(inputTbl) = unlist(input$tbl$params$colHeaders) - rownames(inputTbl) = unlist(input$tbl$params$rowHeaders) - switch(input$mode, - "New rows"= - { - inserts <- mkInserts(inputTbl,dbGlb$tblName, - dbGlb$tbsCTypes[[dbGlb$tblName]]) - if (length(inserts)) - { - dbBegin(dbGlb$dbIcon) - err = FALSE - for (ins in inserts) - { - res = try(dbExecute(dbGlb$dbIcon,ins)) - if (class(res) == "try-error") {err=TRUE; break} - } - if (err) - { - dbRollback(dbGlb$dbIcon) - output$actionMsg = renderText(paste0("Error processing: ",ins)) - return() - } else { - dbCommit(dbGlb$dbIcon) - output$actionMsg = renderText(paste0(length(inserts)," insert(s) processed.")) - } - tbl <- as.data.frame(matrix("", - ncol=length(input$editSelDBvars),nrow=dbGlb$disprows)) - colnames(tbl) <- input$editSelDBvars - output$tbl <- renderRHandsontable(rhandsontable(tbl, - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - } - }, - Edit = - { - err=FALSE - nrows = nrow(inputTbl) - nprocess = 0 - dbBegin(dbGlb$dbIcon) - if (nrows) for (rn in 1:nrows) - { - row = inputTbl[rn,] - id = rownames(inputTbl)[rn] - if (row["Delete"] == "TRUE") - { - qry = paste0("delete from ",dbGlb$tblName," where _ROWID_ = ", - id) -cat ("edit del, qry=",qry,"\n") - res = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(res) == "try-error") {err=TRUE; break} - nprocess = nprocess+1 - if (!is.null(dbGlb$sids)) dbGlb$sids = NULL - } else { - row = inputTbl[rn,] - if (length(row) < 2) next - row = row[-1] - row[is.na(row)] = "" - row[row == "NA"] = "" - org = subset(dbGlb$tbl,rowid == id) - org = as.character(org[,names(row),drop=TRUE]) - org[is.na(org)] = "" - org[org=="character(0)"] = "" - org[org == "NA"] = "" - names(org)=names(row) - neq = vector("logical",length(row)) - for (i in 1:length(row)) neq[i]=!identical(row[i],org[i]) - if (sum(neq) == 0) next - update = row[neq] - toquote = dbGlb$tbsCTypes[[dbGlb$tblName]][names(update)] - if (!is.null(dbGlb$sids) && - !is.na(toquote["Stand_ID"])) dbGlb$sids = NULL - if (any(toquote)) - { - for (toq in names(toquote[toquote])) - { - update[toq] = if (update[toq]=="") "NULL" else - paste0("'",gsub("'","''",update[toq]),"'") - } - } - update[update==""] = "NULL" - qry = paste0("update ",dbGlb$tblName," set ", - paste(paste0(names(update)," = ",update),collapse=", "), - " where _ROWID_ = ",id) -cat ("edit upd, qry=",qry,"\n") - res = try(dbExecute(dbGlb$dbIcon,qry)) - if (class(res) == "try-error") {err=TRUE; break} - nprocess = nprocess+1 - } - } - if (err) - { - dbRollback(dbGlb$dbIcon) - output$actionMsg = renderText(paste0("Error processing: ",qry)) - return() - } else { - dbCommit(dbGlb$dbIcon) - output$actionMsg = renderText(paste0(nprocess," change(s) processed.")) - } - fixEmptyTable(dbGlb) -cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), - " dbGlb$tblName=",dbGlb$tblName, - " Stand_ID yes=",length(intersect("stand_id",tolower(dbGlb$tblCols))),"\n") - if (is.null(dbGlb$sids) && - length(intersect("stand_id",tolower(dbGlb$tblCols)))) - { - dbGlb$sids = dbGetQuery(dbGlb$dbIcon,paste0("select distinct Stand_ID from ", - dbGlb$tblName))[,1] - if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" - if (dbGlb$rowSelOn && length(dbGlb$sids)) - updateSelectInput(session=session, inputId="rowSelector", - choices = dbGlb$sids) else - output$stdSel <- mkStdSel(dbGlb) - } - - qry <- paste0("select _ROWID_,* from ",dbGlb$tblName) - qry <- if (length(grep("stand_id",tolower(dbGlb$tblCols))) && - length(input$rowSelector)) - paste0(qry," where Stand_ID in (", - paste0("'",input$rowSelector,"'",collapse=","),");") else - paste0(qry,";") - dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) - rownames(dbGlb$tbl) = dbGlb$tbl$rowid - for (col in 2:ncol(dbGlb$tbl)) - if (class(dbGlb$tbl[[col]])[1] != "character") - dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) - if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else - { - dbGlb$tbl$Delete = FALSE - dbGlb$rows <- c(dbGlb$rows[1], - min(nrow(dbGlb$tbl),dbGlb$rows[2])) - output$tbl <- renderRHandsontable(rhandsontable( - dbGlb$tbl[dbGlb$rows[1]:dbGlb$rows[2], - union(c("Delete"),input$editSelDBvars),drop=FALSE], - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - } - } - ) - }) - } - reloadStandSelection(session,input) - }) - - ## Remove all rows and commit - observe({ - if(input$clearTable > 0) - { - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "clearTableDlg", - message = "Are you sure you want to delete all rows from this database table?")) - } - }) - - observe({ - if(input$clearTableDlgBtn == 0) return() -cat ("clearTable, tbl=",dbGlb$tblName,"\n") - dbExecute(dbGlb$dbIcon,paste0("delete from ",dbGlb$tblName)) - dbGlb$navsOn <- FALSE - dbGlb$rowSelOn <- FALSE - dbGlb$sids <- NULL - output$stdSel <- renderUI(NULL) - tmp = as.data.frame(lapply(dbGlb$tbsCTypes[[dbGlb$tblName]], - function (x) vector(if (x) "character" else "numeric",1)), - stringsAsFactors=FALSE) - tmp[1,] = NA - dbWriteTable(dbGlb$dbIcon,dbGlb$tblName,tmp,overwrite=TRUE) - qry <- paste0("select _ROWID_,* from ",dbGlb$tblName) - dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) - rownames(dbGlb$tbl) = dbGlb$tbl$rowid - dbGlb$tbl$Delete = FALSE - output$tbl <- renderRHandsontable(rhandsontable( - dbGlb$tbl[,union(c("Delete"),input$selectdbvars),drop=FALSE], - readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) - output$rowRng <- renderText("1 to 1 of 1") - isolate(if (input$mode=="New rows") updateRadioButtons(session=session, - inputId="mode",selected="Edit")) - }) - - ## Upload Map data - observe({ - if(input$inputDBPan == "Upload Map data") - { -cat ("Map data hit.\n") - library(sf) - updateSelectInput(session=session, inputId="mapUpLayers", choices=list(), - selected=0) - output$mapActionMsg = renderText(" ") - } - }) - ## mapUpload - observe({ - if(is.null(input$mapUpload)) return() - { -cat ("mapUpload\n") - progress <- shiny::Progress$new(session,min=1,max=3) - if (file.exists(input$mapUpload$datapath)) - { - fileEnding = tolower(tools::file_ext(basename(input$mapUpload$datapath))) -cat ("mapUpload, filename=",input$mapUpload$datapath," ending=",fileEnding,"\n") - if (fileEnding != "zip") - { - output$mapActionMsg = renderText(paste0("Upload a .zip file")) - progress$close() - return() - } - mapDir = paste0(dirname(input$mapUpload$datapath),"/mapData") - unlink(mapDir,recursive=TRUE) - dir.create(mapDir) - file.copy(from=input$mapUpload$datapath,to=mapDir) - zipName = basename(input$mapUpload$datapath) - unlink(input$mapUpload$datapath) - progress$set(message = "Unzipping",value = 1) - curdir = getwd() - setwd(mapDir) - unzip(zipName) - unlink(zipName) - if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) - progress$set(message = "Getting layers",value = 2) - if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) - setwd(mapDir) - lyrs = try(sf::st_layers(dir(mapDir))) - setwd(curdir) -cat ("mapUpload, class(lyrs)=",class(lyrs),"\n") - if ("try-error" %in% class(lyrs) || length(lyrs$name)==0) - { - output$mapActionMsg = renderText("Can not find layers in data") - progress$close() - return() - } - lyrs = as.list(lyrs$name) - if (length(lyrs) > 1) - { - lyr = grep ("poly",names(lyrs),ignore.case=TRUE) - if (length(lyr) == 0 || any(is.na(lyr))) lyr = 1 - if (length(lyr) > 1) lyr = lyr[which.min(nchar(names(lyrs)[lyr]))] - lyr = names(lyrs)[lyr] - } else lyr = lyrs[1] - lyr = unlist(lyr) - updateSelectInput(session=session, inputId="mapUpLayers", choices=lyrs, - selected=lyr) - progress$close() - } - } - }) - ## mapUpLayers - observe({ - if (is.null(input$mapUpLayers)) return() - datadir = dirname(isolate(input$mapUpload$datapath)) - if (!dir.exists(datadir)) return() - curdir = getwd() - setwd(datadir) - datadir = dir() -cat ("input$mapUpLayers =",input$mapUpLayers,"\n") - if (length(dir(datadir)) == 1) setwd(datadir) - progress <- shiny::Progress$new(session,min=1,max=3) - progress$set(message = paste0("Loading map: ",datadir," Layer: ",input$mapUpLayers),value=2) - txtoutput = capture.output(dbGlb$spd <- try(st_read(dir(),input$mapUpLayers))) - setwd(curdir) - if ("try-error" %in% class(dbGlb$spd)) - { - output$mapActionMsg = renderText(paste0("Map read error: ",dbGlb$spd)) - progress$close() - setwd(curdir) - return() - } - txtoutput = paste0(txtoutput,collapse="\n") - output$mapActionMsg = renderText(txtoutput) - progress$set(message = txtoutput,value=3) - stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") - ids = try(dbGetQuery(dbGlb$dbIcon,paste0('select Stand_ID from ',stdInit))) -cat ("length(ids)=",length(ids),"\n") - choices = setdiff(names(dbGlb$spd),"geometry") - names(choices) = choices - if ("try-error" %in% class(ids) || nrow(ids) == 0) - { - selected = grep("ID",choices,ignore.case=TRUE)[1] - if (is.na(selected)) selected=0 - } else { - ids = unlist(ids) - names(ids) = NULL - cnts = NULL - for (col in choices) - cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd[,col][[col]])))) - cnts = cnts/length(ids)*100 - choices = paste0(choices," ",format(cnts,digits=3),"%") - selected = choices[which.max(cnts)] - } -cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected=",selected,"\n") - updateSelectInput(session=session, inputId="mapUpIDMatch", - choices=choices,selected=selected) - progress$close() - }) - - prepSpatialData = function(dbGlb) - { - if (!exists("spd",envir=dbGlb,inherit=FALSE)) return(NULL) - stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") - ids1 = try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct Stand_ID from ',stdInit))) - ids1 = if (class(ids1)=="try-error") list() else unlist(ids1) - names(ids1) = NULL - if ("FVS_Cases" %in% - dbGetQuery(dbGlb$dbOcon,"SELECT * FROM sqlite_master where type='table'")$name) - { - ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) - ids2 = if ("try-error" %in% class(ids2)) list() else unlist(ids2) - names(ids2) = NULL - keep=union(ids1,ids2) - } else keep=ids1 - matID = unlist(strsplit(input$mapUpIDMatch," "))[1] - keep=na.omit(charmatch(keep,dbGlb$spd[,matID][[matID]])) - if (length(keep)) - { - SpatialData=dbGlb$spd[keep,] - attr(SpatialData,"MatchesStandID") = matID - output$mapActionMsg = renderText(paste0("Map saved for this project, StandID match=", - matID,", Number of objects kept=",nrow(SpatialData))) - } else { - SpatialData=NULL - output$mapActionMsg = renderText("No map or data to save.") - } - rm (spd,envir=dbGlb) - return(SpatialData) - } - ## mapUpSave - observe({ - if(input$mapUpSave > 0) - { - SpatialData=prepSpatialData(dbGlb) - if (!is.null(SpatialData)) - { - save (SpatialData,file="SpatialData.RData") - dbGlb$SpatialData = SpatialData - } - } - }) - ## mapUpAdd - observe({ - if(input$mapUpAdd > 0) - { - NewSpatialData=prepSpatialData(dbGlb) - if (!is.null(NewSpatialData)) - { - spatdat="SpatialData.RData" - if (file.exists(spatdat)) load(file=spatdat) - if (!exists("SpatialData")) SpatialData=NewSpatialData else - SpatialData = if (class(SpatialData)=="list") - append(after=0,NewSpatialData) else list(SpatialData,NewSpatialData) - save (SpatialData,file=spatdat) - dbGlb$SpatialData = SpatialData - } - } - }) - ## Import runs and other items - observe({ - if(input$toolsPan == "Import runs and other items") - { - choices = getProjectList(includeLocked=TRUE) - actprj <- grep(basename(getwd()),choices) # remove current project - if (length(actprj)) choices <- choices[-actprj] - updateSelectInput(session=session, inputId="impPrjSource", - choices=choices,selected=0) - output$selectedSourceMsg <- renderText( - paste0('

', - 'No source selected.')) - output$impPrjSourceMsg <- NULL - output$uploadRunsRdatMsg <- NULL - output$impRunsMsg <- NULL - output$impCustomCmpsMsg <- NULL - output$impGraphSettingMsg <- NULL - output$impCustomQueriesMsg <- NULL - output$impFVSDataMsg <- NULL - output$impSpatialDataMsg <- NULL - updateSelectInput(session=session, inputId="uploadRunsRdat",choices=list()) - updateSelectInput(session=session, inputId="impRuns",choices=list()) - updateSelectInput(session=session, inputId="impCustomCmps",choices=list()) - updateSelectInput(session=session, inputId="impGraphSettings",choices=list()) - updateSelectInput(session=session, inputId="impCustomQueries",choices=list()) - updateSelectInput(session=session, inputId="impFVSData",choices=list()) - updateSelectInput(session=session, inputId="impSpatialData",choices=list()) - } - }) - ## mkSrcMsgAndList - mkSrcMsgAndList <- function(db,nruns) - { - msg = paste0("File contains ",nruns," runs") - tbs=dbListTables(db) - itms=listTableNames(db) - itms=intersect(itms,c("GraphSettings","customCmps","customQueries")) - if (file.exists("SpatialData.RData")) itms=c(itms,"SpatialData") - if (file.exists("FVS_Data.db")) itms=c(itms,"FVS_Data") - if (length(itms)>0) msg=paste0(msg," plus: ",paste0(itms,collapse=", ")) - if (nruns > 0) itms=c(itms,"Runs") - rtn = list(itms,msg) - attr(rtn,"dir") = getwd() - for (itm in itms) - { - switch(itm, - "Runs" = { - updateSelectInput(session=session, inputId="impRuns", - choices=getFVSRuns(db)) - }, - "GraphSettings" = { - loadObject(db,"GraphSettings") - names=setdiff(names(GraphSettings),"None") - updateSelectInput(session=session, inputId="impGraphSettings", - choices=as.list(names)) - }, - "customCmps" = { - loadObject(db,"customCmps") - updateSelectInput(session=session, inputId="impCustomCmps", - choices=as.list(names(customCmps))) - }, - "customQueries" = { - loadObject(db,"customQueries") - updateSelectInput(session=session, inputId="impCustomQueries", - choices=as.list(names(customQueries))) - }) - } - zout = setdiff(c("Runs","GraphSettings","customCmps","customQueries"),itms) - for (itm in zout) - { - switch(itm, - "Runs" = updateSelectInput(session=session, inputId="impRuns",choices=list()), - "GraphSettings" = updateSelectInput(session=session, inputId="impGraphSettings",choices=list()), - "customCmps" = updateSelectInput(session=session, inputId="impCustomCmps",choices=list()), - "customQueries" = updateSelectInput(session=session, inputId="impCustomQueries",choices=list()) - ) - } - rtn - } - - ## Upload zip file. - observe({ - if (is.null(input$uploadRunsRdat)) return() - if (!length(grep("zip",input$uploadRunsRdat$type))) { - output$uploadRunsRdatMsg <- renderText("Uploaded file is not a .zip") - } else { - isolate({ - if (length(globals$importItems)) - { - if (attr(globals$importItems,"temp")) - unlink(attr(globals$importItems,"dir"),recursive = TRUE) - globals$importItems=list() - } - curdir = getwd() - tdir = dirname(input$uploadRunsRdat$datapath) - setwd(tdir) - tmpPrj = uuidgen() - dir.create(tmpPrj) - tmpPrj = file.path(getwd(),tmpPrj) - setwd(tmpPrj) - uz = try(unzip(input$uploadRunsRdat$datapath)) - if (class(uz)=="try-error") - { -cat("uploaded zip failed\n") - output$uploadRunsRdatMsg <- renderText("Uploaded file could not be unzipped.") - unlink(input$uploadRunsRdat$datapath) - unlink(tmpPrj,recursive=TRUE) - } else { - updateSelectInput(session=session, inputId="impPrjSource",selected=0) - nruns=mkFVSProjectDB() - db=connectFVSProjectDB() - ml = mkSrcMsgAndList(db,nruns) - dbDisconnect(db) - output$uploadRunsRdatMsg <- renderUI(HTML(ml[[2]])) - attr(ml,"temp") = TRUE # this directory can be deleted - output$selectedSourceMsg <- renderText( - paste0('

Source: ', - ml[[2]])) - globals$importItems = ml -cat("unload zip had ",length(uz),"items. ml[[2]]=",ml[[2]],"\n") - } - setwd(curdir) - }) - } - session$sendCustomMessage(type = "resetFileInputHandler","uploadRunsRdat") - }) - - ## impPrjSource - observe({ - if (is.null(input$impPrjSource)) return() - { - curdir = getwd() - setwd("../") - tmpPrj = file.path(getwd(),input$impPrjSource) - if (dir.exists(tmpPrj)) - { - setwd(tmpPrj) - db = connectFVSProjectDB() - nruns=mkFVSProjectDB() - ml = mkSrcMsgAndList(db,nruns) - ml[[2]] = gsub("File",paste("Project",input$impPrjSource),ml[[2]]) - dbDisconnect(db) - output$selectedSourceMsg <- renderText( - paste0('

Source: ', - ml[[2]])) - attr(ml,"temp") = FALSE # don't delete this source directory - globals$importItems = ml - } - setwd(curdir) - } - }) - - ## doImpRuns - observe({ - if (input$doImpRuns > 0) - {isolate({ - if (is.null(input$impRuns)) return() - prjDir=attr(globals$importItems,"dir") - pDB=connectFVSProjectDB(prjDir) - on.exit(dbDisconnect(pDB)) - curRuns = names(getFVSRuns(dbGlb$prjDB)) - theRun = loadFVSRun(pDB,input$impRuns) - if (is.null(theRun)) - { - output$impRunsMsg = renderText("The run could not be loaded.") - return() - } - curTitle = theRun$title - theRun$title = mkNameUnique(curTitle,names(getFVSRuns(dbGlb$prjDB))) - theRun$uuid = uuidgen() - storeFVSRun(dbGlb$prjDB,theRun) - globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) - output$impRunsMsg = renderText(paste0('Run "',curTitle,'" imported and ', - ' is named "',theRun$title,'" in your current project.')) - updateSelectInput(session=session, inputId="runSel", - choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) - })} - }) - - ## doImpCustomCmps - observe({ - if (input$doImpCustomCmps > 0) - {isolate({ - if (is.null(input$impCustomCmps)) return() - prjDir=attr(globals$importItems,"dir") - pDB=connectFVSProjectDB(prjDir) - on.exit(dbDisconnect(pDB)) - loadObject(pDB,"customCmps",asName="source") - loadObject(dbGlb$prjDB,"customCmps") - curTitle = input$impCustomCmps - if(exists("customCmps")){ - newtitle = mkNameUnique(curTitle,names(customCmps)) - } else{ - customCmps = list() - newtitle = mkNameUnique(curTitle,customCmps) - } - customCmps[newtitle] = source[curTitle] - storeOrUpdateObject(dbGlb$prjDB,customCmps) - output$impCustomCmpsMsg = renderText(paste0('Component "',curTitle,'" imported and ', - ' is named "',newtitle,'" in your current project.')) - globals$customCmps = customCmps - updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(customCmps)), - selected=names(customCmps)[1]) - })} - }) - - ## doImpGraphSettings - observe({ - if (input$doImpGraphSettings > 0) - {isolate({ - if (is.null(input$impGraphSettings)) return() - prjDir=attr(globals$importItems,"dir") - pDB=connectFVSProjectDB(prjDir) - on.exit(dbDisconnect(pDB)) - loadObject(pDB,"GraphSettings",asName="source") - loadObject(dbGlb$prjDB,"GraphSettings") - curTitle = input$impGraphSettings - if(exists("GraphSettings")){ - newtitle = mkNameUnique(curTitle,names(GraphSettings)) - } else{ - GraphSettings = list() - newtitle = mkNameUnique(curTitle,GraphSettings) - } - GraphSettings[newtitle] = source[curTitle] - storeOrUpdateObject(dbGlb$prjDB,GraphSettings) - output$impGraphSettingsMsg = renderText(paste0('Graph setting "',curTitle,'" imported and ', - ' is named "',newtitle,'" in your current project.')) - updateSelectInput(session=session,inputId="OPsettings",choices=as.list(names(GraphSettings)), - selected=names(GraphSettings)[1]) - })} - }) - - ## doImpCustomQueries - observe({ - if (input$doImpCustomQueries > 0) - {isolate({ - if (is.null(input$impCustomQueries)) return() - prjDir=attr(globals$importItems,"dir") - pDB=connectFVSProjectDB(prjDir) - on.exit(dbDisconnect(pDB)) - loadObject(pDB,"customQueries",asName="source") - loadObject(dbGlb$prjDB,"customQueries") - curTitle = input$impCustomQueries - if(exists("customQueries")){ - newtitle = mkNameUnique(curTitle,names(customQueries)) - } else{ - customQueries = list() - newtitle = mkNameUnique(curTitle,customQueries) - } - globals$customQueries[newtitle]= source[curTitle] - customQueries[newtitle] = source[curTitle] - storeOrUpdateObject(dbGlb$prjDB,customQueries) - output$impCustomQueriesMsg = renderText(paste0('Query "',curTitle,'" imported and ', - ' is named "',newtitle,'" in your current project.')) - updateSelectInput(session=session,inputId="sqlSel",choices=as.list(names(customQueries)), - selected="") - })} - }) - - ## impFVS_Data - observe({ - if (input$impFVS_Data > 0) - { -cat(" input$impFVS_Data=",input$impFVS_Data,"\n") - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "impFVS_DataDlg", - message = "This action overwrites your current FVS_Data.db")) - } - }) - observe({ - if (input$impFVS_DataDlgBtn == 0) return() - isolate({ -cat(" input$impFVS_DataDlgBtn=",input$impFVS_DataDlgBtn,"\n") - needfile = file.path(attr(globals$importItems,"dir"),"FVS_Data.db") - if (length(needfile) && nchar(needfile) && file.exists(needfile)) - { - file.copy(from=needfile,to="FVS_Data.db",overwrite=TRUE) - output$impFVS_DataMsg = renderText("FVS_Data.db has been imported.") - } else output$impFVS_DataMsg = renderText("Source FVS_Data.db was NOT found.") - }) - }) - ## impSpatialData - observe({ - if(input$impSpatialData > 0) - { -cat(" input$impSpatialData=",input$impSpatialData,"\n") - session$sendCustomMessage(type = "dialogContentUpdate", - message = list(id = "impSpatialDataDlg", - message = "This action adds this SpatialData your current SpatialData")) - } - }) - observe({ - if (input$impSpatialDataDlgBtn == 0) return() - isolate({ -cat(" input$impSpatialDataDlgBtn=",input$impSpatialDataDlgBtn,"\n") - needfile = file.path(attr(globals$importItems,"dir"),"SpatialData.RData") - if (length(needfile) && nchar(needfile) && file.exists(needfile)) - { - spatdat = "SpatialData.RData" - if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && file.exists(spatdat)) - { - load(spatdat,envir=dbGlb) - if (class(dbGlb$SpatialData)=="SpatialPolygonsDataFrame") - dbGlb$SpatialData=list(d=dbGlb$SpatialData) - load(needfile) #loads into the current frame (local environment). - dbGlb$SpatialData <- append(dbGlb$SpatialData,SpatialData) - save(SpatialData,envir=dbGlb,file="SpatialData.RData") - } else file.copy(from=needfile,to="SpatialData.RData",overwrite=TRUE) - output$impSpatialDataMsg = renderText("SpatialData.RData has been added to this project's spatial data.") - } else output$impSpatialDataMsg = renderText("Source SpatialData.RData was not found.") - }) - }) - - # runScript selection - observe(if (length(input$runScript)) customRunOps()) - ## customRunOps - customRunOps <- function () - { - isolate({ - if (length(input$runScript) == 0) - { -cat ("in customRunOps runScript is empty\n") - return() - } -cat ("in customRunOps runScript: ",input$runScript,"\n") - globals$fvsRun$runScript = input$runScript - output$uiCustomRunOps = renderUI(NULL) - if (input$runScript != "fvsRun") - { - fn=paste0("customRun_",globals$fvsRun$runScript,".R") - if (!file.exists(fn)) fn=system.file("extdata", fn, package="fvsOL") - if (!file.exists(fn)) return() - 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() - output$uiCustomRunOps = renderUI(uiF(globals$fvsRun)) - } else { - globals$fvsRun$uiCustomRunOps = list() - } -if (length(globals$fvsRun$uiCustomRunOps)) lapply(names(globals$fvsRun$uiCustomRunOps), function (x,y) -cat ("globals$fvsRun$uiCustomRunOps$",x,"=",y[[x]],"\n",sep=""),globals$fvsRun$uiCustomRunOps) else -cat ("globals$fvsRun$uiCustomRunOps is empty\n") - }) - } - ## updateProjectSelections - updateProjectSelections <- function () - { - selChoices = getProjectList() - nsel = charmatch(basename(getwd()),selChoices) - if(length(globals$lastNewPrj)) nsel = charmatch(globals$lastNewPrj,selChoices) - sel = if (is.null(nsel)) NULL else selChoices[[nsel]] - updateSelectInput(session=session, inputId="PrjSelect", - choices=selChoices,selected=sel) - ### Block the ability to delete Project_1 on windows - if(.Platform$OS.type == "windows") - { - prj1 = charmatch("Project_1",selChoices) - if (!is.na(prj1)) selChoices=selChoices[-prj1] - actprj <- grep(basename(getwd()),selChoices) - if (length(actprj)) selChoices <- selChoices[-actprj] - } - updateSelectInput(session=session, inputId="PrjDelSelect",choices=selChoices, - selected=0) - backups = dir (pattern="ProjectBackup") - if (length(backups)) - { - backups = sort(backups,decreasing=TRUE) - names(backups) = backups - } else backups=list() - updateSelectInput(session=session, inputId="pickBackup", - choices = backups, selected=NULL) - } - - ## Projects hit - observe({ - if (input$topPan == "Manage Projects" && input$toolsPan == "Manage project") - { -cat ("Manage project hit\n") - updateProjectSelections() - } - - }) - - ## Make New Project (PrjNew) - observe({ - if (length(input$PrjNew)==0 || input$PrjNew == 0) return() - isolate({ -cat ("Make new project, input$PrjNewTitle=",input$PrjNewTitle,"\n") - if (nchar(input$PrjNewTitle)==0) return() - prjid = if (file.exists("projectId.txt")) scan("projectId.txt", - what="character",sep="\n",quiet=TRUE) else NUL - fbin = Sys.readlink(fvsBin) #will be na if file does not exist, "" if not symbolic link. - if (is.na(fbin)) return() - curdir = getwd() - setwd("../") - newTitle = input$PrjNewTitle - newTitle=mkNameUnique(newTitle,setOfNames=names(getProjectList(includeLocked=TRUE))) - ntit=paste0("title= ",newTitle) - fn = if (isLocal()) - { - basedir = basename(curdir) - newTitle <- mkFileNameUnique(newTitle) - newTitle - } else uuidgen() - dir.create(fn) - setwd(fn) - newdir=getwd() - if (dirname(fvsBin) == ".") #fvsBin points to an entry in the current dir. - { - if (nchar(fbin) && .Platform$OS.type=="unix") file.symlink(fbin, "FVSbin") else - file.copy(paste0(normalizePath(curdir),"/FVSbin"), getwd(), recursive = TRUE, - copy.mode = TRUE, copy.date = TRUE) - } - idrow = grep("title=",prjid) - if (length(idrow)==0) prjid=c(prjid,ntit) else prjid[idrow]=ntit -cat ("new project dir=",getwd()," prjid=",prjid,"\n") - write(file="projectId.txt",prjid) - updateTextInput(session=session, inputId="PrjNewTitle",value="") - setwd(curdir) - file.copy(from="app.R",to=paste0(normalizePath(newdir),"/app.R")) - globals$lastNewPrj=newTitle - updateProjectSelections() - }) - }) - ## PrjOpen - observe(if (length(input$PrjOpen) && input$PrjOpen > 0) - { - isolate({ - newPrj=paste0("../",input$PrjSelect) - plk = file.exists(paste0(newPrj,"/projectIsLocked.txt")) -cat("PrjOpen to=",newPrj," dir.exists(newPrj)=",dir.exists(newPrj), -" locked=",plk,"\n") - if (plk) {updateProjectSelections();return()} - if (dir.exists(newPrj)) - { - if (isLocal()) - { - rscript = if (exists("RscriptLocation")) RscriptLocation else - { - exefile=normalizePath(commandArgs(trailingOnly=FALSE)[1]) - bin = if(.Platform$OS.type == "windows") - regexpr("\\\\bin\\\\",exefile) else regexpr("/bin/",exefile) - bin = substr(exefile,1,bin+attr(bin,"match.length")-2) - if(.Platform$OS.type == "windows") - file.path(bin,"Rscript.exe") else file.path(bin,"Rscript") - } - rscript=gsub("\\\\","/",rscript) - defs=paste0("RscriptLocation='",rscript,"';") - if (exists("mdbToolsDir")) defs=paste0(defs,"mdbToolsDir='",mdbToolsDir,"';") - if (exists("sqlite3exe")) defs=paste0(defs,"sqlite3exe='",sqlite3exe,"';") -cat(".libPaths=",unlist(.libPaths()),"\n") - if (exists("RscriptLocation")) { - Rlib2Use <- paste0(dirname(dirname(dirname(RscriptLocation))),"/library") - defs=paste0(defs,".libPaths('",Rlib2Use,"');") - } - cmd = paste0("$",rscript,"$ --vanilla -e $",defs,"require(fvsOL)", - ";fvsOL(prjDir='",newPrj,"',fvsBin='",fvsBin,"');quit()$") - cmd = gsub('$','\"',cmd,fixed=TRUE) - if (.Platform$OS.type == "unix") cmd = paste0("nohup ",cmd," >> /dev/null") - rtn=try(system (cmd,wait=FALSE)) -cat ("cmd for launch project=",cmd,"\nrtn=",rtn,"\n") - } else { - url = paste0(session$clientData$url_protocol,"//", - session$clientData$url_hostname,"/FVSwork/",input$PrjSelect) -cat ("launch url:",url,"\n") - session$sendCustomMessage(type = "openURL",url) - } - Sys.sleep(5) - updateProjectSelections() - } - }) - }) - - ## Full run/Just groups - observe({ - mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") - updateSelectInput(session=session, inputId="simCont", - choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) - }) - - ## saveRun - saveRun <- function(input,session) - { - isolate({ - runName = trim(input$title) - if (nchar(input$title) == 0) runName <- nextRunName(names(globals$FVS_Runs)) - me=match(globals$fvsRun$uuid,globals$FVS_Runs) -cat ("saveRun, length(me)=",length(me)," uuid=",globals$fvsRun$uuid," class(globals$fvsRun)=",class(globals$fvsRun),"\n") - if (length(me)==0 || is.na(me)) return() else runNames=names(globals$FVS_Runs)[-me] - runName=mkNameUnique(runName,runNames) - if (runName != input$title) updateTextInput(session=session, inputId="title", - value=runName) - globals$fvsRun$title = runName -cat ("in saveRun, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID," input$defMgmtID=",input$defMgmtID,"\n") - globals$fvsRun$defMgmtID = input$defMgmtID - globals$fvsRun$runScript = if (length(input$runScript)) input$runScript else "fvsRun" - if (globals$fvsRun$runScript == "fvsRun") globals$fvsRun$uiCustomRunOps = list() else - { - for (item in names(globals$fvsRun$uiCustomRunOps)) - globals$fvsRun$uiCustomRunOps[[item]] = input[[item]] - } -cat ("saveRun class(globals$fvsRun)=",class(globals$fvsRun),"\n") - # sometimes the class fvsRun is assigned to package ".GlobalEnv" and it - # should be the for this package. - if (attr(class(globals$fvsRun),"package")==".GlobalEnv") - attr(class(globals$fvsRun),"package") = "fvsOL" - storeFVSRun(dbGlb$prjDB,globals$fvsRun) - globals$FVS_Runs=getFVSRuns(dbGlb$prjDB) -cat ("saveRun, input$inVars=",input$inVars,"\n") - globals$lastRunVar = globals$activeVariants[1] -cat ("leaving saveRun, globals$lastRunVar=",globals$lastRunVar,"\n") - }) - } -} - +# The top of this file contains several objects loaded into the .GlobalEnv +# prior to the shinyApp call. + +#' Run fvsOL (FVS OnLine/OnLocal). +#' +#' @param prjDir the name of the directory containing an fvsOL project. +#' @param runUUID the uuid of the run that should be opened when the system starts, +#' if NULL or not found in the list of runs, it is ignored. +#' @param fvsBin the name of the directory containing the FVS load libraries for the platform +#' @param shiny.trace turns on tracing for shiny, see shiny documentation +#' @param logToConsole controls if the log is output to the console or the log file, +#' the default set by the interactive() function. +#' @return the shiny app. +#' @export +fvsOL <- function (prjDir=NULL,runUUID=NULL,fvsBin=NULL,shiny.trace=FALSE, + logToConsole=interactive()) +{ + require(stats) + require(utils) + if (!is.null(prjDir) && dir.exists(prjDir)) setwd(prjDir) + if (is.null(fvsBin) || !dir.exists(fvsBin)) + { + if (dir.exists("FVSbin")) fvsBin="FVSbin" else stop("fvsBin must be set") + } + fvsBin <<- fvsBin + runUUID <<- runUUID + logToConsole <<- logToConsole + + cat ("FVSOnline/OnLocal function fvsOL started.\n") + + addResourcePath("colourpicker-lib/js", + system.file("www/shared/colourpicker/js", package="colourpicker")) + addResourcePath("colourpicker-lib/css", + system.file("www/shared/colourpicker/css",package="colourpicker")) + addResourcePath("colourpicker-binding", + system.file("srcjs",package="colourpicker")) + addResourcePath("FVSlogo.png", + system.file("extdata","www/FVSlogo.png",package="fvsOL")) + addResourcePath("USDAFS.png", + system.file("extdata","www/USDAFS.png",package="fvsOL")) + addResourcePath("message-handler.js", + system.file("extdata","www/message-handler.js",package="fvsOL")) + if (!dir.exists ("www")) dir.create("www") + addResourcePath("www",file.path(".","www")) + + # set shiny.trace=TRUE for reactive tracing + options(shiny.maxRequestSize=10000*1024^2,shiny.trace=shiny.trace, + rgl.inShiny=TRUE,rgl.useNULL=TRUE) + + data (prms) + data (treeforms) + + cat ("Starting shinyApp.\n") + + shinyApp(FVSOnlineUI, FVSOnlineServer, options=list(launch.browser=TRUE)) +} + +mkfvsStd <- setRefClass("fvsStd", + fields = list(sid = "character", rep = "numeric", repwt = "numeric", + invyr = "character", grps = "list", cmps = "list",uuid="character")) + +mkfvsGrp <- setRefClass("fvsGrp", + fields = list(grp = "character", cmps = "list", uuid="character")) + +mkfvsCmp <- setRefClass("fvsCmp", + fields = list(kwds = "character", kwdName = "character", exten="character", + title="character", variant="character",uuid="character", atag="character", + reopn="character")) +# atag is always "c" if the component is a condition, "k" if it is a keyword +# component that is not attached to a specific component. If it is longer than 1 +# character it is the uuid of the related condition + +mkfvsRun <- setRefClass("fvsRun", + fields = list(stands = "list", grps = "list", simcnts = "list", + selsim = "list", FVSpgm = "character", title = "character", + startyr = "character", endyr = "character", cyclelen = "character", + cycleat = "character", refreshDB = "character", uuid="character", + defMgmtID = "character", autoOut = "list", runScript = "character" , + uiCustomRunOps = "list", startDisp = "character")) + +mkfvsOutData <- + setRefClass("fvsOutData", + fields = list(dbLoadData = "list", dbData = "data.frame", + dbVars = "character", browseVars = "character", + dbSelVars = "character", browseSelVars = "character", + runs = "character", plotSpecs = "list", + render = "data.frame")) + +mkGlobals <- setRefClass("globals", + fields = list(activeFVS = "list", activeVariants = "character", + activeExtens = "character", schedBoxYrLastUsed = "character", + extnsel = "character", kwdsel = "list", mgmtsel = "list", + mevsel = "list", mmodsel = "list", pastelist = "list",fvsBin="character", + pastelistShadow = "list", inData = "list", FVS_Runs = "list", + customCmps = "list", selStds = "character", currentCmdDefs="character", + schedBoxPkey = "character", currentCmdPkey = "character",GrpNum="numeric", + currentCndPkey = "character", winBuildFunction = "character",GenGrp="list", + existingCmps = "list",currentQuickPlot = "character", + currentEditCmp = "fvsCmp", NULLfvsCmp = "fvsCmp", saveOnExit= "logical", + customQueries = "list", fvsRun = "fvsRun", foundStand="integer", + reloadAppIsSet = "numeric", hostname= "character", toggleind="character", + selStandTableList = "list",kcpAppendConts = "list",opencond="numeric", + condKeyCntr="numeric",prevDBname="list",changeind="numeric", + lastRunVar="character",gFreeze="logical",importItems="list", + settingChoices="list",exploreChoices="list",simLvl="list",stdLvl="list", + 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", RepsDesign='logical')) + +isLocal <- function () Sys.getenv('SHINY_PORT') == "" + +# cbbPalette is used in the graphics +cbbPalette <- c("#FF0000","#009E73","#0072B2","#E69F00","#CC79A7","#0000FF", + "#D55E00","#8F7800","#D608FA","#009100","#CF2C73","#00989D", + "#00FF00","#BAF508","#202020","#6B6B6A","#56B4E9","#20D920") + +extnslist <- list( + "Base FVS system"="base", + "Cover Model"="cover", + "Full Establishment Model"="estb", + "Partial Establishment Model"="strp", + "Database Extension"="dbs", + "Economic Analysis Extension"="econ", + "Dwarf Mistletoe Impact Model"="mist", + "ORGANON in FVS"="organon", + "Fire and Fuels Extension"="fire", + "Climate-FVS Extension"="climate", + "WRD (Annosus Root Disease)"="ardwrd3", + "WRD (Armillaria Root Disease)"="armwrd3", + "WRD (Laminated Root Rot)"="phewrd3") + +options(rgl.useNULL=TRUE) + +trim <- function (x) gsub("^\\s+|\\s+$","",x) + +defaultRun <- list("Default useful for all FVS variants"="fvsRun") + +# used in Tools, dlZipSet +zipList <- list( + "FVSProject data base (Runs, Custom components (kcp), Custom queries, GraphSettings)" = "fvsProjdb", + "Output data base for for all runs" = "outdb", + "Keyword file for current run" = "key", + "FVS output file for current run" = "out", + "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]) + +# if "runScripts.R" exists in the project directory, then use it, otherwise load +# the version that is part of the package software. +rsf <- "runScripts.R" +if (file.exists(rsf)) source(rsf) else source(system.file("extdata", rsf, + package="fvsOL")) +runScripts <- if (exists("customRunScripts") && length(customRunScripts)) + append(x=customRunScripts,after=0,defaultRun) else defaultRun + +customRunElements = list( + selectInput("runScript", + "Select run script (normally, use the default)", + choices=runScripts, + selected="fvsRun",multiple=FALSE,selectize=FALSE), + uiOutput("uiCustomRunOps")) + +FVSOnlineServer <- function(input, output, session) +{ +cat ("FVSOnline/OnLocal interface server start\n") + + # set serverDate to be the release date using packageVersion + serverDate=as.character(packageVersion("fvsOL")) + serverDate=unlist(strsplit(serverDate,".",fixed=TRUE)) + for (i in 2:3) if (nchar(serverDate[i])==1) serverDate[i]=paste0("0",serverDate[i]) + serverDate=paste0(serverDate,collapse="") + +cat ("ServerDate=",serverDate,"\n") + + if (!logToConsole) + { + if (file.exists("FVSOnline.log")) + { + unlink("FVSOnline.older.log") + file.rename("FVSOnline.log","FVSOnline.older.log") + } + #make sure the sink stack is empty + while (sink.number()) sink() + sink("FVSOnline.log") + } + +cat ("FVSOnline/OnLocal interface server start, serverDate=",serverDate,"\n") + + withProgress(session, + { + setProgress(message = "Start up", + detail = "Loading scripts and settings", value = 1) + + globals <- mkGlobals$new(saveOnExit=TRUE,reloadAppIsSet=0, + gFreeze=FALSE,fvsBin=fvsBin) + dbGlb <- new.env() + dbGlb$tbl <- NULL + dbGlb$navsOn <- FALSE + dbGlb$rowSelOn <- FALSE + dbGlb$disprows <- 20 + if (file.exists("projectIsLocked.txt")) + { +cat ("Project is locked.\n") + output$appLocked<-renderUI(HTML(paste0('

', + 'Warning: This project may already be opened.

', + '
Insure the project is not opened in another window.
', + '', + '    

'))) + } else cat (file="projectIsLocked.txt",date(),"\n") + setProgress(message = "Start up",value = 2) + + nruns = mkFVSProjectDB() + dbGlb$prjDB = connectFVSProjectDB() + + if (nruns==0) + { + globals$fvsRun <- mkfvsRun$new(uuid=uuidgen(),title="Run 1",defMgmtID="A001") + resetGlobals(globals,FALSE) + storeFVSRun(dbGlb$prjDB,globals$fvsRun) + } + globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) + #update a couple of list buttons with the list of tables + xlsxFile=system.file("extdata", "databaseDescription.xlsx", + package="fvsOL") + if (file.exists(xlsxFile)) + { + if ("OutputTableDescriptions" %in% getSheetNames(xlsxFile)) + { + tabs = read.xlsx(xlsxFile=xlsxFile,sheet="OutputTableDescriptions")[,1] + tableList <- sort(c("",tabs)) + metr=grep("Metric",tableList,ignore.case=TRUE) + if (length(metr)) + { + metric = tableList[metr] + tableList=c(tableList[-metr],metric) + } + tableList = as.list(tableList) + } + updateSelectInput(session=session, inputId="tabDescSel2",choices=tableList, + select=tableList[[1]]) + updateSelectInput(session=session, inputId="tabDescSel",,choices=tableList, + select=tableList[[1]]) + } + + setProgress(message = "Start up", + detail = "Loading interface elements", value = 3) + + serverDateOut = if (tolower(basename(dirname(system.file(package="fvsOL")))) == "r-dev") + { + if (isLocal()) + paste0('Dev OnLocal ',serverDate,"
") else + paste0('Development ',serverDate,"
") + } else { + paste0(paste0("Release date: ",serverDate,"
"),if (isLocal()) " Local" else " Online"," configuration
") + } + hostedByLogo=system.file("extdata","www/hostedByLogo.png", + package="fvsOL") +cat ("hostedByLogo=",hostedByLogo," serverDateOut=",serverDateOut,"\n") + if (file.exists(hostedByLogo)) + { + addResourcePath("hostedByLogo.png",hostedByLogo) + serverDateOut = paste0(serverDateOut,"Hosted by
",'
') + } + output$serverDate=renderUI(HTML(serverDateOut)) + tit=NULL + pfexists = file.exists("projectId.txt") + if (!pfexists || (pfexists && file.size("projectId.txt") < 2)) + cat("title= ",basename(getwd()),"\n",file="projectId.txt") + prjid = scan("projectId.txt",what="",sep="\n",quiet=TRUE) + tit=prjid[grep("^title",prjid)] + tit=trim(unlist(strsplit(tit,split="=",fixed=TRUE))[2]) + email=prjid[grep("^email",prjid)] + email=trim(unlist(strsplit(email,split="=",fixed=TRUE))[2]) + tstring = paste0("Project title: ",tit,"", + if (length(email)) paste0("
Email: ",email,"") else "", + "
Last accessed: ", + format(file.info(getwd())[1,"mtime"],"%a %b %d %H:%M:%S %Y"),"") +cat ("tstring=",tstring,"\n") + output$projectTitle = renderText(HTML(tstring)) + mkSimCnts(globals$fvsRun,sels=globals$fvsRun$selsim) + resetGlobals(globals,TRUE) + selChoices = globals$FVS_Runs +cat ("Setting initial selections, length(selChoices)=",length(selChoices),"\n") + runUUID = if (!is.null(runUUID) && runUUID %in% selChoices) runUUID else selChoices[[1]] + updateSelectInput(session=session, inputId="runSel", + choices=selChoices,selected=runUUID) + updateTextInput(session=session, inputId="title", value=names(selChoices[1])) + if (exists("fvsOutData")) rm (fvsOutData) + fvsOutData <- mkfvsOutData$new(plotSpecs=list(res=144,height=4,width=6)) + + dbDrv <- dbDriver("SQLite") + dbGlb$dbOcon <- dbConnect(dbDrv,"FVSOut.db") + + loadObject(dbGlb$prjDB,"stdstkParms") + if (exists("stdstkParms")) + { + val = stdstkParms$sdskwdbh + if (!is.na(val)) updateNumericInput(session=session,inputId="sdskwdbh", + value=val) + val = stdstkParms$sdskldbh + if (!is.na(val)) updateNumericInput(session=session, inputId="sdskldbh", + value=val) + } + + # the default SpatialData is distributed with the package, install it if it + # is not in the project directory. + if (!file.exists("FVS_Data.db") || file.size("FVS_Data.db")==0) + { + frm=system.file("extdata", "FVS_Data.db.default", package="fvsOL") + file.copy(frm,"FVS_Data.db",overwrite=TRUE) + frm=system.file("extdata", "SpatialData.RData.default",package=sub("package:","",find('fvsOL')[1])) + file.copy(frm,"SpatialData.RData",overwrite=TRUE) + } + globals$changeind <- 0 + output$contChange <- renderUI("Run") + dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") + globals$exploring <- FALSE + + setProgress(value = NULL) + }, min=1, max=6) + observe({ +cat ("protocol: ", session$clientData$url_protocol, "\n", + "hostname: ", session$clientData$url_hostname, "\n", + "pathname: ", session$clientData$url_pathname, "\n", + "port: ", session$clientData$url_port, "\n", + "search: ", session$clientData$url_search, "\n") + globals$hostname = session$clientData$url_hostname +cat("signalClosing=",input$signalClosing,"\n") + if (!is.null(input$signalClosing) && input$signalClosing==1 && + globals$reloadAppIsSet == 0 && globals$hostname == "127.0.0.1") + { +cat ("sending closeWindow\n") + session$sendCustomMessage(type = "closeWindow"," ") + } + }) + + session$onSessionEnded(function () + { +cat ("onSessionEnded, globals$saveOnExit=",globals$saveOnExit, + " interactive()=",interactive(),"\n", + "globals$reloadAppIsSet=",globals$reloadAppIsSet, + " globals$hostname=",globals$hostname,"\n") + if (exists("dbOcon",envir=dbGlb,inherit=FALSE)) try(dbDisconnect(dbGlb$dbOcon)) + if (exists("dbIcon",envir=dbGlb,inherit=FALSE)) try(dbDisconnect(dbGlb$dbIcon)) + if (length(globals$importItems)) + { + if (attr(globals$importItems,"temp")) unlink(attr(globals$importItems,"dir"),recursive = TRUE) + globals$importItems=list() + } + + if (globals$saveOnExit) + { + saveRun(input,session) + FVS_Runs = globals$FVS_Runs + stdstkParms = isolate(list("sdskwdbh"=input$sdskwdbh, + "sdskldbh"=input$sdskldbh)) + storeOrUpdateObject(dbGlb$prjDB,stdstkParms) + prjIdTxt = "projectId.txt" + if (file.exists(prjIdTxt)) # this is done to update the modification time. + { + prjid = scan(prjIdTxt,what="character",sep="\n",quiet=TRUE) + write(file=prjIdTxt,prjid) + } + } + unlink ("projectIsLocked.txt") + # remove excess images that may be created in Maps. + delList = dir ("www",pattern="*png$",full.names=TRUE) + if (length(delList)) lapply(delList,function(x) unlink(x)) + #note: the stopApp function returns to the R process that called shinyApp() + if (globals$reloadAppIsSet == 0) stopApp() + globals$reloadAppIsSet == 0 + }) + + ## clearLock + observe({ + if (!is.null(input$clearLock) && input$clearLock==0) + { + withProgress(session, { + for (i in 1:5) + { + setProgress(message = "5 second delay ", + detail = paste(i,"of 5"), value = i) + Sys.sleep(1) + } + setProgress(value = NULL) + }, min=1, max=10) + } + }) + + ## exitNow + observe({ + if (!is.null(input$exitNow) && input$exitNow>0) + { +cat ("exit now\n") + globals$saveOnExit=FALSE + session$sendCustomMessage(type = "closeWindow"," ") + } + }) + ## remake the lock file. + observe({ + if (!is.null(input$clearLock) && input$clearLock>0) + { + output$appLocked<-NULL + # remake the lock file. + cat (file="projectIsLocked.txt",date(),"\n") + } + }) + + ## changeind + observe({ + cat ("changeind=",globals$changeind,"\n") + if (globals$changeind == 0){ + output$contChange <- renderUI("Run") + output$srtYr <-renderUI({ + HTML(paste0("",input$startyr,"")) + }) + output$eYr <-renderUI({ + HTML(paste0("",input$endyr,"")) + }) + output$cyLen <-renderUI({ + HTML(paste0("",input$cyclelen,"")) + }) + output$cyAt <-renderUI({ + HTML(paste0("",input$cycleat,"")) + }) + } + }) + + ## Load + observe({ + if (input$topPan == "View Outputs" && input$leftPan == "Load") + { + globals$selAllVars=FALSE + globals$tableMessage=FALSE +cat ("View Outputs & Load\n") + initTableGraphTools(globals,session,output,fvsOutData) + output$table <- renderTable(NULL) + tbs <- myListTables(dbGlb$dbOcon) + if (length(tbs) > 0 && !is.na(match("FVS_Cases",tbs))) + { + runsdf = dbGetQuery(dbGlb$dbOcon, + paste0("Select RunTitle,KeywordFile from FVS_Cases group by KeywordFile ", + "having min(RunDateTime) order by RunDateTime desc;")) + fvsOutData$runs = runsdf$KeywordFile + names(fvsOutData$runs) = runsdf$RunTitle + } + updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) + } + }) + + ## runs output run selection + observeEvent((input$leftPan == "Load" && !is.null(input$runs)), { + if (input$leftPan != "Load") return() +cat ("runs, run selection (load) input$runs=",input$runs,"\n") + if (!is.null(input$runs) && !length(globals$tbsFinal) && !globals$exploring) # will be a list of run keywordfile names (uuid's) + { + tbs <- myListTables(dbGlb$dbOcon) +cat ("tbs related to the run",tbs,"\n") + if (length(tbs) == 0) + { + updateSelectInput(session, "selectdbtables", choices=list()) + return() + } + withProgress(session, { + i = 1 + setProgress(message = "Please wait: Performing output query", + detail = "Selecting tables", value = i); i = i+1 + # set an exclusive lock on the database + dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = EXCLUSIVE") + trycnt=0 + while (TRUE) + { + trycnt=trycnt+1 + setProgress(message = "Please wait: Getting exclusive lock", + detail = paste0("Number of attempts=",trycnt," of 1000")) + if (trycnt > 1000) + { + dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") + myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active + setProgress(value = NULL) + return() + } +cat ("try to get exclusive lock, trycnt=",trycnt,"\n"); + rtn <- try(dbExecute(dbGlb$dbOcon,"create table dummy (dummy int)")) + if (class(rtn) != "try-error") break; + Sys.sleep (10) + } +cat ("have exclusive lock\n") + dbExecute(dbGlb$dbOcon,"drop table if exists dummy") + # create a temp.Cases table that is a list of CaseIDs + # associated with the selected runs. These two items are used to + # filter records selected from selected tables. + qry = paste0("create table temp.Cases as select _RowID_,CaseID,Variant ", + "from FVS_Cases where FVS_Cases.KeywordFile in ", + paste0("('",paste(input$runs,collapse="','"),"')")) +cat("qry=",qry,"\n") + dbExecute(dbGlb$dbOcon,"drop table if exists temp.Cases") + rtn = dbExecute(dbGlb$dbOcon,qry) +cat("rtn from create temp.Cases=",rtn,"\n") + ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] +cat ("ncases=",ncases,"\n") + bagit=ncases==0 + isMetric=FALSE + if (!bagit) + { + variantsRun = tolower(dbGetQuery(dbGlb$dbOcon, + "select distinct Variant from temp.Cases;")[,1]) + metricVars = c("bc","on") + isMetric = length(intersect(variantsRun,metricVars)) > 0 + # can not have metric and non-metric variants + bagit = isMetric && length(setdiff(variantsRun,metricVars)) + } + if (bagit) + { + updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) + dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") + myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active + setProgress(value = NULL) + return() + } + for (tb in tbs) + { + cat(tbs) +cat ("tb=",tb,"\n") + cnt = 0 + if (tb == "FVS_Cases") next + if (tb %in% c("CmpSummary","CmpSummary_East", "CmpSummary2", + "CmpSummary2_East","CmpSummary2_Metric", "StdStk","CmpStdStk", + "StdStk_East","CmpStdStk_East","StdStk_Metric","CmpStdStk_Metric", + "CmpMetaData","CmpCompute", "CmpCalibStats")) + { +cat ("drop tb=",tb,"\n") + dbExecute(dbGlb$dbOcon,paste0("drop table if exists ",tb)) + } else { + qry = paste0("select count(*) from ", + "(select CaseID from ",tb," where ",tb,".CaseID in ", + "(select CaseID from temp.Cases))") +cat("qry=",qry,"\n") + cnt = if ("CaseID" %in% dbListFields(dbGlb$dbOcon,tb)) + dbGetQuery(dbGlb$dbOcon,qry) else -1 + cnt = if (class(cnt)=="data.frame") cnt[1,1] else -1 +cat ("tb=",tb," cnt=",cnt,"\n") + } + if (cnt == 0) tbs = setdiff(tbs,tb) + } + source(system.file("extdata", if (isMetric) "sqlQueries_Metric.R" else "sqlQueries.R", + package="fvsOL")) + if (!exqury(dbGlb$dbOcon,Create_CmpMetaData)) + { + updateSelectInput(session, "runs", choices = fvsOutData$runs, selected=0) + dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") + myListTables(dbGlb$dbOcon) #any query will cause the locking mode to become active + setProgress(value = NULL) + return() + } + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) + if (!isMetric) + { + if ("FVS_Summary" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpSummary", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpSummary) + tbs = c(tbs,"CmpSummary") +cat ("tbs1=",tbs,"\n") + } + if ("FVS_Summary_East" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpSummary_East", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpSummary_East) + tbs = c(tbs,"CmpSummary_East") +cat ("tbs2=",tbs,"\n") + } + if ("FVS_Summary2" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpSummary2", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpSummary2) + tbs = c(tbs,"CmpSummary2") +cat ("tbs3=",tbs,"\n") + } + if ("FVS_Summary2_East" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpSummary2_East", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpSummary2_East) + tbs = c(tbs,"CmpSummary2_East") +cat ("tbs4=",tbs,"\n") + } + } else { + if ("FVS_Summary2_Metric" %in% tbs && exists("Create_CmpSummary2")) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpSummary2_Metric", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpSummary2) + tbs = c(tbs,"CmpSummary2_Metric") +cat ("tbs5=",tbs,"\n") + } + } + if ("FVS_Compute" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpCompute", value = i); i = i+1 + cmp = dbGetQuery(dbGlb$dbOcon, + "select * from FVS_Compute limit 0") + sumExpressions = paste0( + lapply(setdiff(colnames(cmp),c("CaseID","StandID","Year")), + function (var) paste0("round(sum(",var, + "*SamplingWT)/sum(SamplingWt),2) as Cmp",var)),collapse=",") + exqury(dbGlb$dbOcon,Create_CmpCompute,subExpression=sumExpressions) + cmp = dbGetQuery(dbGlb$dbOcon,"Select * from CmpCompute;") + keep = apply(cmp,2,function (x) !(all(is.na(x)))) + if (!all(keep)) + { + cmp = cmp[,keep] + dbWriteTable(dbGlb$dbOcon,"CmpCompute",cmp,overwrite=TRUE) + } + tbs = c(tbs,"CmpCompute") +cat ("tbs6=",tbs,"\n") + } + if ("FVS_CalibStats" %in% tbs && ncases > 1) + { + setProgress(message = "Please wait: performing output query", + detail = "Building CmpCalibStats", value = i); i = i+1 + exqury(dbGlb$dbOcon,Create_CmpCalibStats,asSpecies=paste0("Species",input$spCodes)) + cmp = dbGetQuery(dbGlb$dbOcon,"Select * from CmpCalibStats;") + keep = apply(cmp,2,function (x) !(all(is.na(x)))) + if (!all(keep)) + { + cmp = cmp[,keep] + dbWriteTable(dbGlb$dbOcon,"CmpCalibStats",cmp,overwrite=TRUE) + } + tbs = c(tbs,"CmpCalibStats") +cat ("tbs6=",tbs,"\n") + } + tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) + if (!isMetric && any(tlprocs)) + { + tlprocs = names(tlprocs)[tlprocs] + chtoEast = function(cmd) + { + cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) + cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) + cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) + gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) + } + for (tlp in tlprocs) + { + if (tlp == "tlwest") + { + C_StdStkDBHSp = Create_StdStkDBHSp + C_HrvStdStk = Create_HrvStdStk + C_StdStk1Hrv = Create_StdStk1Hrv + C_StdStk1NoHrv = Create_StdStk1NoHrv + C_StdStkFinal = Create_StdStkFinal + C_CmpStdStk = Create_CmpStdStk + detail = "Building StdStk from tree lists" + stdstk = "StdStk" + clname = "FVS_CutList" + } else { + C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) + C_HrvStdStk = chtoEast(Create_HrvStdStk ) + C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) + C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) + C_StdStkFinal = chtoEast(Create_StdStkFinal ) + C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) + C_CmpStdStk = chtoEast(Create_CmpStdStk ) + C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) + C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) + detail = "Building StdStk_East from tree lists" + stdstk = "StdStk_East" + clname = "FVS_CutList_East" + } + setProgress(message = "Please wait: performing output query", + detail = detail, value = i); i = i+1 + exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + if (clname %in% tbs) + { + setProgress(message = "Please wait: performing output query", + detail = detail, value = i); i = i+1 + exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + setProgress(message = "Please wait: performing output query", + detail = "Joining tables", value = i); i = i+1 + exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } else { + setProgress(message = "Please wait: performing output query", + detail = "Joining tables", value = i); i = i+2 + exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } + exqury(dbGlb$dbOcon,C_StdStkFinal) + tbs = c(tbs,stdstk) + if (ncases > 1) + { + exqury(dbGlb$dbOcon,C_CmpStdStk) + tbs = c(tbs,paste0("Cmp",stdstk)) + } + } + } + if ("FVS_TreeList_Metric" %in% tbs) + { + asSpecies=paste0("Species",input$spCodes) + setProgress(message = "Please wait: performing output query", detail = "Building StdStk", value = i); i = i+1 + if ("FVS_CutList_Metric" %in% tbs) exqury(dbGlb$dbOcon,Create_HrvStdStk, + subExpression=dbhclassexp, asSpecies=asSpecies) + exqury(dbGlb$dbOcon,Create_StdStkDBHSp,subExpression=dbhclassexp,asSpecies=asSpecies) + exqury(dbGlb$dbOcon,Create_StdStk1NoHrv,subExpression=dbhclassexp,asSpecies=asSpecies) + exqury(dbGlb$dbOcon,Create_StdStkFinal) + tbs = c(tbs,"StdStk_Metric") + if (ncases > 1) + { + exqury(dbGlb$dbOcon,Create_CmpStdStk) + tbs = c(tbs,"CmpStdStk_Metric") + } + } + if (all(Create_View_DWN_Required %in% tbs)) + { + exqury(dbGlb$dbOcon,Create_View_DWN) + tbs = c(tbs,"View_DWN") + } + dbExecute(dbGlb$dbOcon,"PRAGMA locking_mode = NORMAL") +cat ("tbs7=",tbs,"\n") + setProgress(message = "Please wait: performing output query", + detail = "Committing changes", value = i); i = i+1 + dbd = lapply(tbs,function(tb,con) dbListFields(con,tb), dbGlb$dbOcon) + names(dbd) = tbs + if (!is.null(dbd[["FVS_Summary"]])) dbd$FVS_Summary = c(dbd$FVS_Summary, + c("TPrdTpa","TPrdTCuFt","TPrdMCuFt","TPrdBdFt")) + if (!is.null(dbd[["FVS_Summary_East"]])) dbd$FVS_Summary_East = + c(dbd$FVS_Summary_East,c("TPrdTpa","TPrdMCuFt","TPrdSCuFt","TPrdSBdFt")) + if (!is.null(dbd[["CmpSummary"]])) dbd$CmpSummary = c(dbd$CmpSummary, + c("CmpTPrdTpa","CmpTPrdTCuFt","CmpTPrdMCuFt","CmpTPrdBdFt")) + if (!is.null(dbd[["CmpSummary_East"]])) dbd$CmpSummary = c(dbd$CmpSummary_East, + c("CmpTPrdTpa","CmpTPrdTCuFt","CmpTPrdMCuFt","CmpTPrdBdFt")) + if (length(dbd)) fvsOutData$dbLoadData <- dbd + sel = intersect(tbs, c("FVS_Summary2","FVS_Summary2_East")) #not both! + if (length(sel)==0) sel = intersect(tbs, c("FVS_Summary","FVS_Summary_East")) #not both! + if (length(sel)>1) sel = sel[1] + # rearrange the table list so be organized by levels (i.e., tree level, stand level) + globals$simLvl <- list("CmpCompute","CmpCalibStats","CmpStdStk","CmpStdStk_East","CmpStdStk_Metric", + "CmpSummary","CmpSummary_East","CmpSummary_Metric", + "CmpSummary2","CmpSummary2_East","CmpSummary2_Metric","CmpMetaData") + globals$stdLvl <- list("FVS_Climate","FVS_Compute","FVS_EconSummary","FVS_BurnReport","FVS_Carbon", + "FVS_Down_Wood_Cov","FVS_Down_Wood_Vol","FVS_Consumption","FVS_Hrv_Carbon", + "FVS_PotFire","FVS_PotFire_Cond","FVS_PotFire_East","FVS_SnagSum","FVS_Fuels", + "FVS_DM_Stnd_Sum","FVS_Regen_Sprouts","FVS_Regen_SitePrep","FVS_Regen_HabType", + "FVS_Regen_Tally","FVS_Regen_Ingrow","FVS_RD_Sum","FVS_RD_Det","FVS_RD_Beetle", + "FVS_Stats_Stand","FVS_StrClass","FVS_Summary2","FVS_Summary2_East","FVS_Summary2_Metric", + "FVS_Summary","FVS_Summary_East","View_DWN","FVS_DM_Stnd_Sum_Metric") + globals$specLvl <- list("FVS_CalibStats","FVS_EconHarvestValue","FVS_Stats_Species", + "FVS_DM_Spp_Sum","FVS_DM_Spp_Sum_Metric") + globals$dClsLvl <- list("StdStk","StdStk_East","StdStk_Metric","FVS_Mortality","FVS_DM_Sz_Sum", + "FVS_DM_Sz_Sum_Metric") + globals$htClsLvl <- list("FVS_CanProfile") + globals$treeLvl <- list("FVS_ATRTList","FVS_CutList","FVS_SnagDet","FVS_TreeList", + "FVS_TreeList_East","FVS_CutList_East","FVS_ATRTList_East", + "FVS_TreeList_Metric","FVS_CutList_Metric","FVS_ATRTList_Metric", + "FVS_DM_Treelist","FVS_DM_Treelist_Metric") + globals$tbsFinal <- list("FVS_Cases") + tbsFinal <- globals$tbsFinal + if (any(tbs %in% globals$simLvl)) { + tbsFinal <- c(tbsFinal,"-----Composite tables-----") + simLvlIdx <- subset(match(globals$simLvl,tbs),match(globals$simLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[simLvlIdx])) + } + if (any(tbs %in% globals$stdLvl)) { + tbsFinal = c(tbsFinal,"-----Stand-level tables-----") + stdLvlIdx <- subset(match(globals$stdLvl,tbs),match(globals$stdLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[stdLvlIdx])) + } + if (any(tbs %in% globals$specLvl)) { + tbsFinal = c(tbsFinal,"-----Species-level tables-----") + specLvlIdx <- subset(match(globals$specLvl,tbs),match(globals$specLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[specLvlIdx])) + } + if (any(tbs %in% globals$dClsLvl)) { + tbsFinal = c(tbsFinal,"-----Diameter-class tables-----") + dClsLvlIdx <- subset(match(globals$dClsLvl,tbs),match(globals$dClsLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[dClsLvlIdx])) + } + if (any(tbs %in% globals$htClsLvl)) { + tbsFinal = c(tbsFinal,"-----Height-class tables-----") + htClsLvlIdx <- subset(match(globals$htClsLvl,tbs),match(globals$htClsLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[htClsLvlIdx])) + } + if (any(tbs %in% globals$treeLvl)) { + tbsFinal = c(tbsFinal,"-----Tree-level tables-----") + treeLvlIdx <- subset(match(globals$treeLvl,tbs),match(globals$treeLvl,tbs) != "NA") + tbsFinal <- c(tbsFinal,sort(tbs[treeLvlIdx])) + } + othTbs = setdiff(tbs,tbsFinal) + if (length(othTbs)) { + tbsFinal = c(tbsFinal,"-----Other tables-----") + tbsFinal <- c(tbsFinal,othTbs) + } + globals$tbsFinal <- tbsFinal + if(is.null(input$selectdbtables)){ + updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), + selected="FVS_Cases") + } else if(globals$tableMessage) { + updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), + selected=input$selectdbtables[1]) + globals$tableMessage=FALSE + } else { + updateSelectInput(session, "selectdbtables", choices=as.list(tbsFinal), + selected=input$selectdbtables) + } + globals$tbsFinal <- list() + setProgress(value = NULL) + }, min=1, max=6) + } else + { + updateSelectInput(session, "selectdbtables", choices=list()) + globals$exploring <- FALSE + } + }) + + ## bldstdsk + observeEvent(input$bldstdsk,{ + tbs <- myListTables(dbGlb$dbOcon) +cat ("tbs related to the run",tbs,"\n") + if (length(tbs) == 0) + { + updateSelectInput(session, "selectdbtables", choices=list()) + return() + } + dbhclassexp <- mkdbhCase(input$sdskwdbh,input$sdskldbh) + tlprocs = c("tlwest"="FVS_TreeList" %in% tbs, "tleast"="FVS_TreeList_East" %in% tbs) + if (any(tlprocs)) + { + tlprocs = names(tlprocs)[tlprocs] + chtoEast = function(cmd) + { + cmd = gsub("BdFt", "SBdFt",cmd,fixed=TRUE) + cmd = gsub("TCuFt","SCuFt",cmd,fixed=TRUE) + cmd = gsub("FVS_TreeList","FVS_TreeList_East",cmd,fixed=TRUE) + gsub("FVS_CutList","FVS_CutList_East",cmd,fixed=TRUE) + } + for (tlp in tlprocs) + { + if (tlp == "tlwest") + { + C_StdStkDBHSp = Create_StdStkDBHSp + C_HrvStdStk = Create_HrvStdStk + C_StdStk1Hrv = Create_StdStk1Hrv + C_StdStk1NoHrv = Create_StdStk1NoHrv + C_StdStkFinal = Create_StdStkFinal + C_CmpStdStk = Create_CmpStdStk + detail = "Building StdStk from tree lists" + stdstk = "StdStk" + clname = "FVS_CutList" + } else { + C_StdStkDBHSp = chtoEast(Create_StdStkDBHSp ) + C_HrvStdStk = chtoEast(Create_HrvStdStk ) + C_StdStk1Hrv = chtoEast(Create_StdStk1Hrv ) + C_StdStk1NoHrv = chtoEast(Create_StdStk1NoHrv) + C_StdStkFinal = chtoEast(Create_StdStkFinal ) + C_StdStkFinal = gsub(" StdStk"," StdStk_East",C_StdStkFinal) + C_CmpStdStk = chtoEast(Create_CmpStdStk ) + C_CmpStdStk = gsub(" CmpStdStk"," CmpStdStk_East",C_CmpStdStk) + C_CmpStdStk = gsub(" StdStk "," StdStk_East ",C_CmpStdStk) + detail = "Building StdStk_East from tree lists" + stdstk = "StdStk_East" + clname = "FVS_CutList_East" + } + exqury(dbGlb$dbOcon,C_StdStkDBHSp,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + if (clname %in% tbs) + { + exqury(dbGlb$dbOcon,C_HrvStdStk,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + exqury(dbGlb$dbOcon,C_StdStk1Hrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } else { + exqury(dbGlb$dbOcon,C_StdStk1NoHrv,subExpression=dbhclassexp, + asSpecies=paste0("Species",input$spCodes)) + } + exqury(dbGlb$dbOcon,C_StdStkFinal) + ncases = dbGetQuery(dbGlb$dbOcon, "select count(*) from temp.Cases;")[1,1] + if (ncases > 1) exqury(dbGlb$dbOcon,C_CmpStdStk) + } + } + }) + + ## selectdbtables + observe({ +cat("selectdbtables\n") + if (is.null(input$selectdbtables) ||(length(input$selectdbtables)==1 + && length(grep("-----",input$selectdbtables)))) + { + updateSelectInput(session, "selectdbvars", choices=list()) + } else { + tables = input$selectdbtables + if(length(grep("-----",tables))) tables <- setdiff(tables,tables[grep("-----",tables)]) + # Logic to restrict combining tables from different levels (e.g., tree with stand-level). + # Throw up warning, then have first table selection in level that threw error remain selected + while(length(tables)>1) + { + if(length(tables)==2 && "FVS_Cases" %in% tables) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary")) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary_East")) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary_Metric")) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2")) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2_East")) break + if(length(tables)==2 && (tables[1] == "CmpCompute" && tables[2] == "CmpSummary2_Metric")) break + '%notin%' = Negate('%in%') + if (any(tables %in% globals$simLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("This composite table combination in not allowed")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + if (any(tables %in% globals$stdLvl) && any(tables %notin% globals$stdLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("Stand-level tables can only be combined with other stand-level tables")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + if (any(tables %in% globals$specLvl) && any(tables %notin% globals$specLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("Species-level tables can only be combined with other species-level tables")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + # DBH-class tables cannot be combined with any other table + if (any(tables %in% globals$dClsLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("DBH-class tables cannot be combined with any other tables")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + # HT-class tables cannot be combined with any other table + if (any(tables %in% globals$htClsLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("HT-class tables cannot be combined with any other tables")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + # tree-level tables cannot be combined with any other table + if (any(tables %in% globals$treeLvl)) { + session$sendCustomMessage(type = "infomessage", + message = paste0("Tree-level tables cannot be combined with any other tables")) + tables <- tables[1] + globals$tableMessage=TRUE + updateSelectInput(session, "selectdbtables", choices=as.list(globals$tbsFinal), + selected=tables) + } + break + } + vars = lapply(tables,function (tb,dbd) paste0(tb,".",dbd[[tb]]),fvsOutData$dbLoadData) + vars = unlist(vars) + if (length(vars) == 0) return() + fvsOutData$dbVars <- vars + fvsOutData$dbSelVars <- vars + updateSelectInput(session=session, "selectdbvars",choices=as.list(vars), + selected=vars) + output$tbSel <-renderUI({ + HTML(tables) + }) + } + }) + + ## selectdbvars + observe({ +cat("selectdbvars\n") + if (!is.null(input$selectdbvars)) + { + # if CaseID is part of the variable set, make sure it is selected at least once + selidxCaseID=grep("CaseID",input$selectdbvars) + if (!length(selidxCaseID)) + { + idxCaseID=grep("CaseID",fvsOutData$dbVars) + if (length(idxCaseID)) + { + selvars=union(fvsOutData$dbVars[idxCaseID[1]],input$selectdbvars) + updateSelectInput(session=session, "selectdbvars",choices=as.list(fvsOutData$dbVars), + selected=selvars) + } + } + fvsOutData$dbSelVars <- input$selectdbvars +cat ("input$selectdbvars=",input$selectdbvars,"\n") + } + }) + + ## Custom Query + observe({ + if (input$leftPan == "Custom Query") + { +cat("Custom Query\n") + initTableGraphTools(globals,session,output,fvsOutData) + if (length(globals$customQueries) == 0) + { + loadObject(dbGlb$prjDB,"customQueries") + if (exists("customQueries")) globals$customQueries=customQueries + } + if (length(globals$customQueries) == 0) + { + updateSelectInput(session=session, inputId="sqlSel", + choices=list(),selected=0) + } else { + sels = as.list(as.character(1:length(globals$customQueries))) + names(sels) = names(globals$customQueries) + updateSelectInput(session=session, inputId="sqlSel", choices=sels, + selected = 0) + } + updateTextInput(session=session, inputId="sqlTitle", value="") + updateTextInput(session=session, inputId="sqlQuery", value="") + updateTextInput(session=session, inputId="sqlOutput", label="", value="") + output$table <- renderTable(NULL) + } + }) + + ## sqlRunQuery + observe({ + if (input$sqlRunQuery > 0) + { +cat ("sqlRunQuery\n") + isolate({ + msgtxt = character(0) + qrys = trim(gsub("\n"," ",removeComment(input$sqlQuery)," ",input$sqlQuery)) + qrys = scan(text=qrys,sep=";",what="",quote="",quiet=TRUE) + qrys = qrys[nchar(qrys)>0] + output$table <- renderTable(NULL) + iq = 0 + dfrtn = NULL + # attempt to attach the input database is attached as "input" + attInput = if (!dbGlb$dbIcon@dbname %in% dbGetQuery(dbGlb$dbOcon,"PRAGMA database_list")$file) + try(dbExecute(dbGlb$dbOcon,paste0("attach database '",dbGlb$dbIcon@dbname, + "' as input"))) else NULL + for (qry in qrys) + { + iq = iq+1 +cat ("sqlRunQuery, qry=",qry,"\n") + res = try (dbGetQuery(dbGlb$dbOcon,qry)) + msgtxt = if (class(res) == "data.frame" && ncol(res) && nrow(res)) + paste0(msgtxt,"query ",iq," returned a data frame with ",nrow(res), + " rows and ",ncol(res)," cols\n") else + if (class(res) == "try-error") paste0(msgtxt,"query ",iq, + " returned\n",attr(res,"condition"),"\n") else + paste0(msgtxt,"query ",iq," ran\n") + updateTextInput(session=session, inputId="sqlOutput", label="", + value=msgtxt) + if (class(res) == "try-error") break + if (class(res) == "data.frame" && ncol(res) && nrow(res)) + { + for (col in 1:ncol(res)) if (class(res[[col]]) == "character") + res[[col]] = factor(res[[col]],unique(res[[col]])) + if (!is.null(res$Year)) res$Year = as.factor(res$Year) + fvsOutData$dbData = res + fvsOutData$render = res + fvsOutData$runs = character(0) + fvsOutData$dbVars = colnames(res) + fvsOutData$browseVars = colnames(res) + fvsOutData$dbSelVars = character(0) + fvsOutData$browseSelVars = colnames(res) + choices = as.list(c("None", + colnames(res)[unlist(lapply(res, is.factor))])) + updateSelectInput(session,"pivVar",choices=choices,selected="None") + updateSelectInput(session,"hfacet",choices=choices,selected="None") + updateSelectInput(session,"vfacet",choices=choices,selected="None") + updateSelectInput(session,"pltby", choices=choices,selected="None") + globals$settingChoices[["pivVar"]] = choices + globals$settingChoices[["hfacet"]] = choices + globals$settingChoices[["vfacet"]] = choices + globals$settingChoices[["pltby"]] = choices + choices = as.list(c("None", + colnames(res)[!unlist(lapply(res, is.factor))])) + globals$settingChoices[["dispVar"]] = choices + updateSelectInput(session,"dispVar",choices=choices,selected="None") + choices = as.list(colnames(res)) + globals$settingChoices[["xaxis"]] = choices + globals$settingChoices[["yaxis"]] = choices + updateSelectInput(session,"xaxis",choices=choices,selected=colnames(res)[1]) + updateSelectInput(session,"yaxis",choices=choices,selected=colnames(res)[1]) + if (input$outputRightPan != "Tables") + updateSelectInput(session,"outputRightPan",selected="Tables") + tableDisplayLimit = 5000 + if (nrow(res) > tableDisplayLimit) + { + msg=paste0("Table display limit exceeded. ", + tableDisplayLimit," of ",nrow(res)," displayed. Use Download table", + " to download all rows.") + output$tableLimitMsg<-renderText(msg) + res = res[1:tableDisplayLimit,,drop=FALSE] + } else output$tableLimitMsg<-NULL + output$table <- renderTable(res) + break + } + } + if (!is.null(attInput)) try(dbExecute(dbGlb$dbOcon,"detach database 'input'")) + }) + } + }) + +## sqlSave + observe({ + if (input$sqlSave > 0) + { +cat ("sqlSave\n") + isolate({ + if (is.null(input$sqlTitle) || input$sqlTitle == "") + { + newTit = paste0("Query ",length(globals$customQueries)+1) + updateTextInput(session=session, inputId="sqlTitle", value=newTit) + } else newTit = input$sqlTitle + globals$customQueries[[newTit]] = input$sqlQuery + customQueries = globals$customQueries + storeOrUpdateObject(dbGlb$prjDB,customQueries) + if (length(globals$customQueries) == 0) + { + updateSelectInput(session=session, inputId="sqlSel", + choices=list(),selected=0) + } else { + sels = as.list(as.character(1:length(globals$customQueries))) + names(sels) = names(globals$customQueries) + updateSelectInput(session=session, inputId="sqlSel", choices=sels, + selected = match(newTit,names(globals$customQueries))) + } + }) + } + }) + + ## sqlSel + observe({ +cat ("sqlSel input$sqlSel=",input$sqlSel," isnull=", + is.null(input$sqlSel),"\n") + updateTextInput(session=session, inputId="sqlTitle", value="") + updateTextInput(session=session, inputId="sqlOutput", value="") + updateTextInput(session=session, inputId="sqlQuery", value="") + output$table <- renderTable(NULL) + if (!is.null(input$sqlSel)) + { + sel = as.numeric(input$sqlSel) + if(is.na(sel)) sel = as.numeric(match(input$sqlSel,names(globals$customQueries))) +cat ("sqlSel sel=",sel,"\n") + if (length(globals$customQueries) >= sel || !is.null(sel)) + { + updateTextInput(session=session, inputId="sqlTitle", + value=names(globals$customQueries)[sel]) + updateTextInput(session=session, inputId="sqlQuery", + value=globals$customQueries[[sel]]) + } + } + }) + + ## sqlDelete + observe({ + if (input$sqlDelete > 0) + { + isolate ({ +cat ("sqlDelete is.null(input$sqlTitle)=",is.null(input$sqlTitle),"\n") + if (is.null(input$sqlTitle)) return() + globals$customQueries[[input$sqlTitle]] = NULL + customQueries = globals$customQueries + storeOrUpdateObject(dbGlb$prjDB,customQueries) + if (length(customQueries) > 0) + { + sels = as.list(as.character(1:length(globals$customQueries))) + names(sels) = names(globals$customQueries) + } else sels=list() + updateSelectInput(session=session, inputId="sqlSel", choices=sels, + selected = 0) + updateTextInput(session=session, inputId="sqlTitle", value="") + updateTextInput(session=session, inputId="sqlQuery", value="") + updateTextInput(session=session, inputId="sqlOutput", value="") + }) + } + }) + + ## sqlNew + observe({ + if (input$sqlNew > 0) + { +cat ("sqlNew\n") + updateSelectInput(session=session, inputId="sqlSel", selected = 0) + updateTextInput(session=session, inputId="sqlQuery", value="") + updateTextInput(session=session, inputId="sqlOutput", value="") + } + }) + + ## Explore + observe({ + if (input$leftPan == "Explore") + { + globals$exploring <- TRUE +cat ("Explore, length(fvsOutData$dbSelVars)=",length(fvsOutData$dbSelVars),"\n") + if (length(fvsOutData$dbSelVars) == 0) + { + initTableGraphTools(globals,session,output,fvsOutData) + output$table <- renderTable(NULL) + return() + } + withProgress(session, + { + iprg = 1 + setProgress(message = "Processing variable names", detail="", + value = iprg) + tbs = unique(unlist(lapply(strsplit(fvsOutData$dbSelVars,".",fixed=TRUE), + function (x) x[1]))) + if (length(tbs) == 0) return() + cols = unique(unlist(lapply(strsplit(fvsOutData$dbSelVars,".",fixed=TRUE), + function (x) x[2]))) + if (length(cols) == 0) return() + tbgroup=c("CmpMetaData"="0","CmpSummary"=1, "CmpSummary_East"=1, + "CmpSummary2"=1, "CmpSummary2_East"=1,"CmpSummary2_Metric"=1, + "CmpCompute"=1, "CmpCalibStats"=1,"CmpStdStk"=1, "CmpStdStk_East"=1, "CmpStdStk_Metric"=1, + "StdStk"=3, "StdStk_East"=3, "StdStk_Metric"=3, "FVS_ATRTList"=8, + "FVS_Cases"=2, "FVS_Climate"=4, "FVS_Compute"=2, "FVS_CutList"=8, + "FVS_EconHarvestValue"=2, "FVS_EconSummary"=2, "FVS_BurnReport"=2, + "FVS_CanProfile"=5, "FVS_Carbon"=2, "FVS_SnagDet"=6, "FVS_Down_Wood_Cov"=2, + "FVS_Down_Wood_Vol"=2, "FVS_Consumption"=2, "FVS_Hrv_Carbon"=2, + "FVS_Mortality"=2, "FVS_PotFire_East"=2, "FVS_PotFire"=2, "FVS_SnagSum"=2, + "FVS_Fuels"=2, "FVS_DM_Spp_Sum"=7, "FVS_DM_Spp_Sum_Metric"=7, + "FVS_DM_Stnd_Sum"=2, "FVS_DM_Stnd_Sum_Metric"=2, "FVS_DM_Sz_Sum"=2, "FVS_DM_Sz_Sum_Metric"=2, + "FVS_RD_Sum"=2, "FVS_RD_Det"=2, "FVS_RD_Beetle"=2, "FVS_StrClass"=2, + "FVS_Summary_East"=2, "FVS_Summary"=2, "FVS_TreeList"=8,"FVS_ATRTList"=8, + "FVS_CutList"=8,"FVS_TreeList_East"=8,"FVS_ATRTList_East"=8,"FVS_CutList_East"=8, + "FVS_TreeList_Metric"=8,"FVS_ATRTList_Metric"=8,"FVS_CutList_Metric"=8, + "FVS_DM_Treelist"=8,"FVS_DM_Treelist_Metric"=8) + tbg = tbgroup[tbs] + arena = is.na(tbg) + if (any(arena)) + { + tbg[arena] = 3 + names(tbg)[arena] = tbs[arena] + } + if (max(tbg) > 1 && ! ("FVS_Cases" %in% tbs)) tbg = c("FVS_Cases"=2,tbg) + dat=NULL + for (tb in names(sort(tbg))) + { +cat ("tb=",tb," len(dat)=",length(dat),"\n") + iprg = iprg+1 + setProgress(message = "Processing tables", detail=tb,value = iprg) + if (tb %in% c("CmpSummary","CmpSummary_East","CmpSummary2", + "CmpSummary2_East","CmpSummary2_Metric")) + { + dtab <- dbReadTable(dbGlb$dbOcon,tb) + if (tb %in% c("CmpSummary","CmpSummary_East")) + dtab <- ddply(dtab,.(MgmtID),.fun=function (x) + setupSummary(x,composite=TRUE)) else + dtab$RmvCode <- as.factor(dtab$RmvCode) + dtab$Year <- as.factor(dtab$Year) + dtab$MgmtID <- as.factor(dtab$MgmtID) + dat[[tb]] <- dtab + } else { + dtab = if ("CaseID" %in% dbListFields(dbGlb$dbOcon,tb)) + dbGetQuery(dbGlb$dbOcon,paste0("select * from ",tb, + " where CaseID in (select CaseID from temp.Cases)")) else + dbGetQuery(dbGlb$dbOcon,paste0("select * from ",tb)) + # fix the stand and stock table. + if (tb == "StdStk") + { + fix = grep ("Hrv",colnames(dtab)) + if (length(fix)) for (ifx in fix) dtab[[ifx]] = as.numeric(dtab[[ifx]]) + } else if (tb == "FVS_Summary" || tb == "FVS_Summary_East") + { + dtab <- ddply(dtab,.(CaseID),.fun=setupSummary) + dtab$ForTyp =as.factor(dtab$ForTyp) + dtab$SizeCls=as.factor(dtab$SizeCls) + dtab$StkCls =as.factor(dtab$StkCls) + } else if (tb == "FVS_Summary2" || tb == "FVS_Summary2_East") + { + dtab$ForTyp =as.factor(dtab$ForTyp) + dtab$SizeCls=as.factor(dtab$SizeCls) + dtab$StkCls =as.factor(dtab$StkCls) + dtab$RmvCode=as.factor(dtab$RmvCode) + } else if (tb == "FVS_Cases") dtab$RunTitle=trim(dtab$RunTitle) + cls = intersect(c(cols,"StandID","MgmtID","RunTitle","srtOrd"),colnames(dtab)) + if (length(cls) > 0) dtab = dtab[,cls,drop=FALSE] + for (col in colnames(dtab)) if (is.character(dtab[,col])) + dtab[,col] = as.factor(dtab[,col]) + if (!is.null(dtab$Year)) dtab$Year =as.factor(dtab$Year) + if (!is.null(dtab$TreeVal)) dtab$TreeVal =as.factor(dtab$TreeVal) + if (!is.null(dtab$PtIndex)) dtab$PtIndex =as.factor(dtab$PtIndex) + if (!is.null(dtab$SSCD)) dtab$SSCD =as.factor(dtab$SSCD) + rownames(dtab) = 1:nrow(dtab) + # fix the species column. + spcd=paste0("Species",input$spCodes) + if (spcd %in% names(dtab)) + { + if (is.null(dtab$Species)) dtab$Species=dtab[,spcd] else + { + na=is.na(dtab$Species) + dtab$Species = as.character(dtab$Species) + dtab$Species[na] = as.character(dtab[na,spcd]) + dtab$Species = as.factor(dtab$Species) + } + } + dat[[tb]] = dtab + } + } +cat ("Explore, len(dat)=",length(dat),"\n") + if (length(dat) == 0) + { + initTableGraphTools(globals,session,output,fvsOutData) + return() + } + iprg = iprg+1 + setProgress(message = "Merging selected tables", detail = "", value = iprg) + inch = 0 + mdat = NULL + for (tb in names(dat)) + { +cat ("tb=",tb," is.null(mdat)=",is.null(mdat),"\n") + if (is.null(mdat)) mdat = dat[[tb]] else + { + mrgVars = intersect(names(mdat),c("CaseID","Year","StandID","MgmtID")) + mrgVars = intersect(mrgVars,names(dat[[tb]])) + setProgress(message = "Merging selected tables", + detail = tb, value = iprg) +cat ("tb=",tb," mrgVars=",mrgVars,"\n") + merged = merge(mdat,dat[[tb]], by=mrgVars) + mdat = if (nrow(merged)) merged else + { + common = intersect(names(mdat),names(dat[[tb]])) + unique = setdiff(names(dat[[tb]]),c(common,mrgVars)) + nd=matrix(data=NA,ncol=length(unique),nrow=nrow(mdat)) + colnames(nd)=unique + mdat=cbind(mdat,nd) + common = intersect(names(mdat),names(dat[[tb]])) + unique = setdiff(names(mdat),c(common,mrgVars,"MgmtID","RunTitle")) + nd=matrix(data=NA,ncol=length(unique),nrow=nrow(dat[[tb]])) + colnames(nd)=unique + nd = data.frame(nd) + idr=match(as.character(dat[[tb]]$CaseID),as.character(dat$FVS_Cases$CaseID)) + nd=cbind(dat$FVS_Cases[idr,c("MgmtID","RunTitle")],nd) + dat[[tb]]=cbind(dat[[tb]],nd) + rbind(mdat,dat[[tb]]) + } + } + } + if (!is.null(mdat$CaseID)) + { + mdat=merge(mdat,dbGetQuery(dbGlb$dbOcon,"select _RowID_,CaseID from temp.Cases"),by="CaseID") + mdat=mdat[order(mdat$rowid,1:nrow(mdat)),] + mdat$rowid=NULL + } + fvsOutData$dbData = mdat + iprg = iprg+1 + # do rep assignments + setProgress(message = "Setting stand reps", detail = "", value = iprg) + newSid = as.character(fvsOutData$dbData$StandID) + icid = as.integer(fvsOutData$dbData$CaseID) + imid = as.integer(fvsOutData$dbData$MgmtID) + isid = as.integer(fvsOutData$dbData$StandID)+as.integer(imid*1000000) + sidch = FALSE + for (id in unique(isid)) + { + nq = unique(icid[isid==id]) + if (length(nq)==1) next + mq = unique(imid[isid==id]) + sidch = TRUE + rep = 0 + for (iq in nq) + { + rep = rep+1 + chng = icid==iq + newSid[chng] = sprintf("%s r%03i",newSid[chng],rep) + } + } + if (sidch) fvsOutData$dbData$StandID = as.factor(newSid) + iprg = iprg+1 + setProgress(message = "Processing variables", detail=tb,value = iprg) + mdat = fvsOutData$dbData + vars = colnames(mdat) + sby = NULL + for (v in c("MgmtID","StandID","Stand_CN","Year","RmvCode","PtIndex", + "TreeIndex","Species","DBHClass")) if (v %in% vars) sby=c(sby,v) + sby = if (length(sby)) + { + cmd = paste0("order(",paste(paste0("mdat$",sby),collapse=","), + if("srtOrd" %in% vars) ",mdat$srtOrd)" else ")") +cat ("cmd=",cmd,"\n") + sby = try(eval(parse(text=cmd))) + if (class(sby) == "try-error") NULL else sby + } else NULL + vars = intersect(c("MgmtID","Stand_CN","StandID","Year", + "Species","DBHClass"),colnames(mdat)) + vars = c(vars,setdiff(colnames(mdat),vars)) + endvars = intersect(c("SamplingWt","Variant","RunTitle", + "Groups","RunDateTime","KeywordFile","CaseID"),vars) + vars = union(setdiff(vars,endvars),endvars) + if (!is.null(sby)) mdat = mdat[sby,vars,drop=FALSE] + mdat$srtOrd = NULL + vars = colnames(mdat) + if (length(vars) == 0) + { + setProgress(value = NULL) + return() + } + iprg = iprg+1 + setProgress(message = "Loading selection widgets", detail = "", value = iprg) + if (is.null(mdat$RunTitle)) + updateSelectInput(session, "stdtitle", choices = list("None loaded"), + selected = NULL) else + updateSelectInput(session, "stdtitle", + choices=as.list(levels(mdat$RunTitle)), selected=levels(mdat$RunTitle)) + iprg = iprg+1 + setProgress(message = "Loading selection widgets", detail = "", value = iprg) + if (is.null(mdat$StandID)) + { + cho = "None loaded" + updateSelectInput(session,"stdid",choices =list(cho),selected = NULL) + } else { + cho = levels(mdat$StandID) + sel = cho + if (length(cho) > 5000) + { + cho = paste0("None loaded (",length(cho)," stands)") + sel = NULL + } + updateSelectInput(session,"stdid",choices=as.list(cho),selected=sel) + } + globals$exploreChoices$stdid = cho + if (is.null(mdat$Groups)) + { + cho = "None loaded" + updateSelectInput(session,"stdgroups",choices=as.list(cho),selected = NULL) + } else { + cho = sort(unique(unlist(lapply(levels(mdat$Groups), function (x) + trim(scan(text=x,what="character",sep=",",quiet=TRUE)))))) + updateSelectInput(session, "stdgroups",choices=as.list(cho),selected=cho) + } + globals$exploreChoices$stdgroups = cho + if (is.null(mdat$MgmtID)) + { + cho = "None loaded" + updateSelectInput(session,"mgmid",choices=as.list(cho),selected=0) + } else { + cho = levels(mdat$MgmtID) + updateSelectInput(session, "mgmid",choices=as.list(cho),selected=cho) + } + globals$exploreChoices$mgmid = cho + if (length(intersect(c("FVS_TreeList","FVS_ATRTList","FVS_CutList", + "FVS_TreeList_East","FVS_ATRTList_East","FVS_CutList_East", + "FVS_TreeList_Metric","FVS_ATRTList_Metric","FVS_CutList_Metric" + ),names(dat)))) + updateSelectInput(session, "plotType",selected="scat") else + if (length(intersect(c("StdStk","CmpStdStk","StdStk_East", + "CmpStdStk_East","StdStk_Metric","CmpStdStk_Metric"),names(dat)))) + updateSelectInput(session, "plotType",selected="bar") else + updateSelectInput(session, "plotType",selected="line") + iprg = iprg+1 + setProgress(message = "Loading selection widgets", detail = "", value = iprg) + if (is.null(mdat$Year)) + { + cho = "None loaded" + updateSelectInput(session,"year",choices=as.list(cho),selected = NULL) + } else { + cho = levels(mdat$Year) + isel = max(1,length(cho) %/% 2) + sel = if (length(intersect(c("FVS_TreeList","FVS_ATRTList","FVS_CutList", + "FVS_TreeList_East","FVS_ATRTList_East","FVS_CutList_East", + "StdStk","StdStk_East","StdStk_Metric","CmpStdStk","CmpStdStk_East", + "CmpStdStk_Metric"),names(dat)))) + cho[isel] else cho + updateSelectInput(session, "year", choices=as.list(cho), selected=sel) + } + globals$exploreChoices$year = cho + if (is.null(mdat$Species)) + { + cho = "None loaded" + updateSelectInput(session, "species", choices = list(cho), selected = NULL) + } else { + cho = levels(mdat$Species) + updateSelectInput(session, "species", + choices=as.list(cho), selected=setdiff(cho,"All")) + } + globals$exploreChoices$species = cho + if (is.null(mdat$DBHClass)) + { + cho = "None loaded" + updateSelectInput(session,"dbhclass",choices=list(cho),selected = NULL) + } else { + cho = levels(mdat$DBHClass) + sel = if ("All" %in% cho) "All" else cho + updateSelectInput(session, "dbhclass", choices=as.list(cho), selected=sel) + } + globals$exploreChoices$dbhclass = cho + iprg = iprg+1 + setProgress(message = "Finishing", detail = "", value = iprg) + fvsOutData$dbData <- mdat + vars <- c("Select all",vars) + fvsOutData$browseVars <- vars + varsList <- as.list(vars) + vars = setdiff(vars,c("Select all","Stand_CN","KeywordFile", + "SamplingWt","Variant","Version", + "RV", "RunDateTime")) + fvsOutData$browseSelVars <- vars + updateCheckboxGroupInput(session, "browsevars", choices=varsList, + selected=vars,inline=TRUE) + setProgress(value = NULL) + }, min=1, max=12) + } + }) + + ## renderTable + renderTable <- function (dat) + { +cat ("renderTable, is.null=",is.null(dat)," nrow(dat)=",nrow(dat),"\n") + if (!is.null(dat) && ncol(dat)==0){ + renderRHandsontable(NULL) + return() + } + if (!is.null(dat) && nrow(dat) > 0) + { + dat = lapply(dat,function (x) + if (is.factor(x)) levels(x)[as.numeric(x)] else x) + dat = as.data.frame(dat) + for (i in 1:ncol(dat)) + if (class(dat[[i]]) == "numeric") dat[[i]] = round(dat[[i]],3) + } + if(length(grep("X_",names(dat)))){ + idxs <- grep("X_",names(dat)) + for(i in 1:length(grep("X_",names(dat)))){ + names(dat)[idxs[i]] <- sub('.', '', names(dat)[idxs[i]]) + } + } + renderRHandsontable(if (is.null(dat) || nrow(dat)==0) NULL else + rhandsontable(dat,readOnly=TRUE,useTypes=FALSE,contextMenu=FALSE, + width="100%",height=700)) + } + + ## browsevars + observe({ + if (is.null(input$browsevars)) return() +cat("filterRows and/or pivot\n") + if(fvsOutData$browseVars[1]==input$browsevars[1]){ + fvsOutData$browseSelVars <- fvsOutData$browseVars[-1] + updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), + selected=fvsOutData$browseVars,inline=TRUE) + globals$selAllVars = TRUE + if(length(input$browsevars)==(length(fvsOutData$browseVars)-1) && globals$selAllVars){ + fvsOutData$browseSelVars <- input$browsevars[-1] + updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), + selected=fvsOutData$browseSelVars,inline=TRUE) + globals$selAllVars = FALSE + } + }else if (fvsOutData$browseVars[1]!=input$browsevars[1] && globals$selAllVars){ + fvsOutData$browseSelVars <- character() + updateCheckboxGroupInput(session, "browsevars", choices=as.list(fvsOutData$browseVars), + selected=fvsOutData$browseSelVars,inline=TRUE) + globals$selAllVars = FALSE + }else fvsOutData$browseSelVars <- input$browsevars + dat = if (length(input$stdtitle) || length(input$stdgroups) || + length(input$stdid) || length(input$mgmid) || + length(input$year) || length(input$species) || + length(input$dbhclass)) + fvsOutData$dbData[filterRows(fvsOutData$dbData, input$stdtitle, input$stdgroups, + input$stdid, input$mgmid, input$year, input$species, input$dbhclass) + ,fvsOutData$browseSelVars,drop=FALSE] else + fvsOutData$dbData[,fvsOutData$browseSelVars,drop=FALSE] + if (!is.null(input$pivVar) && input$pivVar != "None" && + !is.null(input$dispVar) && input$dispVar != "None") + dat = pivot(dat,input$pivVar,input$dispVar) + fvsOutData$render = dat + tableDisplayLimit = 5000 + if (nrow(dat) > tableDisplayLimit) + { + msg=paste0("Table display limit exceeded. ", + tableDisplayLimit," of ",nrow(dat)," displayed. Use Download table", + " to download all rows.") + output$tableLimitMsg<-renderText(msg) + dat = dat[1:tableDisplayLimit,,drop=FALSE] + } else output$tableLimitMsg<-NULL + output$table <- renderTable(dat) + }) + + ##Graphs + observe({ + if (input$leftPan == "Explore" && input$outputRightPan == "Graphs") + { +cat ("Graphs pan hit\n") + # update color pallet + for (i in 1:length(cbbPalette)) + updateColourInput(session=session,inputId=paste0("color",i),value=cbbPalette[i]) + loadObject(dbGlb$prjDB,"GraphSettings") + if (!exists("GraphSettings")) GraphSettings=list("None"=list()) + updateSelectInput(session=session, inputId="OPsettings", choices=names(GraphSettings), + selected="None") + updateTextInput(session=session, "OPname", value = "") + output$OPmessage=NULL + } + }) + + ## OPsettings + observe({ + if (!is.null(input$OPsettings)) + { + input$OPredo + isolate({ +cat ("OPsettings hit, OPsettings=",input$OPsettings,"\n") + loadObject(dbGlb$prjDB,"GraphSettings") + if (!exists("GraphSettings") || + length(GraphSettings[[input$OPsettings]])<1 || + input$OPsettings == "None") + { + output$OPmessage=NULL + updateTextInput(session=session, "OPname", value = "") + } else { + updateTextInput(session=session, "OPname", value = input$OPsettings) + if (all(unlist(GraphSettings[[input$OPsettings]][["selectdbtables"]]) %in% + input$selectdbtables) && + all(unlist(GraphSettings[[input$OPsettings]][["dbvars"]]) %in% + input$selectdbvars)) + { + output$OPmessage=NULL + msg = setGraphSettings(session,globals,GraphSettings[[input$OPsettings]]) +cat ("msg=",msg,"\n") + if (! is.null(msg)) output$OPmessage= + renderUI(HTML(paste0('

', + "Warning(s):
",paste0(msg,collapse="
"),"

"))) + } else output$OPmessage=renderUI(HTML(paste0('

', + "Error: The data needed for this setting was not selected ", + "when you picked data to load.
Table(s) needed: ", + paste0(GraphSettings[[input$OPsettings]][["selectdbtables"]], + collapse=", "),"

"))) + } + }) + } + }) + + ## OPsave + observe({ + if (input$OPsave > 0) + { + output$OPmessage=NULL + isolate({ +cat ("OPsave hit, OPname=",input$OPname,"\n") + loadObject(dbGlb$prjDB,"GraphSettings") + if (!exists("GraphSettings")) + { + GraphSettings=list("None"=list()) + attr(GraphSettings[[1]],"setTime")=.Machine$integer.max + } + if (nchar(input$OPname)==0) + { + setName=paste0("Setting ",length(GraphSettings)+1) + updateTextInput(session=session,inputId="OPname",value=setName) + } else setName=input$OPname + GraphSettings[[setName]]=getGraphSettings(input) + attr(GraphSettings[[setName]],"setTime")=as.integer(Sys.time()) + GraphSettings <- GraphSettings[order(unlist(lapply(GraphSettings, + function(x) attr(x,"setTime"))),decreasing = TRUE)] + storeOrUpdateObject(dbGlb$prjDB,GraphSettings) + updateSelectInput(session=session, inputId="OPsettings", choices= + names(GraphSettings),selected=setName) + }) + } + }) + + ## OPdel + observe({ + if (input$OPdel > 0) + { + isolate({ +cat("OPdel hit, input$OPname=",input$OPname,"\n") + output$OPmessage=NULL + loadObject(dbGlb$prjDB,"GraphSettings") + if (!exists("GraphSettings")) return() + if (input$OPname == "None") return() + if (is.null(GraphSettings[[input$OPname]])) return() + GraphSettings[[input$OPname]] = NULL + if (length(GraphSettings)==0) + { + updateSelectInput(session=session, inputId="OPsettings", choices=list()) + removeObject(dbGlb$prjDB,"GraphSettings") + } else { + updateSelectInput(session=session, inputId="OPsettings", choices= + names(GraphSettings),selected="None") + storeOrUpdateObject(dbGlb$prjDB,GraphSettings) + } + updateTextInput(session=session, "OPname", value = "") + }) + } + }) + + ## browsevars/plotType + observe({ + if (!is.null(input$browsevars) && !is.null(input$plotType)) + { +cat ("browsevars/plotType, input$plotType=",input$plotType," globals$gFreeze=",globals$gFreeze,"\n") + fvsOutData$browseSelVars <- input$browsevars + cats = unlist(lapply(fvsOutData$dbData,is.factor)) + cats = names(cats)[cats] + cats = intersect(cats,input$browsevars) + cont = union("Year",setdiff(input$browsevars,cats)) + if(length(cont) > 1 && cont[2]=="Select all") cont <- cont[-2] + spiv = if (length(input$pivVar) && + input$pivVar %in% cats) input$pivVar else "None" + sdisp = if (length(input$dispVar) && + input$dispVar %in% input$browsevars) input$dispVar else "None" + ccont = c("None",setdiff(input$browsevars,spiv)) + bb = intersect(ccont,cats) # put the factors at the end of the choices + ccont = c(setdiff(ccont,bb),bb) + updateSelectInput(session,"pivVar",choices=as.list(c("None",cats)), + selected=spiv) + updateSelectInput(session,"dispVar",choices=as.list(ccont), + selected=sdisp) + if (globals$gFreeze) return() + isolate({ + curX = input$xaxis + curY = input$yaxis + if (input$plotType=="line") { + selx = if (is.null(curX)) "Year" else curX + selx = if (selx %in% cont) selx else + if (length(cont) > 0) cont[1] else NULL + globals$settingChoices[["xaxis"]] = as.list(cont) + updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=selx) + sel = if (is.null(curY)) "BA" else curY + sel = if (sel %in% cont) sel else + if (length(cont) > 0) cont[1] else NULL + if (sel == selx && length(cont) > 1) + { + sel = grep("BA",cont)[1] + sel = if (is.na(sel)) cont[2] else cont[sel] + } + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) + } else if (input$plotType == "scat") { + sel = if (is.null(curX)) "DBH" else curX + sel = if (sel %in% cont) sel else + if (length(cont) > 0) cont[1] else NULL + updateSelectInput(session, "xaxis",choices=as.list(cont), selected=sel) + sel = if (is.null(curY)) "DG" else curY + sel = if (sel %in% cont) sel else + if (length(cont) > 0) cont[1] else NULL + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) + } else if (input$plotType == "bar") { + def = if ("Species" %in% cats) "Species" else NULL + def = if (is.null(def) && "Year" %in% cats) "Year" else cats[1] + sel = if (!is.null(curX) && curX %in% cats) curX else def + globals$settingChoices[["xaxis"]] = as.list(cats) + updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=sel) + sel = if (!is.null(curX) && curX %in% cont) curX else cont[1] + if (sel=="Year" && length(cont) > 1) sel = cont[2] + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) + } else if (input$plotType == "box") { + def = if ("Species" %in% cats) "Species" else NULL + def = if (is.null(def) && "Year" %in% cats) "Year" else cats[1] + sel = if (!is.null(curX) && curX %in% cats) curX else def + globals$settingChoices[["xaxis"]] = as.list(cats) + updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected=sel) + sel = if (!is.null(curX) && curX %in% cont) curX else cont[1] + if (sel=="Year" && length(cont) > 1) sel = cont[2] + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected=sel) + } else if (input$plotType=="DMD") { + updateRadioButtons(session=session,inputId="XUnits",selected="QMD") + updateRadioButtons(session=session,inputId="YUnits",selected="Tpa") + updateRadioButtons(session=session,inputId="YTrans",selected="log10") + updateRadioButtons(session=session,inputId="XTrans",selected="log10") + globals$settingChoices[["xaxis"]] = as.list(cont) + updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected="QMD") + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected="Tpa") + } else if (input$plotType=="StkCht") { + globals$settingChoices[["xaxis"]] = as.list(cont) + updateSelectInput(session, "xaxis",choices=globals$settingChoices[["xaxis"]], selected="Tpa") + globals$settingChoices[["yaxis"]] = as.list(cont) + updateSelectInput(session, "yaxis",choices=globals$settingChoices[["yaxis"]], selected="BA") + } + updateSliderInput(session, "transparency", + value = if(input$plotType == "scat") .3 else 0.) + if (input$plotType!="DMD") + { + updateRadioButtons(session=session,inputId="YTrans",selected="identity") + updateRadioButtons(session=session,inputId="XTrans",selected="identity") + } + sel = if ("StandID" %in% cats && input$plotType != "box") "StandID" else "None" + updateSelectInput(session=session, inputId="hfacet",choices=as.list(c("None",cats)), + selected=sel) + sel = if ("MgmtID" %in% cats && input$plotType != "box") "MgmtID" else "None" + updateSelectInput(session=session, inputId="vfacet",choices=as.list(c("None",cats)), + selected=sel) + sel = if ("Species" %in% cats && input$plotType != "box") "Species" else "None" + updateSelectInput(session=session, inputId="pltby",choices=as.list(c("None",cats)), + selected=sel) +cat ("end of browsevars/plotType\n") + }) + } + }) + + ## yaxis, xaxis regarding the Y- and XUnits for DMD + observe({ + if (globals$gFreeze) return() + if (!is.null(input$yaxis) && input$yaxis %in% c("Tpa","QMD")) + updateRadioButtons(session=session,inputId="YUnits", + selected=input$yaxis) + if (!is.null(input$xaxis) && input$xaxis %in% c("Tpa","QMD")) + updateRadioButtons(session=session,inputId="XUnits", + selected=input$xaxis) + }) + ## Set a tool to "None" if the same level is selected by another tool (doesn't + ## apply to axes selection + observe({ + if (is.null(input$pltby) || input$pltby == "None" || globals$gFreeze) return() + isolate({ + if (all(!c(is.null(input$pltby),is.null(input$xaxis),is.null(input$pltby), + is.null(input$yaxis))) && + (input$pltby == input$xaxis || input$pltby == input$yaxis)) + { + updateSelectInput(session=session, inputId="pltby", selected="None") + return() + } + if (input$pltby == input$vfacet) + updateSelectInput(session=session, inputId="vfacet", selected="None") + if (input$pltby == input$hfacet) + updateSelectInput(session=session, inputId="hfacet", selected="None") + }) }) + + ## vfacet change + observe({ +cat ("vfacet change, globals$gFreeze=",globals$gFreeze,"\n") + if (is.null(input$vfacet) || input$vfacet == "None" || globals$gFreeze) return() + isolate({ + if (!is.null(input$xaxis) && !is.null(input$yaxis) && + (input$vfacet == input$xaxis || input$vfacet == input$yaxis)) + { + updateSelectInput(session=session, inputId="vfacet", selected="None") + return() + } + if (!is.null(input$pltby) && input$vfacet == input$pltby) + updateSelectInput(session=session, inputId="pltby", selected="None") + if (input$vfacet == input$hfacet) + updateSelectInput(session=session, inputId="hfacet", selected="None") + }) }) + + ## hfacet change + observe({ +cat ("hfacet change, globals$gFreeze=",globals$gFreeze,"\n") + if (is.null(input$hfacet) || input$hfacet == "None" || globals$gFreeze) return() + isolate({ + if (!is.null(input$xaxis) && !is.null(input$yaxis) && + (input$hfacet == input$xaxis || input$hfacet == input$yaxis)) + { + updateSelectInput(session=session, inputId="hfacet", selected="None") + return() + } + if (!is.null(input$pltby) && input$hfacet == input$pltby) + updateSelectInput(session=session, inputId="pltby", selected="None") + if (input$hfacet == input$vfacet) + updateSelectInput(session=session, inputId="vfacet", selected="None") + }) }) + + ## renderPlot + output$outplot <- renderImage( + { +cat ("renderPlot\n") + output$plotMessage=NULL + nullPlot <- function (msg="Select different data, variables, plot type, or facet settings.") + { + outfile = "www/nullPlot.png" + if (!file.exists(outfile)) + { + CairoPNG(outfile, width=3, height=2, res=72, units="in", pointsize=12) + plot.new() + text(x=.5,y=.5,"Nothing to graph",col="red") + dev.off() + } + output$plotMessage=renderText(msg) + list(src = outfile) + } + if (input$leftPan == "Load" || (length(input$xaxis) == 0 && + length(input$yaxis) == 0)) return(nullPlot()) + output$plotMessage=renderText(NULL) + + vf = if (input$vfacet == "None") NULL else input$vfacet + hf = if (input$hfacet == "None") NULL else input$hfacet + pb = if (input$pltby == "None") NULL else input$pltby + needVars = unique(c(vf,hf,pb,input$xaxis,input$yaxis)) + dat = if (input$leftPan == "Custom Query") fvsOutData$dbData else + droplevels(fvsOutData$dbData[filterRows(fvsOutData$dbData, input$stdtitle, + input$stdgroups, input$stdid, input$mgmid, input$year, input$species, + input$dbhclass),]) + if (nrow(dat)==0) return(nullPlot("No observations using these selections")) + # fix DBHClass if it is in the data. + if (!is.null(dat$DBHClass)) + { + mlv=setdiff(input$dbhclass,levels(dat$DBHClass)) + if (length(mlv)) + { + # this bit makes sure CaseID is first + if(!length(grep("CmpStdStk",input$selectdbtables))) + byset=c("CaseID",setdiff(names(dat)[unlist(lapply(dat,is.factor))], + c("CaseID", "MgmtID","StandID","DBHClass","RunTitle"))) else + byset=c(setdiff(names(dat)[unlist(lapply(dat,is.factor))], + c("CaseID","MgmtID","StandID","DBHClass","RunTitle"))) + newrows = ddply(dat,byset,function(x) x[1,]) + newrows[,!unlist(lapply(dat,is.factor))]=0 + newrows$DBHClass=as.character(newrows$DBHClass) + dat$DBHClass=as.character(dat$DBHClass) + for (lms in mlv) + { + newrows$DBHClass = lms + dat=rbind(dat,newrows) + } + dat$DBHClass=factor(as.character(dat$DBHClass)) + cmd=paste0("idx=with(dat,order(",paste0(c(byset,"DBHClass"),collapse=","),"))") + eval(parse(text=cmd)) + dat = dat[idx,] + } + } # end of DBHClass fixup + if (!is.null(pb) && pb=="Groups" && length(input$stdgroups) && length(levels(dat$Groups))) + { + for (il in 1:length(levels(dat$Groups))) + { + levs = trim(unlist(strsplit(levels(dat$Groups)[il],","))) + newl = paste0(intersect(levs,input$stdgroups),collapse=", ") + levels(dat$Groups)[il] = newl + } + } + if (length(setdiff(needVars,names(dat)))) return(nullPlot()) +cat ("vf=",vf," hf=",hf," pb=",pb," xaxis=",input$xaxis," yaxis=",input$yaxis,"\n") + if (is.null(input$xaxis) || is.null(input$yaxis)) return (nullPlot("Select both X- and Y-axes")) + if (!is.null(hf) && nlevels(dat[,hf]) > 9) + { +cat ("hf test, nlevels(dat[,hf])=",nlevels(dat[,hf]),"\n") + return (nullPlot(paste0("Number of horizontal facets= ",nlevels(dat[,hf]),"> 9"))) + } + if (!is.null(vf) && nlevels(dat[,vf]) > 9) + { +cat ("vf test hit, nlevels(dat[,vf])=",nlevels(dat[,vf]),"\n") + return (nullPlot(paste0("Number of vertical facets= ",nlevels(dat[,vf]),"> 9"))) + } + chk = if ("RunTitle" %in% c(input$xaxis, vf, hf, pb, input$yaxis)) + c("RunTitle","StandID","Year") else c("MgmtID","StandID","Year") + if ( ! input$plotType %in% c("scat","box")) for (v in chk) + { + if (input$plotType %in% c("line","DMD","StkCht") && v=="Year") next + if (v %in% names(dat) && nlevels(dat[[v]]) > 1 && + ! (v %in% c(input$xaxis, vf, hf, pb, input$yaxis))) + return(nullPlot(paste0("Variable '",v,"' has ",nlevels(dat[[v]])," levels and ", + " therefore must be an axis, plot-by code, or a facet."))) + } + pltp = input$plotType + if (input$xaxis == "Year" && !(pltp %in% c("bar","box"))) dat$Year = as.numeric(as.character(dat$Year)) + nlv = 1 + (!is.null(pb)) + (!is.null(vf)) + (!is.null(hf)) + vars = c(input$xaxis, vf, hf, pb, input$yaxis) + nd = NULL + specOpts <- c("Species","SpeciesFVS","SpeciesPLANTS","SpeciesFIA") + sumOnSpecies= (all(!specOpts %in% vars) && any(specOpts %in% names(dat)) && + nlevels(dat$Species)>1) + sumOnDBHClass= !"DBHClass" %in% vars && "DBHClass" %in% names(dat) && + nlevels(dat$DBHClass)>1 + for (v in vars[(nlv+1):length(vars)]) + { + if (is.na(v) || !v %in% names(dat)) return(nullPlot()) + pd = dat[,c(vars[1:nlv],v),drop=FALSE] + names(pd)[ncol(pd)] = "Y" + if (sumOnSpecies) pd = cbind(pd,Species =dat$Species) + if (sumOnDBHClass)pd = cbind(pd,DBHClass=dat$DBHClass) + nd = rbind(nd, data.frame(pd,Legend=v,stringsAsFactors=FALSE)) + } +cat("sumOnSpecies=",sumOnSpecies," sumOnDBHClass=",sumOnDBHClass,"\n") + if (sumOnSpecies) + { + nd=subset(nd,Species!="All") + nd$Species="Sum" + } + if (sumOnDBHClass) + { + nd=subset(nd,DBHClass!="All") + nd$DBHClass="Sum" + } + if (sumOnSpecies || sumOnDBHClass) + { + nd=ddply(nd,setdiff(names(nd),"Y"),.fun=function (x) sum(x$Y)) + names(nd)[ncol(nd)]="Y" + } + if (nlevels(nd[[input$xaxis]])>7 && max(nchar(levels(nd[[input$xaxis]]))) > 6 && + isolate(input$XlabRot) == "0" && !globals$gFreeze) + updateSelectInput(session=session,inputId="XlabRot",selected="90") + hrvFlag = NULL + if (input$plotType %in% c("line","DMD","StkCht")) + { + if (is.null(dat[["RmvCode"]])) + { + rtpa = grep ("RTpa",names(dat))[1] + if (!is.null(dat$Year) && !is.null(rtpa) && !is.na(rtpa) && nrow(dat)>1) + { + hrvFlag = vector(mode="logical",length=nrow(pd)) + i = 0 + while (i < nrow(dat)-1) { + i = i+1; + if (dat$Year[i]==dat$Year[i+1] && dat[i+1,rtpa]>0) + { + hrvFlag[i]=TRUE + i=i+1 + } + } + } + } else hrvFlag = dat[["RmvCode"]] == 1 + } + nd = na.omit(nd) + omits = as.numeric(attr(nd,"na.action")) + if (length(nd) == 0) return(nullPlot()) + if (length(omits)) hrvFlag = hrvFlag[-omits] + rownames(nd)=1:nrow(nd) + names(nd)[match(input$xaxis,names(nd))] = "X" + if (!is.null(vf)) names(nd)[match(vf,names(nd))] = "vfacet" + if (!is.null(hf)) names(nd)[match(hf,names(nd))] = "hfacet" + legendTitle = "Legend" + if (!is.null(pb) && !is.null(nd$Legend)) + { + legendTitle = pb + nd$Legend = if (nlevels(as.factor(nd$Legend)) == 1) + nd[,pb] else paste(nd$Legend,nd[,pb],sep=":") + } + if (input$plotType %in% c("line","DMD","StkCht") && + length(unique(nd$X)) < 2) return(nullPlot( + "Selected plot type requires more than 1 unique value on the X-axis")) + if (!is.null(nd$vfacet)) nd$vfacet = ordered(nd$vfacet, levels=sort(unique(nd$vfacet))) + if (!is.null(nd$hfacet)) nd$hfacet = ordered(nd$hfacet, levels=sort(unique(nd$hfacet))) + if (!is.null(nd$Legend)) nd$Legend = ordered(nd$Legend, levels=sort(unique(nd$Legend))) + fg = if (!is.null(nd$vfacet) && !is.null(nd$hfacet)) facet_grid(vfacet~hfacet) else NULL + if (input$facetWrap == "Off") + { + fg = if (is.null(fg) && !is.null(nd$hfacet)) facet_grid(.~hfacet) else fg + fg = if (is.null(fg) && !is.null(nd$vfacet)) facet_grid(vfacet~.) else fg + } else { + fg = if (is.null(fg) && !is.null(nd$hfacet)) + facet_wrap(~hfacet,ncol=ceiling(sqrt(nlevels(nd$hfacet))),strip.position="top") else fg + fg = if (is.null(fg) && !is.null(nd$vfacet)) + facet_wrap(~vfacet,ncol=ceiling(sqrt(nlevels(nd$vfacet))),strip.position="right") else fg + } + if (pltp %in% c("bar","box")) nd$Y[nd$Y==0] = NA + mkgraphlab <- function (str) + { + str=trim(str) + if(nchar(str)<10) return(str) + if(substr(str,1,10)=="expression") + { + rtn = try(eval(parse(text=str))) + if (class(rtn)=="expression") return(rtn) + } + str + } + xxlab=if (nchar(input$xlabel)) mkgraphlab(input$xlabel) else input$xaxis + yylab=if (nchar(input$ylabel)) mkgraphlab(input$ylabel) else input$yaxis + grtit=if (nchar(input$ptitle)) mkgraphlab(input$ptitle) else input$ptitle + p = ggplot(data=nd) + fg + labs(x=xxlab,y=yylab,title=grtit) + + theme(text = element_text(size=9), + panel.background = element_rect(fill="gray95"), + axis.text = element_text(color="black")) + if (!is.null(fg)) p = p + + theme(strip.text.x = element_text(margin = margin(.025, .01, .025, .01, "in"))) + + theme(strip.text.y = element_text(margin = margin(.025, .01, .025, .01, "in"))) + colors = if (input$colBW == "B&W") + unlist(lapply(seq(0,.3,.05),function (x) rgb(x,x,x))) else + { + if (is.null(input$color1)) cbbPalette else + c(input$color1,input$color2,input$color3,input$color4, input$color5, input$color6, + input$color7,input$color8,input$color9,input$color10,input$color11,input$color12, + input$color13,input$color14,input$color15,input$color16,input$color17,input$color18) + } + colors = autorecycle(colors,nlevels(nd$Legend)) + linetypes = autorecycle(c("solid","dashed","dotted","dotdash","longdash","twodash"), + nlevels(nd$Legend)) + alpha = if (is.null(input$transparency)) .7 else (1-input$transparency) +cat ("Legend nlevels=",nlevels(nd$Legend)," colors=",colors,"\n") + p = p + theme(axis.text.x = element_text(angle = as.numeric(input$XlabRot), + hjust = if(input$XlabRot=="0") .5 else 1)) + p = p + theme(axis.text.y = element_text(angle = as.numeric(input$YlabRot), + hjust = if(input$YlabRot!="0") .5 else 1)) + p = p + scale_colour_manual(values=colors) + p = p + scale_fill_manual(values=colors) + p = p + scale_shape_manual(values=1:nlevels(nd$Legend)) + scale_linetype_manual(values=linetypes) + p = p + scale_linetype_manual(values=1:nlevels(nd$Legend)) +cat ("input$XTrans=",input$XTrans," input$YTrans=",input$YTrans,"\n") + xmin = as.numeric(input$XLimMin) + xmax = as.numeric(input$XLimMax) + xlim = if (!is.na(xmin) && !is.na(xmax) && xmin < xmax) c(xmin, xmax) else NULL + ymin = as.numeric(input$YLimMin) + ymax = as.numeric(input$YLimMax) + ylim = if (!is.na(ymin) && !is.na(ymax) && ymin < ymax) c(ymin, ymax) else NULL +cat("ylim=",ylim," xlim=",xlim,"\n") + ymaxlim = NA + xmaxlim = NA + DMDguideLines = NULL + if (input$plotType == "DMD") + { + sdis=input$SDIvals + for (xx in c(" ","\n","\t",",",";")) sdis = if (is.null(sdis)) + NULL else unlist(strsplit(sdis,split=xx)) + if (!is.null(sdis)) + { + maxSDI = max(na.omit(as.numeric(sdis))) + if (maxSDI == -Inf) {maxSDI=700; sdis = c(sdis,as.character(maxSDI))} + sdisn = NULL + for (xx in sdis) + { + li = nchar(xx) + nv = if (li>1 && substr(xx,li,li)=="%") + as.numeric(substr(xx,1,li-1))*.01*maxSDI else as.numeric(xx) + sdisn = c(sdisn,nv) + } +cat("sdisn=",sdisn,"\nXUnits=",input$XUnits," YUnits=",input$YUnits,"\n") + seqTpa = seq(5,3000,length.out=50) + seqQMD = seq(1,80,length.out=50) + for (SDI in sdisn) + { + xseq = if (input$XUnits=="Tpa") seqTpa else seqQMD + yseq = if (input$YUnits=="Tpa") + if (input$XUnits=="Tpa") seqTpa else + # Tpa = f(QMD,SDI) + SDI / (seqQMD/10)^1.605 else + if (input$XUnits=="QMD") seqQMD else + # QMD = f(Tpa,SDI) + exp(log(SDI/seqTpa) / 1.605)*10 + lineData = data.frame(xseq=xseq,yseq=yseq)[! yseq > Inf,] + ymaxlim = range(c(ymaxlim,lineData$yseq),na.rm=TRUE) + xmaxlim = range(c(xmaxlim,lineData$xseq),na.rm=TRUE) + DMDguideLines[[as.character(SDI)]] = lineData +cat("SDI=",SDI," ymaxlim=",ymaxlim," xmaxlim=",xmaxlim,"\n") + } + } + } + StkChtguideLines = NULL + if (input$plotType == "StkCht") + { + sdis=input$StkChtvals + for (xx in c(" ","\n","\t",",",";")) sdis = if (is.null(sdis)) + NULL else unlist(strsplit(sdis,split=xx)) + if (length(sdis)) + { + sdis = unlist(lapply(sdis,function(x) if(substr(x,nchar(x),nchar(x)) == "%") + x else paste0(x,"%"))) + for (i in 1:length(sdis)) + yptsba = c(70.2,80.9,89.5,96.5,102.5,107.5,111.9,115.7,119.0,121.8, + 124.4,126.6,128.9) + xptstpa = c(1430,928,657,492,383,308,253,212,180,155,135,119,105) + seqTpa = seq(10,max(2000,nd$X),length.out=100) + seqBA = 161.47029555*exp(-.02275259*(seqTpa^.5)) #found using nls() + ymaxlim = range(seqBA) + xmaxlim = range(seqTpa) + StkChtguideLines = list() + for (PCT in sdis) + { + pct = as.numeric(gsub("%","",PCT))*.01 + lineData = data.frame(xseq=seqTpa*pct,yseq=seqBA*pct) + StkChtguideLines[[as.character(PCT)]] = lineData + ymaxlim = range(c(ymaxlim,lineData$yseq),na.rm=TRUE) + xmaxlim = range(c(xmaxlim,lineData$xseq),na.rm=TRUE) + } + pcts = as.numeric(gsub("%","",sdis))*.01 + pm = min(pcts) + px = max(pcts) + StkChtrng = data.frame(X=c(xptstpa[1]*pm,xptstpa[1]*px,xptstpa*px,rev(xptstpa)*pm), + Y=c(yptsba[1]*pm,yptsba[1]*px,yptsba*px,rev(yptsba)*pm)) + } + } + ### end DMD...except for adding annotations, see below. + if (is.factor(nd$X)) nd$X = as.ordered(nd$X) + if (is.factor(nd$Y)) nd$Y = as.ordered(nd$Y) + if (pltp %in% c("DMD","StkCht")) pltp = "path" +cat ("pltp=",pltp," input$colBW=",input$colBW," hrvFlag is null=",is.null(hrvFlag),"\n") + brks = function (x,log=FALSE) + { + b = range(x,na.rm=TRUE) + if (log) { + b = pretty (log10(b), n = 4, min.n = 1) + b = ifelse(b<=.1,.1,b) + b = floor(10**b[!duplicated(b)]) + xx = 10**floor(log10(b)) + ceiling((b/xx))*xx + } else pretty(b, n=4, min.n = 1) + } + if (!is.factor(nd$X)) + { + rngx=range(if (!is.null(xlim)) xlim else range(c(nd$X,xmaxlim),na.rm=TRUE)) + if(input$XTrans == "log10") + { + brkx=brks(rngx,log=TRUE) + rngx=ifelse(rngx<=.01,.01,rngx) + p = p + scale_x_log10(breaks=brkx,limits=rngx) + } else { + brkx=brks(rngx) + if (! (pltp %in% c("bar","box"))) p = p + scale_x_continuous(breaks=brkx, + limits=rngx,guide=guide_axis(check.overlap = TRUE)) + } +cat("xlim=",xlim," rngx=",rngx," brkx=",brkx,"\n") + } else p = p + scale_x_discrete(guide = guide_axis(check.overlap = TRUE)) + + if (!is.factor(nd$Y)) + { + rngy=range(if (!is.null(ylim)) ylim else range(c(nd$Y,ymaxlim),na.rm=TRUE)) + if(input$YTrans == "log10") + { + brky=brks(rngy,log=TRUE) + rngy=ifelse(rngy<.01,.01,rngy) + p = p + scale_y_log10(breaks=brky,limits=rngy) + } else { + brky=brks(rngy) + if (! (pltp %in% c("bar","box"))) p = p + scale_y_continuous(breaks=brky, + limits=rngy,guide = guide_axis(check.overlap = TRUE)) + } +cat("ylim=",ylim," rngy=",rngy," brky=",brky,"\n") + } else p = p + scale_y_discrete(guide = guide_axis(check.overlap = TRUE)) + # add the guidelines and annotation here (now that we know the range limits of x and y + if (!is.null(DMDguideLines)) + { + pltorder = sort(as.numeric(names(DMDguideLines)),decreasing=TRUE,index.return=TRUE)$ix + for (linetype in 1:length(pltorder)) + { + SDI = names(DMDguideLines)[pltorder[linetype]] + p = p + geom_line(aes(x=xseq,y=yseq),show.legend=FALSE,alpha=.4, + linetype=linetype,data=DMDguideLines[[SDI]]) + } + sq = seq(.95,0,-.05) + sq = if (input$YTrans=="log10") 10^(log10(rngy[2])*sq) else rngy[2]*sq + sq = sq[1:min(length(sq),length(pltorder))] + xs = if (input$XTrans=="log10") 10^(log10(rngx[2])*c(.75,.9)) else rngx[2]*c(.75,.9) + guidedf = do.call(rbind,lapply(sq,function(y) data.frame(ys=y,xs=xs))) + guidedf$SDI=unlist(lapply(names(DMDguideLines)[pltorder], function(x) c(x,x))) + linetype = 0 + for (idrow in seq(1,nrow(guidedf)-1,2)) + { + linetype = linetype+1 + p = p + annotate(geom="text",hjust="left", + label=paste0(guidedf$SDI[idrow]),size=2,y=guidedf$ys[idrow],x=guidedf$xs[idrow+1]) + + annotate("segment",y=guidedf$ys[idrow],yend=guidedf$ys[idrow+1],linetype=linetype, + x=guidedf$xs[idrow],xend=guidedf$xs[idrow+1],alpha=.4) + } + } + if (!is.null(StkChtguideLines)) + { + linetype = 1 + for (PCT in rev(names(StkChtguideLines))) + { + linetype = linetype+1 + p = p + geom_line(aes(x=xseq,y=yseq),show.legend=FALSE,alpha=.4, + linetype=if (PCT == "100%") 1 else linetype,data=StkChtguideLines[[PCT]]) + } + sq = seq(.95,0,-.05) + sq = if (input$YTrans=="log10") 10^(log10(rngy[2])*sq) else rngy[2]*sq + sq = sq[1:min(length(sq),length(names(StkChtguideLines)))] + xs = if (input$XTrans=="log10") 10^(log10(rngx[2])*c(.75,.9)) else rngx[2]*c(.75,.9) + guidedf = do.call(rbind,lapply(sq,function(y) data.frame(ys=y,xs=xs))) + guidedf$PCT=unlist(lapply(rev(names(StkChtguideLines)), function (x) c(x,x))) + linetype = 1 + for (idrow in seq(1,nrow(guidedf)-1,2)) + { + linetype = linetype+1 + p = p + annotate(geom="text",hjust="left", + label=paste0(guidedf$PCT[idrow]),size=2,y=guidedf$ys[idrow],x=guidedf$xs[idrow+1]) + + annotate("segment",y=guidedf$ys[idrow],yend=guidedf$ys[idrow+1],alpha=.4, + x=guidedf$xs[idrow],xend=guidedf$xs[idrow+1], + linetype=if (guidedf$PCT[idrow] == "100%") 1 else linetype) + } + p = p + geom_polygon(aes(x=X,y=Y), data = StkChtrng, color="Gray", alpha=.3, + show.legend = FALSE) + } + size = approxfun(c(50,100,1000),c(1,.7,.5),rule=2)(nrow(nd)) + + if (is.factor(nd$X)) nd$X = as.ordered(nd$X) + if (is.factor(nd$Y)) nd$Y = as.ordered(nd$Y) + pltp = input$plotType + if (pltp %in% c("DMD","StkCht")) pltp = "path" +cat ("pltp=",pltp," input$colBW=",input$colBW," hrvFlag is null=",is.null(hrvFlag),"\n") + p = p + switch(pltp, + line = if (input$colBW == "B&W") + geom_line (aes(x=X,y=Y,linetype=Legend),alpha=alpha) else + geom_line (aes(x=X,y=Y,color=Legend),alpha=alpha), + path = if (input$colBW == "B&W") + geom_path (aes(x=X,y=Y,linetype=Legend),alpha=alpha, + arrow=grid::arrow(angle=20,length=unit(6,"pt"), + ends="last",type="closed")) else + geom_path (aes(x=X,y=Y,color=Legend),alpha=alpha, + arrow=grid::arrow(angle=20,length=unit(6,"pt"), + ends="last",type="closed")), + scat = + geom_point (aes(x=X,y=Y,color=Legend,shape=Legend),size=size,alpha=alpha), + bar = if (input$colBW == "B&W") + geom_col (aes(x=X,y=Y,fill=Legend),color="black",size=.2,alpha=alpha, + position=input$barPlace) else + geom_col (aes(x=X,y=Y,fill=Legend),color="transparent",size=.1,alpha=alpha, + position=input$barPlace), + box = if (input$colBW == "B&W") + geom_boxplot (aes(x=X,y=Y,linetype=Legend),color="black",size=.6,alpha=alpha) else + geom_boxplot (aes(x=X,y=Y,color=Legend),linetype=1,size=.6,alpha=alpha) + ) + if (!is.null(hrvFlag) && any(hrvFlag)) p = p + + if (input$colBW == "B&W") + geom_point(aes(x=X,y=Y), shape=82, #the letter R is code 82 + data = nd[hrvFlag,], alpha=alpha, show.legend = FALSE) else + geom_point(aes(x=X,y=Y,color=Legend), shape=82, #the letter R is code 82 + data = nd[hrvFlag,], alpha=alpha, show.legend = FALSE) + if (input$colBW == "B&W" && pltp == "bar") + p = p + scale_fill_grey(start=.15, end=.85) + p = p + theme(text=element_text(size=9),plot.title = element_text(hjust = 0.5)) + p = p + switch(pltp, + line = if (input$colBW == "B&W") + guides(linetype=guide_legend(override.aes = list(alpha=1,size=.8), + title=legendTitle)) else + guides(colour=guide_legend(override.aes = list(alpha=1,size=.8), + title = legendTitle)), + path = if (input$colBW == "B&W") + guides(linetype=guide_legend(override.aes=list(alpha=1,size=.8), + arrow=grid::arrow(angle=20,length=unit(5,"pt"),ends="last",type="closed"), + title=legendTitle)) else + guides(colour=guide_legend(override.aes=list(alpha=1,size=.8), + arrow=grid::arrow(angle=20,length=unit(5,"pt"),ends="last",type="closed"), + title=legendTitle)), + scat = + guides(shape=guide_legend(override.aes = list(color=colors,alpha=1,size=1), + title = legendTitle),color="none"), + bar = + guides(fill=guide_legend(override.aes = list(alpha=.9,size=.6), + title = legendTitle, keywidth = .8, keyheight = .8)), + box = if (input$colBW == "B&W") + guides(linetype=guide_legend(override.aes = list(alpha=.8,size=.5), + title = legendTitle, keywidth = .8, keyheight = .8)) else + guides(color=guide_legend(override.aes = list(alpha=.8,size=.5), + title = legendTitle, keywidth = .8, keyheight = .8))) + if (nlevels(nd$Legend)==1 || nlevels(nd$Legend)>30) + { + p = p + theme(legend.position="none") + if (nlevels(nd$Legend)>30) output$plotMessage=renderText("Over 30 legend items, legend not drawn.") + } else p = p + theme(legend.position=input$legendPlace) + outfile = "www/plot.png" + fvsOutData$plotSpecs$res = as.numeric(if (is.null(input$res)) 150 else input$res) + fvsOutData$plotSpecs$width = as.numeric(input$width) + fvsOutData$plotSpecs$height = as.numeric(input$height) + CairoPNG(outfile, width=fvsOutData$plotSpecs$width, + height=fvsOutData$plotSpecs$height, units="in", + res=fvsOutData$plotSpecs$res) + print(p) + dev.off() + globals$gFreeze = FALSE + list(src = outfile) + }, deleteFile = FALSE) + + ## copyplot + observe( + if (input$copyplot > 0) + { +cat ("copyToClipboard copyplot\n") + session$sendCustomMessage(type="copyEltToClipboard", "outplot") + } + ) + + ## Stands tab + observe({ + if (input$topPan == "Simulate" || input$rightPan == "Stands") + { +cat ("Stands\n") + f1=system.file("extdata", "FVS_Data.db.default",package="fvsOL") + output$sayDataSource <-renderUI((h4(paste0( + if (areFilesIdentical(f1=f1,f2="FVS_Data.db")) "Training" else "User", + " data installed")))) + initNewInputDB(session,output,dbGlb) + loadStandTableData(globals, dbGlb$dbIcon) + updateStandTableSelection(session,input,globals) + loadVarData(globals,input,dbGlb$dbIcon) + updateVarSelection(globals,session,input) + } + }) + + ## inTabs has changed + observe({ + if (is.null(input$inTabs)) return() + reloadStandSelection(session,input) +cat ("inTabs\n") + }) + + ## inVars has changed + observe({ + if (is.null(input$inVars)) return() + globals$activeVariants = input$inVars + globals$activeExtens = c("base",globals$activeFVS[[paste0("FVS",globals$activeVariants)]][-1]) + reloadStandSelection(session,input) +cat ("inVars globals$activeVariants=",globals$activeVariants, + " globals$activeExtens=",globals$activeExtens," \n") + }) + + ## reloadStandSelection + reloadStandSelection <- function (session,input) + isolate({ +cat ("in reloadStandSelection\n") + if (is.null(input$inTabs) || is.null(input$inVars)) return() + sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) "StandPlot_ID" else "Stand_ID" + grps = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups, INV_YEAR from ",input$inTabs, + ' where lower(variant) like "%',tolower(input$inVars),'%"'))) + grps <- subset(grps, !is.na(grps[grep("inv_year",tolower(names(grps)))])) + grps <- subset(grps, grps[grep("inv_year",tolower(names(grps)))] !="") + if (class(grps) == "try-error" || is.null(grps) || nrow(grps) == 0) + { + dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") + dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.Grps"),data.frame(Stand_ID="",Grp="")) + updateSelectInput(session=session, inputId="inGrps",choices=list()) + updateSelectInput(session=session, inputId="inStds",list()) + } else { + if(tolower(input$inVars)=="cr"){# check for 5 GENGYM submodel variant codes in the input data + test <- try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct variant from ',input$inTabs))) + test=sort(unique(tolower(scan(text=gsub(","," ",test[,1]),what="character", + strip.white=TRUE,sep=" ",quiet=TRUE)))) + CRsubModels <- c("sm","sp","bp","sf","lp") + if(any(!is.na(match(test,CRsubModels)))){ + CRsubModels <- CRsubModels[na.omit(match(test,CRsubModels))] + for(i in 1:length(CRsubModels)){ + subgrps <- try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,",Groups from ",input$inTabs, + ' where lower(variant) like "%',tolower(CRsubModels[i]),'%"'))) + if(length(subgrps))grps <- rbind(grps,subgrps) + } + } + } + dd = apply(grps,1,function (x) + { + gr=unlist(strsplit(x[2]," ")) + st=rep(x[1],length(gr)) + attributes(st) = NULL + attributes(gr) = NULL + list(st,gr) + }) + dd = lapply(dd,function(x) matrix(unlist(x),ncol=2)) + dd = do.call(rbind,dd) + colnames(dd) = c(if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) + "StandPlot_ID" else "Stand_ID","Grp") + dd = as.data.frame(dd) + dbExecute(dbGlb$dbIcon,"drop table if exists temp.Grps") + dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.Grps"),dd) + selGrp = dbGetQuery(dbGlb$dbIcon, + 'select distinct Grp from temp.Grps order by Grp')[,1] + updateSelectInput(session=session, inputId="inGrps", + choices=as.list(selGrp)) + updateSelectInput(session=session, inputId="inStds", + choices=list()) + output$stdSelMsg <- renderUI(NULL) + } + }) + + ## inGrps, inAnyAll, or inStdFindBut has changed + observe({ + if (input$topPan == "Simulate" || input$rightPan == "Stands") + { +cat ("inGrps inAnyAll inStdFindBut\n") + # insure reactivity to inStdFindBut + input$inStdFindBut + if (is.null(input$inGrps)) + { + output$stdSelMsg <- renderUI(NULL) + updateSelectInput(session=session, inputId="inStds", + choices=list()) + } else { + dbExecute(dbGlb$dbIcon,"drop table if exists temp.SGrps") + dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.SGrps"),data.frame(SelGrps = input$inGrps)) + sid = if (input$inTabs %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) + "StandPlot_ID" else "Stand_ID" + stds = try(dbGetQuery(dbGlb$dbIcon,paste0('select ',sid,' from temp.Grps ', + 'where Grp in (select SelGrps from temp.SGrps)'))) + if (class(stds) == "try-error") return() +cat ("inGrps, nrow(stds)=",nrow(stds),"\n") + globals$selStds = stds[,1] + globals$selStds = if (input$inAnyAll == "Any") unique(globals$selStds) else + { + stdCnts = table(globals$selStds) + names(stdCnts[stdCnts == length(input$inGrps)]) + } + isolate({ +cat ("input$inStdFind=",input$inStdFind,"\n") + srchStr = input$inStdFind + if (length(globals$selStds) && nchar(srchStr)) globals$selStds = + globals$selStds[grep(srchStr,globals$selStds)] + }) + nstds = length(globals$selStds) + msg = paste0(length(globals$selStds)," Stand(s) in ",length(input$inGrps)," Group(s)") + if (nchar(srchStr)) msg = paste0(msg," and matching search string ",srchStr) + msg = paste0(msg,"
") + output$stdSelMsg <- renderUI(HTML(msg)) + stds = if (length(globals$selStds) <= 220) globals$selStds else + c(globals$selStds[1:200],paste0("<< Display 201 to ", + min(400,length(globals$selStds ))," of ",length(globals$selStds )," >>")) + updateSelectInput(session=session, inputId="inStds", + choices=as.list(stds)) + } + } + }) + ## inStds has changed + observe({ +cat ("inStds, length(input$inStds)=",length(input$inStds),"\n") + if (length(input$inStds) != 1) return() + prts = unlist(strsplit(input$inStds[1]," ")) + if (prts[1] != "<<") return() + nprts = as.numeric(prts[c(3,5,7)]) +cat ("inStds, nprts=",nprts,"\n") + up = nprts[c(1,2)] - 200 + if (up[2]-up[1] < 200) up[2] = min(up[1]+200,length(globals$selStds)) + upM = if (up[1] > 0) paste0("<< Display ",up[1]," to ", + min(up[2],length(globals$selStds))," of ", + length(globals$selStds)," >>") else NULL + dn = nprts[c(1,2)] + 200 + if (dn[2]-dn[1] < 200) dn[2] = min(dn[1]+200,length(globals$selStds)) + dn[2] = min(dn[2],length(globals$selStds)) + dnM = if (dn[1] <= length(globals$selStds)) paste0("<< Display ",dn[1]," to ", + dn[2]," of ",length(globals$selStds)," >>") else NULL + stds = c(upM,globals$selStds[nprts[1]:nprts[2]],dnM) +cat ("inStds upM=",upM," dnM=",dnM,"\n") + updateSelectInput(session=session, inputId="inStds", + choices=as.list(stds)) + }) + + ## Save saveRun + observe({ + if (input$saveRun > 0) + { +cat ("saveRun\n") + saveRun(input,session) + updateSelectInput(session=session, inputId="runSel", + choices=globals$FVS_Runs,selected=globals$FVS_Runs[[1]]) + } + }) + + ## New run + observe({ + if (input$newRun > 0) + { + saveRun(input,session) + resetfvsRun(globals$fvsRun,globals$FVS_Runs) + globals$fvsRun$title <- nextRunName(names(globals$FVS_Runs)) + storeFVSRun(dbGlb$prjDB,globals$fvsRun) + globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) +cat("New run, calling resetGlobals\n") + resetGlobals(globals,TRUE) + if (length(globals$GenGrp)) globals$GenGrp <- list() + if (length(globals$GrpNum)) globals$GrpNum <- numeric(0) + updateTextInput(session=session, inputId="title", value=globals$fvsRun$title) +cat ("in new run, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID,"\n") + updateTextInput(session=session, inputId="defMgmtID", + value=globals$fvsRun$defMgmtID) + updateSelectInput(session=session, inputId="simCont",choices=list()) + output$contCnts <- renderUI(HTML(paste0("Run contents: ", + length(globals$fvsRun$stands)," stand(s), ", + length(globals$fvsRun$grps)," group(s)"))) + updateSelectInput(session=session, inputId="addMgmtCats",choices=list()) + updateSelectInput(session=session, inputId="addMgmtCmps",choices=list()) + updateTextInput(session=session, inputId="startyr", + value=globals$fvsRun$startyr) + updateTextInput(session=session, inputId="endyr", + value=globals$fvsRun$endyr) + updateTextInput(session=session, inputId="cyclelen", + value=globals$fvsRun$cyclelen) + updateTextInput(session=session, inputId="cycleat", + value=globals$fvsRun$cycleat) + updateTextInput(session=session, inputId="inReps",value="1") + updateTextInput(session=session, inputId="inRwts",value="1") + output$runProgress <- renderUI(NULL) + updateSelectInput(session=session, inputId="rightPan", + selected="Stands") + updateSelectInput(session=session, inputId="compTabSet", + selected="Management") + updateSelectInput(session=session, inputId="runScript", + selected="fvsRun") + updateCheckboxGroupInput(session=session, "autoSVS", choices=list("Stand visualization:"="autoSVS")) + updateRadioButtons(session=session,inputId="svsPlotShape",selected="Round") + updateNumericInput(session=session,inputId="svsNFire",value=4) + updateCheckboxGroupInput(session=session, "autoOut", choices=list( + "Tree lists (FVS_Treelist, FVS_CutList (StdStk-stand and stock))"="autoTreelists", + "Carbon and fuels (FVS_Carbon, FVS_Consumption, FVS_Hrv_Carbon, FVS_Fuels)"="autoCarbon", + "Fire and mortality (FVS_Potfire, FVS_BurnReport, FVS_Mortality)"="autoFire", + "Snags and down wood (FVS_SnagSum, FVS_Down_Wood_Cov, FVS_Down_Wood_Vol)"="autoDead", + "FFE canopy profile (FVS_CanProfile)"="autoCanProfile", + "FFE detailed snag (FVS_SnagDet)"="autoSnagDet", + "Stand structure (FVS_StrClass)"="autoStrClass", + "Calibration statistics (FVS_CalibStats)"="autoCalibStats", + "Climate-FVS (FVS_Climate)"="autoClimate", + "Economics (FVS_EconSummary, FVS_EconHarvestValue)"="autoEcon", + "Mistletoe detail by tree size (FVS_DM_Sz_Sum)"="autoDM_Sz_Sum", + "Western Root Disease summary (FVS_RD_Sum)"="autoRD_Sum", + "Western Root Disease details (FVS_RD_Det)"="autoRD_Det", + "Western Root Disease bark beetles (FVS_RD_Beetle)"="autoRD_Beetle", + "Inventory statistics (FVS_Stats_Species, FVS_Stats_Stand)"="autoInvStats", + "Regeneration (All Variants: FVS_Regen_Sprouts, FVS_Regen_SitePrep, FVS_Regen_Tally. + AK, EM, KT, IE, and CI variants also get: FVS_Regen_HabType, FVS_Regen_Ingrowth)"="autoRegen", + "Produce all standard FVS text outputs (otherwise some are suppressed)"="autoDelOTab" + ), selected=list()) + isolate ({ + loadStandTableData(globals, dbGlb$dbIcon) + updateSelectInput(session=session, inputId="inTabs", choices=globals$selStandTableList, + selected=if (length(globals$selStandTableList)) globals$selStandTableList[[1]] else NULL) + updateSelectInput(session=session, inputId="inGrps", NULL, NULL) + updateSelectInput(session=session, inputId="inStds", NULL, NULL) + updateTabsetPanel(session=session, inputId="rightPan",selected="Stands") + loadVarData(globals,input,dbGlb$dbIcon) + updateVarSelection(globals,session,input) + }) + updateSelectInput(session=session, inputId="runSel", + choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) + globals$changeind <- 0 + output$contChange <- renderUI("Run") + } + }) + + + ## Duplicate run + observe({ + if (input$dupRun > 0) + { + if (length(globals$FVS_Runs) == 0) return() + isolate(if (is.null(input$runSel)) return()) + saveRun(input,session) + globals$fvsRun$title <- mkNameUnique(globals$fvsRun$title,names(globals$FVS_Runs)) + globals$fvsRun$uuid <- uuidgen() + globals$fvsRun$defMgmtID <- nextMgmtID(length(globals$FVS_Runs)) + storeFVSRun(dbGlb$prjDB,globals$fvsRun) + globals$FVS_Runs=getFVSRuns(dbGlb$prjDB) + updateTextInput(session=session, inputId="title", label="Run title", + value=globals$fvsRun$title) + updateTextInput(session=session, inputId="defMgmtID", + value=globals$fvsRun$defMgmtID) + updateSelectInput(session=session, inputId="compTabSet", + selected="Management") + updateSelectInput(session=session, inputId="runSel", + choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) + globals$changeind <- 0 + output$contChange <- renderUI("Run") + } + }) + + ## updateAutoOut + updateAutoOut <- function(session,autoOut) + { +cat ("updateAutoOut called\n") + if (!is.null(autoOut) && is.null(names(autoOut))) # block is for backward compatibility, after 2021 it can be deleted. + { + updateCheckboxGroupInput(session=session, inputId="autoOut", + selected=autoOut) + if ("autoSVS" %in% unlist(autoOut)) updateCheckboxGroupInput(session=session, + inputId="autoSVS",selected="autoSVS") + } else { + if (is.null(autoOut)) return() + updateCheckboxGroupInput(session=session, inputId="autoOut", + selected=autoOut[["autoOut"]]) + updateCheckboxGroupInput(session=session,inputId="autoSVS",selected=autoOut[["svsOut"]][["svs"]]) + updateRadioButtons(session=session,inputId="svsPlotShape",selected=autoOut[["svsOut"]][["shape"]]) + updateNumericInput(session=session,inputId="svsNFire",value=as.numeric(autoOut[["svsOut"]][["nfire"]])) + } + } + + ## Reload or Run Selection + observe({ + if (input$reload > 0 || !is.null(input$runSel)) + isolate({ + if (length(globals$fvsRun$uuid) && input$runSel != globals$fvsRun$uuid) saveRun(input,session) +cat ("reload or run selection, runSel=",input$runSel," lensim=", +length(globals$fvsRun$simcnts)," globals$currentQuickPlot=",globals$currentQuickPlot,"\n") + if (length(globals$currentQuickPlot) && + globals$currentQuickPlot != input$runSel) + { +cat("setting uiRunPlot to NULL\n") + output$uiRunPlot <- output$uiErrorScan <- renderUI(NULL) + globals$currentQuickPlot = character(0) + } + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + progress <- shiny::Progress$new(session,min=1,max=5) + progress$set(message = "Loading selected run",value = 1) + resetGlobals(globals,FALSE) + sel = match (input$runSel,globals$FVS_Runs) + if (is.na(sel)) sel = 1 + saveFvsRun = loadFVSRun(dbGlb$prjDB,globals$FVS_Runs[sel]) + # make sure the saved object has the correct class. This will fix load errors from old projects + if (! identical(attributes(class(saveFvsRun)),attributes(class(globals$fvsRun)))) + attributes(class(saveFvsRun)) = attributes(class(globals$fvsRun)) + globals$fvsRun = saveFvsRun + + if (length(globals$fvsRun$stands)) for (i in 1:length(globals$fvsRun$stands)) + { + if (length(globals$fvsRun$stands[[i]]$grps) > 0) + for (j in 1:length(globals$fvsRun$stands[[i]]$grps)) + { + if (length(globals$fvsRun$stands[[i]]$grps[[j]]$cmps) > 0) + for (k in 1:length(globals$fvsRun$stands[[i]]$grps[[j]]$cmps)) + { + test <- globals$fvsRun$stands[[i]]$grps[[j]]$cmps[[k]]$kwds + spgtest <- grep("^SpGroup",test) + cntr <- 0 + spgname <- list() + if (length(spgtest)) + { + cntr<-cntr+1 + spgname[cntr] <- trim(unlist(strsplit(strsplit(test, split = "\n")[[1]][1], + split=" "))[length(unlist(strsplit(strsplit(test, split = "\n")[[1]][1],split=" ")))]) + if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else + globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 + + spgname[1] <- gsub(" ","", spgname[1]) + tmpk <- match(spgname[1], globals$GenGrp) + if (!is.na(tmpk)) + { + globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] + } else globals$GenGrp[length(globals$GrpNum)]<-spgname + } + } + } + } + resetGlobals(globals,TRUE) + tmp = unlist(globals$activeFVS[globals$fvsRun$FVSpgm]) + globals$lastRunVar = if (length(tmp) && !is.null(tmp)) tmp[1] else + if (length(globals$fvsRun$FVSpgm) && nchar(globals$fvsRun$FVSpgm)>4) + substring(globals$fvsRun$FVSpgm,4) else globals$lastRunVar + mkSimCnts(globals$fvsRun,sels=globals$fvsRun$selsim, + justGrps=isolate(input$simContType)=="Just groups") + output$uiCustomRunOps = renderUI(NULL) +cat ("reloaded globals$fvsRun$title=",globals$fvsRun$title," uuid=",globals$fvsRun$uuid,"\n") +cat ("reloaded globals$fvsRun$runScript=",globals$fvsRun$runScript,"\n") + if (length(globals$fvsRun$uiCustomRunOps)) lapply(names(globals$fvsRun$uiCustomRunOps), function (x,y) +cat ("globals$fvsRun$uiCustomRunOps$",x,"=",y[[x]],"\n",sep=""),globals$fvsRun$uiCustomRunOps) else +cat ("globals$fvsRun$uiCustomRunOps is empty\n") + if ((globals$changeind==0 && !length(globals$currentQuickPlot)) && length(globals$fvsRun$simcnts)>0) + { + if (input$rightPan != "Components" && length(globals$fvsRun$simcnts)>0) + { + updateTabsetPanel(session=session, inputId="rightPan", + selected="Components") + } + if (input$rightPan != "Stands" && length(globals$fvsRun$simcnts)==0) + { + updateTabsetPanel(session=session, inputId="rightPan", + selected="Stands") + } + } + progress$set(message = paste0("Setting values for run ", globals$fvsRun$title), + value = 2) + updateAutoOut(session, globals$fvsRun$autoOut) + updateTextInput(session=session, inputId="title", value=globals$fvsRun$title) +cat ("in Reload, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID,"\n") + updateTextInput(session=session, inputId="defMgmtID", + value=globals$fvsRun$defMgmtID) + for (id in c("addMgmtCats","addMgmtCmps","addModCats","addModCmps", + "addEvCmps","addKeyExt","addKeyWds")) + updateSelectInput(session=session, inputId=id,selected=0) + updateTextInput(session=session, inputId="startyr", + value=globals$fvsRun$startyr) + updateTextInput(session=session, inputId="endyr", + value=globals$fvsRun$endyr) + updateTextInput(session=session, inputId="cyclelen", + value=globals$fvsRun$cyclelen) + updateTextInput(session=session, inputId="cycleat", + value=globals$fvsRun$cycleat) + updateVarSelection(globals,session,input) + progress$set(message = paste0("Setting simulation contents for run ", + globals$fvsRun$title),value = 3) + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + loadVarData(globals,input,dbGlb$dbIcon) + updateVarSelection(globals,session,input) + output$contCnts <- renderUI(HTML(paste0("Run contents: ", + length(globals$fvsRun$stands)," stand(s), ", + length(globals$fvsRun$grps)," group(s)"))) + updateStandTableSelection(session,input,globals) + loadVarData(globals,input,dbGlb$dbIcon) + updateVarSelection(globals,session,input) + # if the update causes a change in the runscript selection, then + # customRunOps will get called automatically. If it is the same + # script then it needs to be called here to update/set the settings. + progress$set(message = "Setting custom run options ",value = 4) + callCustom = length(globals$fvsRun$runScript) && + globals$fvsRun$runScript == input$runScript + updateSelectInput(session=session, inputId="runScript", + selected=globals$fvsRun$runScript) + if (!is.na(callCustom) && callCustom) customRunOps() + progress$close() + }) + }) + + ## autoOut + observe({ + input$autoOut + input$autoSVS + { +cat ("autoOut changed, input$autoSVS=",input$autoSVS,"\n") + out<-list(svsOut=list(svs=input$autoSVS,shape=input$svsPlotShape,nfire=input$svsNFire), + autoOut=as.list(input$autoOut)) + if (identical(out,globals$fvsRun$autoOut)) return() + globals$fvsRun$autoOut <- out + updateAutoOut(session, globals$fvsRun$autoOut) + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + } + }) + + ## inAdd: Add Selected Stands + observeEvent(input$inAdd, { + cat("In inAdd\n") + cat("input$inAdd=", input$inAdd, "\n") + cat("number of stands to add=", length(input$inStds), "\n") + + if(length(input$inStds)) + { + addStandsToRun(session,input,output,selType="inAdd",globals,dbGlb) + updateVarSelection(globals,session,input) + } + else + { + cat("No stands selected") + } + }) + + # observe({ + # if (input$inAdd > 0) + # { + # cat("Launch inAdd!!!") + # cat ("input$inAdd=",input$inAdd,"\n") + # + # addStandsToRun(session,input,output,selType="inAdd",globals,dbGlb) + # updateVarSelection(globals,session,input) + # } + # }) + + ## inAddGrp: Add all stands in selected groups + observeEvent(input$inAddGrp, { + cat("In inAddGrp\n") + cat("input$inAddGrp=", input$inAdd, "\n") + cat("number of groups to add=", length(input$inStds), "\n") + + if(length(input$inGrps)) + { + addStandsToRun(session,input,output,selType="inAddGrp",globals,dbGlb) + updateVarSelection(globals,session,input) + } + else + { + cat("No groups selected") + } + }) +# observe({ +# if (input$inAddGrp > 0) +# { +# cat (" input$inAddGrp=",input$inAddGrp,"\n") +# addStandsToRun(session,input,output,selType="inAddGrp",globals,dbGlb) +# updateVarSelection(globals,session,input) +# } +# }) + + ## inStdFindBut: Find and select stands in the stand list that match the search string + observe({ + if (input$inStdFindBut > 0) + { +cat ("input$inStdFindBut=",input$inStdFindBut,"\n") + } + }) + + ## run element selection + observe({ + if (length(input$simCont) == 0) return() +cat ("run element selection\n") + if (all(input$simCont == globals$fvsRun$selsim)) return() + mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=isolate(input$simContType=="Just groups")) + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + }) + + ## findStand (set run element to item if found) + observe({ + if (input$searchNext== 0) return() + isolate ({ +cat ("searchNext: string=",input$searchString,"\n") + if (nchar(input$searchString) == 0) return() + elt = findStand(globals,search=input$searchString) +cat ("elt=",elt,"\n") + if (is.null(elt)) return() + if (input$simContType=="Just groups") updateRadioButtons(session=session, + inputId="simContType", selected="Full run") + mkSimCnts(globals$fvsRun,sels=elt,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=elt) + })}) + + ## Edit + observe({ + if (input$editSel == 0) return() + isolate ({ + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + globals$currentEditCmp <- globals$NULLfvsCmp + if (length(input$simCont) == 0) return() + toed = input$simCont[1] + # find component + cmp = findCmp(globals$fvsRun,toed) + if (is.null(cmp)) return() + globals$currentEditCmp = cmp + if (length(cmp$kwdName) == 0) cmp$kwdName="freeEdit" +cat ("Edit, cmp$kwdName=",cmp$kwdName,"toed=",toed,"\n") + eltList = NULL + if (cmp$kwdName=="freeEdit") + { + eltList <- mkFreeformEltList(globals,input,prms,cmp$title,cmp$kwds) + rtn <- if (cmp$atag=="c") list(h5(), + div(myInlineTextInput("cmdTitle","Condition title ", + value=globals$currentEditCmp$title,size=40)),h5()) else + list(h5(),div(myInlineTextInput("cmdTitle","Component title ", + value=globals$currentEditCmp$title,size=40)),h5()) + if(length(globals$currentEditCmp$title)) rtn <- append(rtn,list( + h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) + output$titleBuild <- renderUI(rtn) + } else + { + if (length(cmp$kwdName) && nchar(cmp$kwdName)) + { + if (exists(cmp$kwdName)) #if a function exists, use it. + { + eltList <- eval(parse(text=paste0(cmp$kwdName, + "(globals$currentEditCmp$title,prms,globals,input,output)"))) + if (is.null(eltList)) return(NULL) + eltList <- eltList[[1]] + rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", + value=globals$currentEditCmp$title,size=40)),h5()) + if(length(globals$currentEditCmp$title)) rtn <- append(rtn,list( + h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) + output$titleBuild <- renderUI(rtn) + } else { + pk <- match (cmp$kwdName,names(prms)) + if (!is.na(pk)) # FreeForm Edit, used if pk does not match a parms. + { # Launch general purpose builder when pk matches a parms. + pkeys <- prms[[pk]] + eltList <- mkeltList(pkeys,prms,globals,input,output, + cmp$atag=="c",FALSE,globals$currentEditCmp$title) + } + } + } + } + if (is.null(eltList)) + { + rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", + value=globals$currentEditCmp$title,size=40)),h5()) + rtn <- append(rtn,list( + h4(paste0('Edit: "',globals$currentEditCmp$title),'"')),after=0) + output$titleBuild <- renderUI(rtn) + eltList <- mkFreeformEltList(globals,input,prms,globals$currentEditCmp$title, + globals$currentEditCmp$kwds) + } + eltList <- append(eltList,list( + tags$style(type="text/css", "#cmdCancel {color:red;}"), + actionButton("cmdCancel","Cancel"), + tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), + actionButton("cmdSaveInRun","Save in run"))) + output$cmdBuild <- renderUI(eltList) + output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + if (input$rightPan != "Components") { + updateTabsetPanel(session=session, + inputId="rightPan",selected="Components") + updateSelectInput(session=session, + inputId="compTabSet", selected="Management") + } + if (input$rightPan == "Components" && input$compTabSet !="Management") { + updateSelectInput(session=session, + inputId="compTabSet", selected="Management") + output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + } + for (id in c("addMgmtCats","addMgmtCmps","addModCats","addModCmps", + "addEvCmps","addKeyExt","addKeyWds")) + updateSelectInput(session=session, inputId=id, selected=0) + }) + }) + # install callback functionality for the textarea that has the focus + # to get start and end selection poistions. + observe({ + if (length(input$freeEdit)) + { + session$sendCustomMessage(type="getStartEnd", "freeEdit") + } + }) + ## focusedElement + observe({ + if (length(input$focusedElement) && + input$focusedElement %in% c("freeEdit","condDisp")) + session$sendCustomMessage(type="getStartEnd", input$focusedElement) + }) + ## freeSpecies + observe({ + if (length(input$freeSpecies) && nchar(input$freeSpecies)) + insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeSpecies) + }) + ## freeVars + observe({ + if (length(input$freeVars) && nchar(input$freeVars)) + insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeVars) + }) + ## freeOps + observe({ + if (length(input$freeOps) && nchar(input$freeOps)) + insertStringIntoFocusedTextarea(input,input$focusedElement,input$freeOps) + }) + ## freeFuncs + observe({ + if (length(input$freeFuncs) && nchar(input$freeFuncs) && input$freeFuncs != " ") + isolate({ + pkeys = prms[[paste0("evmon.function.",input$freeFuncs)]] + if (is.null(pkeys)) insertStringIntoFocusedTextarea(input, + input$focusedElement,paste0(input$freeFuncs,"()")) else + { + eltList <- mkeltList(pkeys,prms,globals,globals$fvsRun,funcflag=TRUE) + eltList <- append(eltList,list( + actionButton("fvsFuncInsert","Insert function"), + actionButton("fvsFuncCancel","Cancel function"),h6())) + output$fvsFuncRender <- renderUI(eltList) + } + }) + }) + ## fvsFuncCancel + observe({ + if (length(input$fvsFuncCancel) && input$fvsFuncCancel) + { + output$fvsFuncRender <- renderUI (NULL) + updateSelectInput(session=session, inputId="freeFuncs",selected=1) + } + }) + ## fvsFuncInsert + observe({ + if (length(input$fvsFuncInsert) && input$fvsFuncInsert) + isolate({ + pkeys = prms[[paste0("evmon.function.",input$freeFuncs)]] + ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) + reopn = NULL + fn = 0 + repeat + { + fn = fn+1 + pkey = paste0("f",fn) + fps = getPstring(pkeys,pkey,globals$activeVariants[1]) + if (is.null(fps)) break + pkey = paste0("func.f",fn) + instr = input[[pkey]] + reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) + names(reopn)[fn] = pkey + } + string = mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) + insertStringIntoFocusedTextarea(input,input$focusedElement,string) + }) + }) + + ## insertStringIntoFocusedTextarea + insertStringIntoFocusedTextarea <- function(input,textarea,string) + { + isolate({ + if (is.null(textarea)) textarea="freeEdit" + if (!is.null(string) && nchar(trim(string)) > 0) + { + if (length(input$selectionStart)) + { + start = input$selectionStart + end = input$selectionEnd + } else { start=0;end=0 } + len = nchar(input[[textarea]]) +cat ("insertStringIntoFocusedTextarea textarea=",textarea," string=",string," start=",start," end=",end," len=",len,"\n") + if (nchar(string) == 0) return() + if (start == end && end == len) { # prepend + updateTextInput(session, textarea, value = paste0(input[[textarea]],string)) + } else if (start == 0 && end == start) { # append + updateTextInput(session, textarea, value = paste0(string,input[[textarea]])) + } else if (end >= start) { # insert/replace + str = input[[textarea]] + updateTextInput(session, textarea, value = + paste0(substring(input[[textarea]],1,max(1,start)),string, + substring(input[[textarea]],min(end+1,len)))) + } + } + updateSelectInput(session=session, inputId="freeOps", selected=1) + updateSelectInput(session=session, inputId="freeVars",selected=1) + updateSelectInput(session=session, inputId="freeSpecies",selected=1) + updateSelectInput(session=session, inputId="freeFuncs",selected=1) + output$fvsFuncRender <- renderUI (NULL) + session$sendCustomMessage(type="refocus", textarea) + }) + } + + ## Cut + observe({ + if (input$cutCmp == 0) return() + isolate ({ +cat ("Cut length(input$simCont) = ",length(input$simCont),"\n") + if (length(input$simCont) == 0) return() + if (moveToPaste(input$simCont[1],globals,globals$fvsRun)) + { + globals$foundStand=0L + updateReps(globals$fvsRun) + mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + output$contCnts <- renderUI(HTML(paste0("Run contents: ", + length(globals$fvsRun$stands)," stand(s), ", + length(globals$fvsRun$grps)," group(s)"))) + updateSelectInput(session=session, inputId="selpaste", + choices=globals$pastelistShadow, + selected=if (length(globals$pastelistShadow)) + globals$pastelistShadow[[1]] else 0) + } + globals$changeind <- 1 + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + output$contChange <- renderText(HTML("*Run*")) + }) + }) + + + ## Copy + observe({ + if (input$copyCmp == 0) return() + isolate ({ + toCpy = findCmp(globals$fvsRun,input$simCont[1]) + if (is.null(toCpy)) return() + toCpy = mkfvsCmp(kwds=toCpy$kwds,kwdName=toCpy$kwdName, + exten=toCpy$exten,variant=toCpy$variant,uuid=uuidgen(), + atag=toCpy$atag,title=toCpy$title,reopn=toCpy$reopn) + globals$pastelist <- append(globals$pastelist,toCpy,after=0) + globals$pastelistShadow <- append(globals$pastelistShadow,toCpy$uuid,after=0) + names(globals$pastelistShadow)[1] = toCpy$title + updateSelectInput(session=session, inputId="selpaste", + choices=globals$pastelistShadow, + selected=if (length(globals$pastelistShadow)) + globals$pastelistShadow[[1]] else 0) + }) + }) + + + ## Paste + observe({ + if (input$paste == 0) return() + isolate ({ + if (length(input$simCont) == 0) return() + if (length(input$selpaste) == 0) return() + if (nchar(input$selpaste) == 0) return() + pidx = findIdx (globals$pastelist, input$selpaste) +cat("paste, pidx=",pidx,"\n") + if (is.null(pidx)) return() + topaste = globals$pastelist[[pidx]] + if (length(grep("^SpGroup",topaste$kwds))) + { +cat("paste, SpGroup hit\n") + cntr <- 0 + if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else + globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 + globals$GenGrp[length(globals$GrpNum)] <- topaste$reopn[[1]] + } +cat("paste, class(topaste)=",class(topaste),"\n") + if (class(topaste) != "fvsCmp") return() + topaste = mkfvsCmp(kwds=topaste$kwds,kwdName=topaste$kwdName, + exten=topaste$exten,variant=topaste$variant,uuid=uuidgen(), + atag=topaste$atag,title=topaste$title,reopn=topaste$reopn) + idx = pasteComponent(globals,input$simCont[1],topaste) + if (!is.null(idx)) + { + mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + output$contCnts <- renderUI(HTML(paste0("Run contents: ", + length(globals$fvsRun$stands)," stand(s), ", + length(globals$fvsRun$grps)," group(s)"))) + } + globals$foundStand=0L + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + }) + }) + + + ## Change to freeform + observe({ + if (input$mkfree == 0) return() + isolate ({ + globals$currentEditCmp <- globals$NULLfvsCmp + updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0) + if (length(input$simCont) == 0) return () + toed = input$simCont[1] + cmp = findCmp(globals$fvsRun,toed) + if (is.null(cmp)) return() + cmp$kwdName="freeEdit" + if (substring(cmp$title,1,10) != "Freeform: ") cmp$title=paste("Freeform: ",cmp$title) + cmp$reopn=character(0) + mkSimCnts(globals$fvsRun,sels=toed,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + output$titleBuild <-output$condBuild <- output$cmdBuild <- + output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + }) + }) + + ## Command Set + observe({ +cat ("compTabSet, input$compTabSet=",input$compTabSet, + " input$simCont=",length(input$simCont),"\n") + if(!length(globals$currentEditCmp$kwds) || input$compTabSet !="Management") + { + output$titleBuild <-output$condBuild <- output$cmdBuild <- + output$cmdBuildDesc <- output$fvsFuncRender <- renderUI (NULL) + } + if (length(globals$fvsRun$FVSpgm) == 0) return(NULL) + if (! globals$fvsRun$FVSpgm %in% names(globals$activeFVS)) return(NULL) + switch (input$compTabSet, + "Management" = + { + if (length(globals$mgmtsel) == 0) globals$mgmtsel <- mkMgmtCats(globals) + updateSelectInput(session=session, inputId="addMgmtCats", + choices=mkpair(globals$mgmtsel), selected = 0) + updateSelectInput(session=session, inputId="addMgmtCmps", + choices=list()) + }, + "Modifiers" = + { + if (length(globals$mmodsel) == 0) globals$mmodsel <- mkModMCats(globals) + updateSelectInput(session=session, inputId="addModCats", + choices=mkpair(globals$mmodsel), selected = 0) + updateSelectInput(session=session, inputId="addModCmps", + choices=list()) + }, + "Event Monitor"= + { + if (length(globals$mevsel) == 0) globals$mevsel <- mkEvMonCats(globals) + updateSelectInput(session=session, inputId="addEvCmps", + selected = 0,choices=mkpair(globals$mevsel[[1]])) + }, + "Economic"= + { + renderComponent(input,output,"ecn") + }, + "Keywords" = + { + if (length(globals$extnsel) == 0) mkextkwd(prms,globals) + updateSelectInput(session=session, inputId="addKeyExt", + label="Extensions", choices=globals$extnsel, selected = 0) + updateSelectInput(session=session, inputId="addKeyWds", + label="Keywords", choices=list()) + }, + "Editor" = + { + customCmps = NULL + if(length(globals$currentEditCmp$kwds) > 0) closeCmp() + if (length(globals$customCmps) == 0)loadObject(dbGlb$prjDB,"customCmps") + if (!is.null(customCmps)){ + globals$customCmps = customCmps + updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(customCmps)), + selected=names(customCmps)[1]) + } + eltList <- mkFreeformEltList(globals,input,prms,globals$currentEditCmp$title, + globals$currentEditCmp$kwds) + output$condBuild <- renderUI(NULL) + output$cmdBuild <-renderUI(eltList) + output$fvsFuncRender <- renderUI (NULL) + output$cmdBuildDesc <- renderUI(paste0("Description: This Editor menu allows you to", + " utilize the advanced features of the freeform text format for creating custom", + " component sets by directly adding & editing keyword records and Event Monitor", + " functions. You can upload an existing keyword component file (.kcp), or keyword", + " component archive (FVS_kcps.Rdata) and then save it into the Run Contents window", + " on the left (Save in run), and also save it in the component collection (Save in", + " component collection). You can also create your own component sets by appending", + " items from the Run Contents on the left (Append selected component from run)", + " and then saving them into your component collection (Save in component collection).", + " Finally, you can download a text file of your component set (Download(KCP)).")) + }, + NULL) + }) + ## kcpEdit + observe({ + if (length(input$kcpEdit)) + { + session$sendCustomMessage(type="getStartEnd", "kcpEdit") + } + }) + ## freeSpeciesKCP + observe({ + if (length(input$freeSpeciesKCP) && nchar(input$freeSpeciesKCP)) isolate({ + if (length(input$kcpEdit) == 0) return() + insertStrinIntokcpEdit(input,input$freeSpeciesKCP) + }) + }) + ## freeVarsKCP + observe({ + if (length(input$freeVarsKCP) && nchar(input$freeVarsKCP)) isolate({ + if (length(input$kcpEdit) == 0) return() + insertStrinIntokcpEdit(input,input$freeVarsKCP) + }) + }) + ## freeOpcKCP + observe({ + if (length(input$freeOpsKCP) && nchar(input$freeOpsKCP)) + isolate({ + if (length(input$kcpEdit) == 0) return() + insertStrinIntokcpEdit(input,input$freeOpsKCP) + }) + }) + ## freeFuncsKCP + observe({ + if (length(input$freeFuncsKCP) && nchar(input$freeFuncsKCP) && input$freeFuncsKCP != " ") + isolate({ + if (length(input$kcpEdit) == 0) return() + pkeys = prms[[paste0("evmon.function.",input$freeFuncsKCP)]] + if (is.null(pkeys)) insertStrinIntokcpEdit(input, + paste0(input$freeFuncsKCP,"()")) else + { + eltList <- mkeltList(pkeys,prms,globals,input,output,funcflag=TRUE) + eltList <- append(eltList,list( + actionButton("fvsFuncInsertKCP","Insert function"), + actionButton("fvsFuncCancelKCP","Cancel function"),h6())) + output$fvsFuncRender <- renderUI(eltList) + } + }) + }) + ## fvsFuncCancelKCP + observe({ + if (length(input$fvsFuncCancelKCP) && input$fvsFuncCancelKCP) + { + output$fvsFuncRender <- renderUI (NULL) + updateSelectInput(session=session, inputId="freeFuncsKCP",selected=1) + } + }) + ## fvsFuncInsertKCP + observe({ + if (length(input$fvsFuncInsertKCP) && input$fvsFuncInsertKCP) + isolate({ + pkeys = prms[[paste0("evmon.function.",input$freeFuncsKCP)]] + ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) + reopn = NULL + fn = 0 + repeat + { + fn = fn+1 + pkey = paste0("f",fn) + fps = getPstring(pkeys,pkey,globals$activeVariants[1]) + if (is.null(fps)) break + pkey = paste0("func.f",fn) + instr = input[[pkey]] + reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) + names(reopn)[fn] = pkey + } + string = mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) + insertStrinIntokcpEdit(input,string) + }) + }) + ## insertStrinIntokcpEdit + insertStrinIntokcpEdit <- function(input,string) + { + if (is.null(string) || nchar(string) == 0 || string == " ") return() + isolate({ + if (length(input$selectionStart)) + { + start = input$selectionStart + end = input$selectionEnd + } else { start=0;end=0 } + len = nchar(input$kcpEdit) +cat ("insertStrinIntokcpEdit string=",string," start=",start," end=",end," len=",len,"\n") + if (nchar(string) == 0) return() + if (start == end && end == len) { # prepend + updateTextInput(session, "kcpEdit", value = paste0(input$kcpEdit,string)) + } else if (start == 0 && end == start) { # append + updateTextInput(session, "kcpEdit", value = paste0(string,input$kcpEdit)) + } else if (end >= start) { # insert/replace + str = input$kcpEdit + updateTextInput(session, "kcpEdit", value = + paste0(substring(input$kcpEdit,1,max(1,start)),string, + substring(input$kcpEdit,min(end+1,len)))) + } + updateSelectInput(session=session, inputId="freeOpsKCP", selected=1) + updateSelectInput(session=session, inputId="freeVarsKCP",selected=1) + updateSelectInput(session=session, inputId="freeSpeciesKCP",selected=1) + updateSelectInput(session=session, inputId="freeFuncsKCP",selected=1) + output$fvsFuncRender <- renderUI (NULL) + }) + } + + ## addMgmtCats + observe({ + if (is.null(input$addMgmtCats)) return() + if (length(globals$mgmtsel)==0) globals$mgmtsel<-mkMgmtCats(globals) + updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0, + choices=globals$mgmtsel[[as.numeric(input$addMgmtCats)]]) + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) + }) + ## addModCats + observe({ + if (is.null(input$addModCats)) return() + if (length(globals$mmodsel) == 0) globals$mmodsel <- mkModMCats(globals) + updateSelectInput(session=session, inputId="addModCmps", selected = 0, + choices=globals$mmodsel[[as.numeric(input$addModCats)]]) + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) + }) + ## addKeyExt + observe({ + if (is.null(input$addKeyExt)) + updateSelectInput(session=session, inputId="addKeyWds", selected = 0, + choices=NULL) else + { + if (length(globals$mevsel) == 0) globals$mevsel <- mkEvMonCats(globals) + updateSelectInput(session=session, inputId="addKeyWds", selected = 0, + choices=globals$kwdsel[[input$addKeyExt]]) + } + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) + }) + ## addMgmtCmps + observe({ + if (length(input$addMgmtCmps) && + nchar(input$addMgmtCmps)) renderComponent(input,output,"mgt") + }) + ## addModCmps + observe({ + if (length(input$addModCmps) && + nchar(input$addModCmps)) renderComponent(input,output,"mod") + }) + ## addKeyWds + observe({ + if (length(input$addKeyWds) && + nchar(input$addKeyWds)) renderComponent(input,output,"key") + }) + ## addEvent + observe({ + if (length(input$addEvCmps) && + nchar(input$addEvCmps)) renderComponent(input,output,"evn") + }) + + ## renderComponent + renderComponent <- function(input,output,inCode="default") + { +cat ("renderComponent, inCode=",inCode,"\n") + isolate ({ + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) + globals$currentEditCmp <- globals$NULLfvsCmp + globals$currentCndPkey <- character(0) + switch (as.character(inCode), + "mgt" = + { + if (is.null(input$addMgmtCats)) return(NULL) + titIndx = try(match(input$addMgmtCmps, + globals$mgmtsel[[as.numeric(input$addMgmtCats)]])) + if (class(titIndx)=="try-error") return(NULL) + title = names(globals$mgmtsel[[as.numeric(input$addMgmtCats)]])[titIndx] + globals$currentCmdPkey = globals$mgmtsel[[as.numeric(input$addMgmtCats)]][titIndx] + }, + "mod" = + { + titIndx = try(match(input$addModCmps, + globals$mmodsel[[as.numeric(input$addModCats)]])) + if (class(titIndx)=="try-error") return(NULL) + title = names(globals$mmodsel[[as.numeric(input$addModCats)]])[titIndx] + globals$currentCmdPkey = globals$mmodsel[[as.numeric(input$addModCats)]][titIndx] + }, + "key" = + { + titIndx = try(match(input$addKeyWds, + globals$kwdsel[[input$addKeyExt]])) + if (class(titIndx)=="try-error") return(NULL) + title = names(globals$kwdsel[[input$addKeyExt]])[titIndx] + globals$currentCmdPkey = globals$kwdsel[[input$addKeyExt]][titIndx] + }, + "evn" = + { + globals$currentCmdPkey=globals$mevsel[[1]][as.numeric(input$addEvCmps)] + title = names(globals$currentCmdPkey) + }, + "ecn" = + { + title = "Economic analysis" + globals$currentCmdPkey = "econ Econ_reports" + }, + return(NULL) + ) +cat ("globals$currentCmdPkey=",globals$currentCmdPkey," title=",title,"\n") + cmdp = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) + if(length(cmdp)>1)cmdp <- cmdp[2] else cmdp <- cmdp[1] + # the cmdp can be a function name, or a ".Win" can be appended to form a + # function name. If a function does not exist, then try finding a prms entry. + if (exists(cmdp)) funName = cmdp + funName = paste0(cmdp,".Win") + if (!exists(funName)) funName = cmdp + if (!exists(funName)) funName = NULL +cat ("funName=",funName,"\n") + if (!is.null(funName)) + { + globals$winBuildFunction <- funName + ans = eval(parse(text=paste0(globals$winBuildFunction, + "(title,prms,globals,input,output)"))) + if (is.null(ans)) return(NULL) + ans[[1]] <- append(ans[[1]],list( + tags$style(type="text/css", "#cmdCancel {color:red;}"), + actionButton("cmdCancel","Cancel"), + tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), + actionButton("cmdSaveInRun","Save in run"))) + if (length(grep("freeEdit",ans[[1]]))==0) ans[[1]] <- append(ans[[1]], + list(tags$style(type="text/css","#cmdChgToFree {color:black}"), + actionButton("cmdChgToFree","Change to freeform"))) + rtn <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", value=title,size=40)),h5()) + output$titleBuild <- renderUI(rtn) + output$cmdBuild <- renderUI (if (length(ans[[1]])) ans[[1]] else NULL) + output$cmdBuildDesc <- renderUI (if (length(ans[[2]])) ans[[2]] else NULL) + } else { + globals$winBuildFunction <- character(0) + indx = match(cmdp,names(prms)) + if (is.na(indx)) return() + pkeys <- prms[[indx]] + eltList <- try(mkeltList(pkeys,prms,globals,input,output,FALSE,FALSE,title)) + if (class(eltList)=="try-error") + { + output$cmdBuildDesc = renderUI (HTML(paste0( + '
Error:
Programming for "',title,'" is incorrect.
'))) + return() + } + eltList <- append(eltList,list( + tags$style(type="text/css", "#cmdCancel {color:red;}"), + actionButton("cmdCancel","Cancel"), + tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), + actionButton("cmdSaveInRun","Save in run"), + actionButton("cmdChgToFree","Change to freeform"))) + output$cmdBuild <- renderUI (if (length(eltList)) eltList else NULL) + des <- getPstring(pkeys,"description",globals$activeVariants[1]) + output$cmdBuildDesc <- renderUI (if (!is.null(des) && nchar(des) > 0) + HTML(paste0("
Description:
",gsub("\n","
",des))) else NULL) + } + }) + } + + ## Thin from below window observer function + observe({ + if(is.null(input$tbf2)) return() + if(input$tbf2 == "1" || input$tbf2 == "2") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf3').prop('disabled',false)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf4').prop('disabled',false)")) + + if(input$tbf2 == "1" && input$tbf3 > 0 && input$tbf4 <= 0){ + updateTextInput(session=session,inputId ="tbf4", + value=round(sqrt(43560/as.numeric(input$tbf3)),digits=4)) + } + if(input$tbf2 == "2" && input$tbf3 <= 0 && input$tbf4 > 0){ + updateTextInput(session=session,inputId ="tbf3", + value=round(43560/(as.numeric(input$tbf4)^2),digits=2)) + } + if(input$tbf2 == "1" && input$tbf3 > 0 && input$tbf4 >0){ + updateTextInput(session=session,inputId ="tbf4", + value=round(sqrt(43560/as.numeric(input$tbf3)),digits=4)) + } + if(input$tbf2 == "2" && input$tbf3 > 0 && input$tbf4 >0){ + updateTextInput(session=session,inputId ="tbf3", + value=round(43560/(as.numeric(input$tbf4)^2),digits=2)) + } + + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf3').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf4').prop('disabled',true)")) + } + if(input$tbf2 == "3") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf5').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf5').prop('disabled',true)")) + } + if(input$tbf2 == "4") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf6').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf6').prop('disabled',true)")) + } + if(input$tbf2 == "5") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf7').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#tbf7').prop('disabled',true)")) + } + }) + + ## Thin from above window observer function + observe({ + if(length(input$taf2)==0) return() + if(input$taf2 == "1" || input$taf2 == "2") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf3').prop('disabled',false)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf4').prop('disabled',false)")) + + if(input$taf2 == "1" && input$taf3 > 0 && input$taf4 <= 0){ + updateTextInput(session=session,inputId ="taf4", + value=round(sqrt(43560/as.numeric(input$taf3)),digits=4)) + } + if(input$taf2 == "2" && input$taf3 <= 0 && input$taf4 > 0){ + updateTextInput(session=session,inputId ="taf3", + value=round(43560/(as.numeric(input$taf4)^2),digits=2)) + } + if(input$taf2 == "1" && input$taf3 > 0 && input$taf4 >0){ + updateTextInput(session=session,inputId ="taf4", + value=round(sqrt(43560/as.numeric(input$taf3)),digits=4)) + } + if(input$taf2 == "2" && input$taf3 > 0 && input$taf4 >0){ + updateTextInput(session=session,inputId ="taf3", + value=round(43560/(as.numeric(input$taf4)^2),digits=2)) + } + + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf3').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf4').prop('disabled',true)")) + } + if(input$taf2 == "3") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf5').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf5').prop('disabled',true)")) + } + if(input$taf2 == "4") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf6').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf6').prop('disabled',true)")) + } + if(input$taf2 == "5") { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf7').prop('disabled',false)")) + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#taf7').prop('disabled',true)")) + } +}) + + ## schedule box toggled. + observe({ + if (length(input$schedbox) == 0) return() +cat("input$schedbox=",input$schedbox,"\n") + if (input$schedbox == 1) + { + updateTextInput(session, globals$schedBoxPkey, + label = "Year or cycle number: ", + value = globals$schedBoxYrLastUsed) + output$conditions <- renderUI(NULL) + if (length(globals$toggleind)) globals$currentCndPkey <- character(0) + } else if (input$schedbox == 2) + { + updateTextInput(session, globals$schedBoxPkey, + label = "Number of years after condition is found true: ", value = "0") + cndlist = unlist(prms$conditions_list) + names(cndlist) = unlist(lapply(prms$conditions_list,attr,"pstring")) + cndlist = as.list(cndlist) + globals$toggleind <- "1" +cat("globals$currentCmdPkey=",globals$currentCmdPkey,"\n") + if (length(globals$currentCmdPkey)) + { + n = suppressWarnings(as.numeric(globals$currentCmdPkey)) + default = getPstring(prms[[if (is.na(n)) globals$currentCmdPkey else n]], + "defaultCondition",globals$activeVariants[1]) + if (is.null(default)) default="cycle1" + } else default = "cycle1" + output$conditions <- renderUI(list( + selectInput("condList", "Create a condition", cndlist, + selected = default, multiple = FALSE, selectize = FALSE), + uiOutput("condElts"))) + } else { + globals$currentCndPkey <- character(0) + updateTextInput(session, globals$schedBoxPkey, + label = "Number of years after condition is found true ", value = "0") + output$conditions <- renderUI( + selectInput("condList","Existing conditions", globals$existingCmps, + selected = NULL, multiple = FALSE, selectize = FALSE)) + } + }) + + ## schedule by condition selection + observe({ + if (length(input$schedbox) == 0) return() + if (length(input$condList) == 0) return() + if (length(globals$toggleind) && input$schedbox == 1) return() +cat("make condElts, input$condList=",input$condList,"\n") + if (input$condList == "none") output$condElts <- renderUI(NULL) else + { + cnpkey <- paste0("condition.",input$condList) + idx <- match(cnpkey,names(prms)) + globals$currentCndPkey <- if (is.na(idx)) character(0) else cnpkey + ui = if (identical(globals$currentCndPkey,character(0))) NULL else + { + eltList <- mkeltList(prms[[globals$currentCndPkey]],prms, + globals,input,output,cndflag=TRUE) + if (length(eltList) == 0) NULL else eltList + } + if (!is.null(ui)) + { + title = getPstring(prms$conditions_list,input$condList) + if (!is.null(title)) + { + ui <- append(ui,list(myInlineTextInput("condTitle","Condition title", + value=title, size=40)),after=1) + output$condElts <- renderUI(ui) + } + } + } + }) + + ## cmdChgToFree + observe({ + if (length(input$cmdChgToFree) == 0 || input$cmdChgToFree==0) return() + isolate({ +cat ("cmdChgToFree=",input$cmdChgToFree,"\n") + # process the condition first...if there is one. + if (length(globals$toggleind)>0 && length(globals$currentCndPkey) && + !is.null(input$schedbox) && input$schedbox == 2) + { +cat ("cmdChgToFree processing condition\n") + kwds = mkCondKeyWrd(globals,prms,input) + attr(kwds$kwds,"keywords") = "condDisp" + globals$currentCndPkey=kwds$kwds + updateTextInput(session, "condTitle",value=paste0("Freeform: ",input$condTitle)) + condUI <- list(myInlineTextInput("condTitle","Condition title", + value=paste0("Freeform: ",input$condTitle), size=40), + tags$style(type="text/css", + "#condDisp{font-family:monospace;font-size:90%;height:1in;width:100%;cursor:auto;}"), + tags$script('$(document).ready(function(){ $("textarea").on("focus", function(e){ Shiny.setInputValue("focusedElement", e.target.id);}); }); '), + tags$textarea(id="condDisp",kwds$kwds), + myInlineTextInput("cmdTitle","Component title", + value=paste0("Freeform: ",input$cmdTitle), size=40)) + output$titleBuild <- renderUI(NULL) + } else { + titleUI <- list(h5(),div(myInlineTextInput("cmdTitle","Component title ", paste0("Freeform: ",input$cmdTitle),size=40)),h5()) + output$titleBuild <- renderUI(titleUI) + condUI <- NULL + } +cat ("cmdChgToFree processing component\n") + if (length(globals$winBuildFunction)) + { + kwPname = globals$winBuildFunction + pkeys = character(0) + } else { + kwPname = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) + pkeys = if (length(kwPname)>1) prms[[kwPname[2]]] else prms[[kwPname[1]]] + } + kwds = buildKeywords(character(0),pkeys,kwPname,globals) + attr(kwds$kwds,"keywords") = "freeEdit" + attr(kwds$kwds,"extension") = kwds$ex + globals$currentCmdPkey = kwds$kwds + globals$winBuildFunction = character(0) + cmdUI <- mkFreeformEltList(globals,input,prms,paste0("Freeform: ",input$cmdTitle), + kwds$kwds) + cmdUI <- append(cmdUI,list( + tags$style(type="text/css", "#cmdCancel {color:red;}"), + actionButton("cmdCancel","Cancel"), + tags$style(type="text/css", "#cmdSaveInRun {color:green;}"), + actionButton("cmdSaveInRun","Save in run"))) + output$condBuild <- renderUI(condUI) + output$cmdBuild <- renderUI(cmdUI) + output$cmdBuildDesc <- renderUI(NULL) + session$sendCustomMessage(type="refocus", "freeEdit") + }) + }) + ## command Cancel + observe({ + if (length(input$cmdCancel) && input$cmdCancel == 0) return() + closeCmp() + }) + ## closeCmp + closeCmp <- function () + { + globals$currentEditCmp <- globals$NULLfvsCmp + globals$schedBoxPkey <- character(0) + updateSelectInput(session=session, inputId="addMgmtCmps", selected = 0) + updateSelectInput(session=session, inputId="addModCmps", selected = 0) + updateSelectInput(session=session, inputId="addKeyWds", selected = 0) + updateSelectInput(session=session, inputId="addEvCmps",selected = 0) + output$titleBuild <-output$condBuild <- output$cmdBuild <- output$cmdBuildDesc <- renderUI (NULL) + } + ## mkCondKeyWrd + mkCondKeyWrd <- function (globals,prms,input) + { + kwPname = globals$currentCndPkey +cat ("mkCondKeyWrd, kwPname=",kwPname,"\n") + pkeys = prms[[kwPname]] + ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) + if (is.null(ansFrm)) ansFrm = + getPstring(pkeys,"parmsForm",globals$activeVariants[1]) + reopn = NULL + fn = 0 + repeat + { + fn = fn+1 + pkey = paste0("f",fn) + fps = getPstring(pkeys,pkey,globals$activeVariants[1]) + if (is.null(fps)) break + instr = input[[paste0("cnd.",pkey)]] + reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) + names(reopn)[fn] = pkey + } + instr = input[["waitYears"]] + reopn = c(reopn,as.character(if (is.null(instr)) character(0) else instr)) + names(reopn)[length(names(reopn))] = "waitYears" + kwds = sprintf("%-10s%10s\n","If",if (is.null(instr)) " " else instr) + kwds = paste0(kwds,mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]), + "\nThen") + list(reopn=reopn,kwds=kwds) + } + ## buildKeywords + buildKeywords <- function(oReopn,pkeys,kwPname,globals) + { +cat ("in buildKeywords, oReopn=",oReopn," kwPname=",kwPname,"\n") + if (length(pkeys) == 0 && nchar(kwPname) || (length(globals$currentEditCmp$kwds) && + length(pkeys) > 0 && exists(paste0(kwPname,".mkKeyWrd")))) + { + # try to find a function that can make the keywords + fn = paste0(kwPname,".mkKeyWrd") + ans = if (exists(fn)) eval(parse(text=paste0(fn,"(input,output)"))) else NULL + } else { + # build from prms entry + ansFrm = getPstring(pkeys,"answerForm",globals$activeVariants[1]) + if (is.null(ansFrm)) + { + kw = if (length(kwPname) > 1) kwPname[2] else kwPname[1] + kw = unlist(strsplit(kw,".",fixed=TRUE)) + kw = kw[length(kw)] + ansFrm = paste0(substr(paste0(kw," "),1,10), + "!1,10!!2,10!!3,10!!4,10!!5,10!!6,10!!7,10!") + } + reopn = NULL + fn = 0 + repeat + { + fn = fn+1 + pkey = paste0("f",fn) + fps = getPstring(pkeys,pkey,globals$activeVariants[1]) + if (is.null(fps)) break + instr = if (length(globals$currentEditCmp$atag) && + globals$currentEditCmp$atag=="c") + input[[paste0("cnd.",pkey)]] else input[[pkey]] + if(is.null(instr))instr=" " + if(instr=="blank")instr=" " + if(length(grep("noInput",fps)))instr=" " + reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) + names(reopn)[fn] = pkey + } + kwds = if ("waitYears" %in% names(oReopn)) + { + instr = input[["waitYears"]] + if (!is.null(instr)) + { + reopn = c(reopn,as.character(if (is.null(instr)) " " else instr)) + names(reopn)[length(names(reopn))] = "waitYears" + kwds = sprintf("%-10s%10s\n","If",if (is.null(instr)) " " else instr) + paste0(kwds,mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]), + "\nThen") + } + } else mkKeyWrd(ansFrm,reopn,pkeys,globals$activeVariants[1]) + ans = list(ex=if (length(kwPname) > 1) kwPname[1] else if (length(grep("keyword.",kwPname))) gsub("[.].*","",gsub("keyword.","",kwPname)) + else "base", kwds=kwds,reopn=reopn) + if (length(kwPname) > 1 && length(grep("keyword.",kwPname))){ + kwd <- gsub("[.].*","",gsub("keyword.","",kwPname)) + if(kwd[2]=="estbstrp"){ + ans[1] <- if(length(grep("strp",globals$activeExtens))) "strp" else "estb" + } + } + } + ans + } + ## Save in run + observeEvent(input$cmdSaveInRun, { + if(!length(input$simCont)) + { + cat("No Active Stands\n") + showModal(shiny::modalDialog(title = "Cannot Perform Operation", + "'Run Contents' must contain at least one stand or group to perform this operation ")) + # showNotification("Must have at least one stand in Run Contents to perform this operation", + # type = 'warning') + return() + } + if (identical(globals$currentEditCmp,globals$NULLfvsCmp) && + identical(globals$currentCndPkey,character(0)) && + identical(globals$currentCmdPkey,character(0))) return() + if (length(globals$currentEditCmp$reopn) && + globals$currentEditCmp$reopn[1] == "pasteOnSave") + { + globals$currentEditCmp$reopn = character(0) + globals$currentEditCmp$kwds = input$freeEdit + if (!is.null(input$cmdTitle) && nchar(input$cmdTitle)) + globals$currentEditCmp$title = input$cmdTitle + idx = pasteComponent(globals,input$simCont[1],globals$currentEditCmp) + if (!is.null(idx)) + { + mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + } + globals$currentEditCmp <- globals$NULLfvsCmp + closeCmp() + return() + } + if (identical(globals$currentCndPkey,character(0))) newcnd = NULL else + if (is.null(attr(globals$currentCndPkey,"keywords"))) + { + kwds = mkCondKeyWrd(globals,prms,input) + newcnd = mkfvsCmp(uuid=uuidgen(),atag="c",exten="base", + kwdName=globals$currentCndPkey,title=input$condTitle, + kwds=kwds$kwds,reopn=kwds$reopn) + } else { + newcnd = mkfvsCmp(uuid=uuidgen(),atag="c", + exten="base",kwdName="freeEdit",title=input$condTitle, + kwds=if (attr(globals$currentCndPkey,"keywords")=="condDisp") + input$condDisp else input$freeForm, + reopn=character(0)) + } + # make or edit a keyword. This section is used for both + # building a keyword and editing a keyword or a condition. + # if this is true, then we are building a new component + if (identical(globals$currentEditCmp,globals$NULLfvsCmp)) + { + if (length(globals$winBuildFunction)) + { + kwPname = globals$winBuildFunction + pkeys = character(0) + } else { + if (!is.null(attr(globals$currentCmdPkey,"keywords"))) + { + kwPname = attr(globals$currentCmdPkey,"keywords") + pkeys=NULL + } else { + kwPname = scan(text=globals$currentCmdPkey,what="character",sep=" ",quiet=TRUE) + pkeys = if (length(kwPname)>1) prms[[kwPname[2]]] else prms[[kwPname[1]]] + } + } + oReopn = character(0) + } else { # we are editing the component + kwPname = globals$currentEditCmp$kwdName + oReopn = globals$currentEditCmp$reopn + cat ("Editing a component: kwPname=",kwPname," oReopn=",oReopn,"\n") + pkeys = if (length(kwPname)) prms[[kwPname]] else NULL + if (is.null(pkeys) && length(oReopn) == 0) #this is freeform... + { + cat ("Editing as freeform\n") + globals$currentEditCmp$kwds = input$freeEdit + globals$currentEditCmp$reopn = character(0) + globals$currentEditCmp$title = input$cmdTitle + mkSimCnts(globals$fvsRun,sels=input$simCont[[1]], + justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + closeCmp() + return() + } + } + cat ("Building a component: kwPname=",kwPname,"\n") + ans = if (length(kwPname)==1 && kwPname=="freeEdit") list(ex=attr(globals$currentCmdPkey,"extension"), + reopn=NULL,kwds=input$freeEdit) else buildKeywords(oReopn,pkeys, kwPname,globals) + gensps <- grep("SpGroup", ans$kwds) + if(length(gensps)) + { + cntr <- 0 + if(!length(globals$GrpNum)) globals$GrpNum[1] <- 1 else + globals$GrpNum[(length(globals$GrpNum)+1)] <- length(globals$GrpNum)+1 + grlist <- list() + for (spg in 1:length(ans$reopn)) if(try(ans$reopn[spg])!=" ") + { + cntr<-cntr+1 + grlist[cntr]<-ans$reopn[spg] + } + # prevent duplicate SpGroup names due to editing & saving non-name changes + grlist[1] <- gsub(" ","", grlist[1]) + tmpk <- match(grlist[1], globals$GenGrp) + if (is.na(tmpk) && !length(globals$currentEditCmp$kwds)) + globals$GenGrp[length(globals$GrpNum)]<-grlist + if (is.na(tmpk) && length(globals$currentEditCmp$kwds)) + { + globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] + globals$GenGrp <- globals$GenGrp[-length(globals$GenGrp)] + globals$GenGrp[length(globals$GrpNum)]<-grlist + } + if (!is.na(tmpk) && length(globals$currentEditCmp$kwds)) + globals$GrpNum <- globals$GrpNum[-length(globals$GrpNum)] + } + if (identical(globals$currentEditCmp,globals$NULLfvsCmp)) + { + newcmp = mkfvsCmp(uuid=uuidgen(),atag="k",kwds=ans$kwds,exten=ans$ex, + variant=globals$activeVariants[1],kwdName= if (length(kwPname)>1) kwPname[2] else kwPname[1], + title=input$cmdTitle, + reopn=if (is.null(ans$reopn)) character(0) else ans$reopn) + # find the attachment point. + sel = if (length(globals$schedBoxPkey) && + input$schedbox == 3) input$condList else input$simCont[[1]] + grp = findIdx(globals$fvsRun$grps,sel) + std = if (is.null(grp)) findIdx(globals$fvsRun$stands,sel) else NULL + cmp = NULL + if (is.null(grp) && is.null(std)) + { + for (grp in 1:length(globals$fvsRun$grps)) + { + cmp = findIdx(globals$fvsRun$grps[[grp]]$cmps,sel) + if (!is.null(cmp)) break + } + if (is.null(cmp)) grp = NULL + if (is.null(grp)) for (std in 1:length(globals$fvsRun$stands)) + { + cmp = findIdx(globals$fvsRun$stands[[std]]$cmps,sel) + if (!is.null(cmp)) break + } + } + if (length(globals$schedBoxPkey) && input$schedbox == 3) + { + #tag the component as being linked to the condition. + newcmp$atag = sel + #adjust insert point. + if (is.null(std)) for (i in (cmp+1):length(globals$fvsRun$grps[[grp]]$cmps)) + { + if (i > length(globals$fvsRun$grps[[grp]]$cmps)) break + if (globals$fvsRun$grps[[grp]]$cmps[[i]]$atag == sel) cmp = i + } else for (i in (cmp+1):length(globals$fvsRun$stands[[std]]$cmps)) + { + if (i > length(globals$fvsRun$stands[[std]]$cmps)) break + if (globals$fvsRun$stands[[std]]$cmps[[i]]$atag == sel) cmp = i + } + } + # save schedBoxYrLastUsed + if (length(globals$schedBoxPkey) && input$schedbox == 1 && + length(input[[globals$schedBoxPkey]])) globals$schedBoxYrLastUsed <- + input[[globals$schedBoxPkey]] + # if there is a newcnd, then attach it first. + if (!is.null(newcnd)) + { + newcmp$atag = newcnd$uuid + if (is.null(grp)) + { + globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$stands[[std]]$cmps, newcnd) else + append(globals$fvsRun$stands[[std]]$cmps, newcnd, after=cmp) + } else { + globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$grps[[grp]]$cmps, newcnd) else + append(globals$fvsRun$grps[[grp]]$cmps, newcnd, after=cmp) + } + if (!is.null(cmp)) cmp <- cmp+1 + } + # attach the new component + if (is.null(grp)) + { + globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$stands[[std]]$cmps, newcmp) else + append(globals$fvsRun$stands[[std]]$cmps, newcmp, after=cmp) + } else { + globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$grps[[grp]]$cmps, newcmp) else + append(globals$fvsRun$grps[[grp]]$cmps, newcmp, after=cmp) + } + } else { + globals$currentEditCmp$kwds=ans$kwds + globals$currentEditCmp$title=input$cmdTitle + cat ("saving, kwds=",ans$kwds," title=",input$cmdTitle," reopn=",ans$reopn,"\n") + globals$currentEditCmp$reopn=if (is.null(ans$reopn)) character(0) else ans$reopn + globals$currentEditCmp=globals$NULLfvsCmp + } + mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + closeCmp() + globals$schedBoxPkey <- character(0) + }) + + ## time--start year + observe({ + if(!length(input$simCont) || !length(globals$fvsRun$startyr) || + globals$fvsRun$startyr==input$startyr) return() + globals$fvsRun$startyr <- input$startyr + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + }) + ## time--end year + observe({ + if(!length(input$simCont) || !length(globals$fvsRun$endyr) || + globals$fvsRun$endyr==input$endyr) return() + globals$fvsRun$endyr <- input$endyr + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + }) + ## time--cycle length + observe({ + if(!length(input$simCont) || !length(globals$fvsRun$cyclelen) || globals$fvsRun$cyclelen==input$cyclelen) return() + globals$fvsRun$cyclelen <- input$cyclelen + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + }) + ## time--cycle breaks + observe({ + if(!length(input$simCont) || (length(globals$fvsRun$cycleat) && + length(input$cycleat) && globals$fvsRun$cycleat==input$cycleat)) return() + globals$fvsRun$cycleat <- input$cycleat + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + }) + + + ## runwaitback + observe( + output$bkgCpuPrompt <- renderUI(if (input$runwaitback=="Wait for run") NULL else + list(myInlineNumericInput("bkgNcpu","Background processes", + value=as.character(max(1,floor(detectCores()/2))), min="1", + max=as.character(detectCores()), step="1",size=10,labelstyle="font-weight:normal;"), + HTML(paste0("

A background run is divided into sets of ", + "separate processes that are run at once. The max ", + "number of processes is limited to ",detectCores(),", the number of CPUs ", + "cores in this computer.

"))) + )) + + + + + ## Save and Run + observeEvent(input$saveandrun, { + if(!length(input$simCont)) + { + cat("No Active Stands\n") + showModal(shiny::modalDialog(title = "Cannot Perform Operation", + "'Run Contents' must contain at least one stand or group to perform this operation ")) + return() + } + cat("Nulling uiRunPlot at Save and Run\n") + output$uiRunPlot <- output$uiErrorScan <- renderUI(NULL) + globals$currentQuickPlot = character(0) + # 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))){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The common starting year of ",input$startyr, + " is more than 50 years from the current year of ", thisYr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + if ((input$startyr !="") && (input$startyr < globals$fvsRun$stands[[i]]$invyr)){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The common starting year of ",input$startyr, + " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + } + # 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)))) || + ((input$endyr !="") && nchar(input$endyr) > 4))){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The common ending year of ", input$endyr, + " is more than 40 growth cycles from the current year of ", thisYr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + if ((input$endyr !="") && ((as.numeric(input$endyr) < + as.numeric(globals$fvsRun$stands[[i]]$invyr)))){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The common ending year of ", input$endyr, + " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + } + # other cycle length check + if (((input$cyclelen !="" && ((as.numeric(input$cyclelen)) > 50))) || + ((input$cyclelen !="") && nchar(input$cyclelen) > 4)){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The growth interval of ", input$cyclelen, + " years is greater than the maximum 50 years")) + 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)), + what=0,quiet=TRUE) + # Cycle break checks + if (length(cycleat)){ + for(i in 1:length(globals$fvsRun$stands)){ + for(j in 1:length(cycleat)){ + if ((cycleat[j] > (thisYr + 400))){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The additional reporting year of ", cycleat[j], + " is more than 400 years from the current year of", thisYr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + if ((cycleat[j] < as.numeric(globals$fvsRun$stands[[i]]$invyr))){ + session$sendCustomMessage(type = "infomessage", + message = paste0("The additional reporting year of ", cycleat[j], + " is before the inventory year of ", globals$fvsRun$stands[[i]]$invyr)) + updateTabsetPanel(session=session,inputId="rightPan",selected="Time") + return() + } + } + } + } + progress <- shiny::Progress$new(session,min=1, + max=length(globals$fvsRun$stands)+10) + progress$set(message = "Run preparation: ", + detail = "Saving FVS Run", value = 1) + saveRun(input,session) + updateSelectInput(session=session, inputId="runSel", + choices=globals$FVS_Runs,selected=globals$FVS_Runs[[1]]) + + killIfRunning(globals$fvsRun$uuid) + # if rerunning a run that is currently selected in the "View Outputs", + # then clear those tools. + if (globals$fvsRun$uuid %in% input$runs) initTableGraphTools(globals,session,output,fvsOutData) + progress$set(message = "Run preparation: ", + detail = "Deleting old ouputs", value = 2) + removeFVSRunFiles(globals$fvsRun$uuid) + updateSelectInput(session=session, inputId="bkgRuns", + choices=getBkgRunList(),selected=0) + progress$set(message = "Run preparation: ", + detail = "Write .key file and prepare program", value = 3) + cat ("runwaitback=",input$runwaitback,"\n") + + if (input$runwaitback!="Wait for run") + { + ncpu=suppressWarnings(if(is.null(input$bkgNcpu)) NA else + as.numeric(input$bkgNcpu)) + if (is.na(ncpu)) ncpu=1 + progress$set(message = "Run preparation: ", + detail = "Starting backgrouind run", value = length(globals$fvsRun$stands)+10) + updateTextInput(session=session, inputId="bkgNcpu",value=as.character(ncpu)) + msg=extnSimulateRun(runUUID=globals$fvsRun$uuid,fvsBin=globals$fvsBin, + ncpu=ncpu) + if(msg=="wrong active database"){ + cat ("Run data query returned no data to run.\n") + progress$set(message = "Error: Keyword file was not created. Try re-importing + the inventory database associated with this run.", + detail = msg, value = 3) + Sys.sleep(5) + progress$close() + return() + } + refreshTimmer <- reactiveTimer(500,session=session) + progress$close() + output$contChange <- renderUI("Run") + return() + } + msg=writeKeyFile(globals,dbGlb$dbIcon) + fc = paste0(globals$fvsRun$uuid,".key") + if (!file.exists(fc)) + { + if(msg=="Wrong active database."){ + cat ("Wrong active database.\n") + progress$set(message = "Error: Wrong active database. Try re-importing + the inventory database associated with this run.", + detail = NA, value = 3) + return() + } else { + cat ("keyword file was not created.\n") + progress$set(message = "Error: Keyword file was not created.",detail = msg, value = 3) + Sys.sleep(5) + progress$close() + return() + } + } + if(msg=="Stand not found in FVS_ClimAttrs table."){ + cat ("Stand not found in FVS_ClimAttrs table.\n") + progress$set(message = "Error: Stand(s) not found in the existing FVS_ClimAttrs table. Check climate data + to ensure all stands in the run are included.", + detail = NA, value = 3) + return() + } + if(msg=="No Climate attributes data found."){ + cat ("No climate attributes data found.\n") + progress$set(message = "Error: No climate attributes data found. Make sure to either upload it using + the Upload Climate-FVS data menu, or check the file name on the ClimData keyword.", + detail = NA, value = 3) + return() + } + if (!dir.exists(globals$fvsBin)) + { + progress$set(message = paste0("Error: ",globals$fvsBin," does not exist."), + detail = "", value = 3) + Sys.sleep(5) + progress$close() + return() + } + dir.create(globals$fvsRun$uuid) + fvschild = makePSOCKcluster(1) + #on exit of the reactive context + on.exit({ + 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('", + globals$fvsRun$FVSpgm,"',bin='",globals$fvsBin,"'))") + cat ("load FVSpgm cmd=",cmd,"\n") + rtn = try(eval(parse(text=cmd))) + if (class(rtn) == "try-error") return() + # if not using the default run script, load the one requested. + if (globals$fvsRun$runScript != "fvsRun") + { + rsFn = paste0("customRun_",globals$fvsRun$runScript,".R") + if (!file.exists(rsFn)) rsFn = system.file("extdata", rsFn, + package="fvsOL") + if (!file.exists(rsFn)) return() + cmd = paste0("clusterEvalQ(fvschild,source('",rsFn,"'))") + cat ("run script load cmd=",cmd,"\n") + rtn = try(eval(parse(text=cmd))) + if (class(rtn) == "try-error") return() + runOps <- if (is.null(globals$fvsRun$uiCustomRunOps)) list() else + globals$fvsRun$uiCustomRunOps + rtn = try(clusterExport(fvschild,list("runOps"),envir=environment())) + if (class(rtn) == "try-error") return() + } + foo = paste0(globals$fvsRun$uuid,".key") + cmd = paste0("clusterEvalQ(fvschild,",'fvsSetCmdLine("--keywordfile=',foo,'"))') + cat ("load run cmd=",cmd,"\n") + rtn = try(eval(parse(text=cmd))) + if (class(rtn) == "try-error") return() + cat ("at for start\n") + allSum = list() + for (i in 1:length(globals$fvsRun$stands)) + { + detail = paste0("Stand ",i," StandId=",globals$fvsRun$stands[[i]][["sid"]]) + progress$set(message = "FVS running", detail = detail, value = i+4) + rtn = if (globals$fvsRun$runScript != "fvsRun") + { + cmd = paste0("clusterEvalQ(fvschild,",globals$fvsRun$runScript,"(runOps))") + cat ("custom run cmd=",cmd,"\n") + try(eval(parse(text=cmd))) + } else { + cat ("running normal run cmd\n") + try(clusterEvalQ(fvschild,fvsRun())) + } + cat ("rtn class for stand i=",i," is ",class(rtn),"\n") + if (class(rtn) == "try-error") + { + cat ("run try error\n") + return() + } + rtn = rtn[[1]] + if (rtn != 0) break + ids = try(clusterEvalQ(fvschild,fvsGetStandIDs())) + if (class(ids) == "try-error") break + ids = ids[[1]] + rn = paste0("SId=",ids["standid"],";MId=",ids["mgmtid"]) + cat ("rn=",rn,"\n") + rtn = try(clusterEvalQ(fvschild,fvsSetupSummary(fvsGetSummary()))) + if (class(rtn) == "try-error") break + allSum[[i]] = rtn[[1]] + names(allSum)[i] = rn + } + cat ("rtn,class=",class(rtn),"\n") + try(clusterEvalQ(fvschild,fvsRun())) + progress$set(message = "Scanning output for errors", detail = "", + value = length(globals$fvsRun$stands)+4) + outf=paste0(globals$fvsRun$uuid,".out") + errScan = try(extnErrorScan(outf)) + if (class(errScan) == "try-error") errScan = + "Error scan failed likely due to invalid multibyte strings in output" + output$uiErrorScan <- renderUI(list( + h6(paste0("Run made with: ",globals$fvsRun$FVSpgm)," ",attr(errScan,"pgmRV")), + h5("FVS error scan: "), + tags$style(type="text/css", paste0("#errorScan { overflow:auto; ", + "height:150px; font-family:monospace; font-size:90%;}")), + HTML(paste(errScan,"
")))) + if (length(dir(globals$fvsRun$uuid)) == 0) + unlink(globals$fvsRun$uuid,recursive = TRUE, force = TRUE) + progress$set(message = if (length(allSum) == length(globals$fvsRun$stands)) + "FVS finished" else + "FVS run failed", detail = "", + value = length(globals$fvsRun$stands)+5) + Sys.sleep(.1) + cat ("length(allSum)=",length(allSum),"\n") + if (length(allSum) == 0) {Sys.sleep(.4); return()} + progress$set(message = "FVS finished", + detail = "Merging output to master database", + value = length(globals$fvsRun$stands)+6) + res = addNewRun2DB(globals$fvsRun$uuid,dbGlb$dbOcon) + unlink(paste0(globals$fvsRun$uuid,".db")) + unlink(paste0(globals$fvsRun$uuid,"_genrpt.txt")) + progress$set(message = "Building plot", detail = "", + value = length(globals$fvsRun$stands)+6) + modn = names(allSum) + toch = unique(modn) + if (length(toch) != length(modn)) + { + for (chg in toch) + { + chrr = chg == modn + if ((nch <- sum(chrr)) < 2) next + chg = unlist(strsplit(chg,";")) + modn[chrr] = sprintf("%s r%03i;%s",chg[1],1:nch,chg[2]) + } + names(allSum) = modn + } + X <- Y <- Stand <- NULL + unitConv = if (substring(globals$fvsRun$FVSpgm,4) %in% c("bc","on")) + 0.0699713 else 1 # note FT3pACRtoM3pHA = 0.0699713 + for (i in 1:length(allSum)) + { + X = c(X,allSum[[i]][,"Year"]) + Y = c(Y,allSum[[i]][,"TCuFt"]) * unitConv + ltag = gsub(x=names(allSum)[i],pattern=";.*$",replacement="") + ltag = gsub(x=ltag,pattern="^SId=",replacement="") + Stand=c(Stand,c(rep(ltag,nrow(allSum[[i]])))) + } + toplot = data.frame(X = X, Y=Y, Stand=as.factor(Stand)) + toMany = nlevels(toplot$Stand) > 9 + colors = autorecycle(cbbPalette,nlevels(toplot$Stand)) + yUnits = expression(Total~(ft^{3}/a)) + if (substring(globals$fvsRun$FVSpgm,4) %in% c("cs","ls","ne","sn")) + yUnits = expression(Merchantable~(ft^{3}/a)) + else if (substring(globals$fvsRun$FVSpgm,4) %in% c("bc","on")) + yUnits = expression(Total~(m^{3}/ha)) + plt = ggplot(data = toplot) + scale_colour_manual(values=colors) + + geom_line (aes(x=X,y=Y,color=Stand)) + + labs(x="Year", y=yUnits) + + theme(text = element_text(size=6), + legend.position=if (toMany) "none" else "right", + axis.text = element_text(color="black")) + width=if (toMany) 3 else 4 + height=2.5 + CairoPNG("www/quick.png", width=width, height=height, units="in", res=150) + print(plt) + dev.off() + output$uiRunPlot <- renderUI( + plotOutput("runPlot",width="100%",height=paste0((height+1)*144,"px"))) + output$runPlot <- renderImage(list(src="www/quick.png", width=(width+1)*144, + height=(height+1)*144), deleteFile=TRUE) + cat ("setting currentQuickPlot, input$runSel=",input$runSel,"\n") + globals$currentQuickPlot = globals$fvsRun$uuid + globals$changeind <- 0 + output$contChange <- renderUI("Run") + updateTabsetPanel(session=session, inputId="leftPan",selected="Load") + }) + +## bkgKill + observe({ + if (input$bkgKill == 0) return() + isolate ({ + if (!is.null(input$bkgRuns)) + { + uuid=sub(".pidStatus","",input$bkgRuns) + killIfRunning(uuid) + removeFVSRunFiles(uuid) + } + updateSelectInput(session=session, inputId="bkgRuns", + choices=getBkgRunList(),selected=0) + }) + }) + +## refreshTimmer + refreshTimmer <- reactiveTimer(2000,session=session) + observe({ + if (refreshTimmer()) + { + # 2000 millisceconds = 2 seconds + choices=getBkgRunList() + refreshTimmer <- if (length(choices)==0) reactiveTimer(Inf,session=session) else + reactiveTimer(2000,session=session) + updateSelectInput(session=session, inputId="bkgRuns", + choices=getBkgRunList(),selected=isolate(input$bkgRuns)) + } + }) + ## Download handlers + ## Download dlRenderData + + output$dlRenderData <- downloadHandler( + filename=function () paste0("table",input$dlRDType), + content=function (tf = tempfile()) + { + if (input$dlRDType == ".csv") + { + if (nrow(fvsOutData$render) > 0) + write.csv(fvsOutData$render,file=tf,row.names=FALSE) else + cat (file=tf,'"No data"\n') + } else { + if (nrow(fvsOutData$render) > 0) + { + excelRowLimit=1048576 + if (nrow(fvsOutData$render) > excelRowLimit) + write.xlsx(fvsOutData$render[1:excelRowLimit,],file=tf,colNames = TRUE) else + write.xlsx(fvsOutData$render,file=tf,colNames = TRUE) + } else write.xlsx(file=tf) + } + }, contentType=if (length(input$table) && input$dlRDType==".csv") "text/csv" else + "application/vnd.openxmlformats-officedocument.spreadsheetml.sheet") + ### NB: length(input$table) is tested only to force this downloadHandler to fire. + ## Download dlFVSDatadb + output$dlFVSDatadb <- downloadHandler( + filename="FVS_Data.db", + content = function (tf = tempfile()) file.copy("FVS_Data.db",tf)) + ## Download dlFVSOutdb + output$dlFVSOutdb <- downloadHandler( + filename="FVSOut.db", + content = function (tf = tempfile()) file.copy("FVSOut.db",tf)) + ## Download dlFVSOutxlsx + output$dlFVSOutxlsx <- downloadHandler( + filename= function () paste0(globals$fvsRun$title,"_FVSoutput.xlsx"), + content = function (tf = paste0(tempfile(),".xlsx")) + { + # limit the number of rows exported to Excel to 1,048,576 + excelRowLimit=1048576 + runuuid = globals$fvsRun$uuid + if (is.null(runuuid)) return() + tabs = myListTables(dbGlb$dbOcon) + if (!("FVS_Cases" %in% tabs)) return() + cases = dbGetQuery(dbGlb$dbOcon,paste0("select CaseID from FVS_Cases ", + "where KeywordFile = '",globals$fvsRun$uuid,"';")) + if (nrow(cases) == 0) return() +cat ("download run as xlsx, ncases=",nrow(cases),"\n") + tmp = paste0("tmp",gsub("-","",runuuid),Sys.getpid(),"genoutput") + dbExecute(dbGlb$dbOcon,paste0("attach database ':memory:' as ",tmp)) + casesToGet = paste0(tmp,".casesToGet") + dbWriteTable(dbGlb$dbOcon,name=DBI::SQL(casesToGet),value=cases,overwirte=TRUE) + out = list() + cmpYes = if ("CmpMetaData" %in% tabs) + { + meta = try(dbReadTable(dbGlb$dbOcon,"CmpMetaData")) + class(meta) == "data.frame" && meta$KeywordFile == runuuid + } + for (tab in tabs) + { + qry = if (!is.null(cmpYes) && cmpYes && substr(tab,1,3) == "Cmp") + paste0("select * from ",tab," limit ",excelRowLimit,";") else + paste0("select * from ",tab," where ",tab,".CaseID in", + " (select CaseID from ",casesToGet,") limit ",excelRowLimit,";") + dat = try(dbGetQuery(dbGlb$dbOcon,qry)) + if (class(dat) == "try-error") next + if (nrow(dat) == 0) next + out[[tab]] = dat +cat ("qry=",qry," class(dat)=",class(dat),"\n") + } + dbExecute(dbGlb$dbOcon,paste0("detach database ",tmp,";")) + if (length(out)) write.xlsx(file=tf,out) + }, contentType=NULL) + ## dlPrjBackup + output$dlPrjBackup <- downloadHandler(filename=function () + isolate({ + bckupPick <- input$pickBackup + if (file.exists(bckupPick)) bckupPick else "NoBackup.txt" + }), + content=function (tf = tempfile()) + { + sfile = input$pickBackup + if (file.exists(sfile)) file.copy(sfile,tf) else + cat (file=tf,"Backup does not exist.\n") + }, contentType="zip") + + ## DownLoad + output$dlFVSRunout <- downloadHandler( + filename=function() paste0(globals$fvsRun$title,"_FVSoutput.txt"), + content=function (tf = tempfile()) + { + sfile = paste0(input$runSel,".out") + if (file.exists(sfile)) + { + file.copy(sfile,tf) + # use perl to change line endings, ignore if an error is detected + if (!isLocal()) try(system(paste0("perl -pi -e 's/\\n/\\r\\n/' ",tf))) + } else cat (file=tf,"Output not yet created.\n") + }, contentType="text") + ## Download keywords + output$dlFVSRunkey <- downloadHandler( + filename=function()paste0(globals$fvsRun$title,"_FVSkeywords.txt"), + content=function (tf = tempfile()) + { + sfile = paste0(input$runSel,".key") + if (file.exists(sfile)) file.copy(sfile,tf) else + cat (file=tf,"Keywords not yet created.\n") + }, contentType="text") + + ## Download FVSProjectData.zip + output$dlFVSRunZip <- downloadHandler( + filename="FVSProjectData.zip", + content = function (tf = tempfile()) + { + tempDir = paste0(dirname(tf),"/tozip") + if (dir.exists(tempDir)) lapply(paste0(tempDir,"/",dir(tempDir)),unlink) else + dir.create(tempDir) + spatdat = "SpatialData.RData" + for (ele in input$dlZipSet) + { +cat ("building download, ele=",ele,"\n") + switch (ele, + outdb = { + from="FVSOut.db" + to=file.path(tempDir,from) + if (file.exists(from)) file.copy(from=from,to=to) else + cat (file=to,"Output database does not exist.\n") + }, + key = { + from=paste0(input$runSel,".key") + to=file.path(tempDir,paste0(globals$fvsRun$title,"_FVSkeywords.txt")) + if (file.exists(from)) file.copy(from=from,to=to) + }, + out = { + from=paste0(input$runSel,".out") + to=paste0(tempDir,"/",globals$fvsRun$title,"_FVSoutput.txt") + if (file.exists(from)) file.copy(from=from,to=to) + }, + subdir= { + from=input$runSel + if (dir.exists(from)) + { + to = file.path(tempDir,paste0(globals$fvsRun$title,"_SVS")) + dir.create (to) + file.copy(from=from,to=to,recursive = TRUE) + file.copy(from=paste0(from,"_index.svs"),to=to) + } + }, + FVS_Data = file.copy(from="FVS_Data.db" , + to=file.path(tempDir,"FVS_Data.db")), + fvsProjdb = { + rdat="FVSProject.db" + if (file.exists(rdat)) file.copy(from=rdat,to=file.path(tempDir,rdat)) + }, + SpatialData = { + spatdat = "SpatialData.RData" + if (file.exists(spatdat)) file.copy(from=spatdat, + to=file.path(tempDir,spatdat)) + } + + )} + curdir = getwd() + setwd(tempDir) + zipr(tf,dir()) + unlink(tempDir,recursive = TRUE) + setwd(curdir) + }, contentType="application/zip") + + ## kcpUpload + observe({ + if (is.null(input$kcpUpload)) return() + data=scan(file=input$kcpUpload$datapath,sep="\n",what="",quiet=TRUE) + if (input$kcpUpload$name=="FVS_kcps.RData") data <- data[4:length(data)] + if (length(data)==0) return() + isolate ({ + addnl = TRUE + if (length(globals$customCmps) == 0 && input$kcpUpload$name=="FVS_kcps.RData") + { + load(input$kcpUpload$datapath) + globals$customCmps = customCmps + addnl = FALSE + } + if (length(globals$customCmps) && !is.null(globals$customCmps) && input$kcpEdit !=""){ + updateSelectInput(session=session, inputId="kcpSel", selected = 0) + } + updateTextInput(session=session, inputId="kcpTitle", value= + paste("From:",input$kcpUpload$name)) + if(addnl){ + updateTextInput(session=session, inputId="kcpEdit", value= + paste(data,collapse="\n")) + } else { + updateTextInput(session=session, inputId="kcpEdit", value=globals$customCmps[1]) + save(file="FVS_kcps.RData",customCmps) + } + }) + }) + + ## kcpSel + observe({ + if (length(input$kcpSel) == 0) return() +cat ("kcpSel called, input$kcpSel=",input$kcpSel,"\n") + if (is.null(input$kcpSel)) + { + updateTextInput(session=session, inputId="kcpTitle",value="") + updateTextInput(session=session, inputId="kcpEdit",value="") + } else { + sel = match(trim(input$kcpSel),trim(names(globals$customCmps))) + updateTextInput(session=session, inputId="kcpTitle", + value=names(globals$customCmps)[sel]) + updateTextInput(session=session, inputId="kcpEdit", + value=globals$customCmps[[sel]]) + } + }) + + ## kcpNew + observe({ + if (length(input$kcpNew) && input$kcpNew > 0) + { + isolate ({ + updateSelectInput(session=session, inputId="kcpSel", selected = 0) + updateTextInput(session=session, inputId="kcpTitle", value="") + updateTextInput(session=session, inputId="kcpEdit", value="") + globals$kcpAppendConts <- list() + globals$condKeyCntr <- 0 + }) +cat ("kcpNew called, input$kcpNew=",input$kcpNew,"\n") + } + }) + + ## kcpAppend + observe({ + if (length(input$kcpAppend) && input$kcpAppend > 0) + { + isolate ({ + topaste = findCmp(globals$fvsRun,input$simCont[1]) + if (is.null(topaste)) return() + if (nchar(input$kcpTitle) == 0) + updateTextInput(session=session, inputId="kcpTitle", + value=topaste$title) + updateTextInput(session=session, inputId="kcpEdit", value= + paste0(input$kcpEdit,"* ",topaste$title,"\n",topaste$kwds,"\n")) + session$sendCustomMessage(type="refocus", "kcpEdit") + indx <- match(input$simCont,globals$fvsRun$simcnts) + if (!length(globals$kcpAppendConts)){ + globals$kcpAppendConts[1] <- globals$fvsRun$simcnts[indx] + names(globals$kcpAppendConts)[1] <- names(globals$fvsRun$simcnts)[indx] + }else + globals$kcpAppendConts[(length(globals$kcpAppendConts)+1)] <- globals$fvsRun$simcnts[indx] + names(globals$kcpAppendConts)[length(globals$kcpAppendConts)] <- names(globals$fvsRun$simcnts)[indx] + # first conditional added + if (length(grep("^-> Cnd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && + (!length(globals$opencond) || globals$opencond==0)){ + globals$opencond <- 1 + globals$condKeyCntr <- 0 + } + # first conditional keyword added + if (length(grep("^--> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)])))){ + globals$condKeyCntr <- globals$condKeyCntr + 1 + } + if (length(grep("^-> Cnd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && + (length(globals$condKeyCntr) && globals$condKeyCntr > 0)){ + globals$opencond <- 0 + globals$condKeyCntr <- 0 + updateTextInput(session=session, inputId="kcpEdit", value= + paste0(input$kcpEdit,"ENDIF\n","* ",topaste$title,"\n",topaste$kwds,"\n")) + } + if (length(grep("^-> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)])))&& + (length(globals$condKeyCntr) && globals$condKeyCntr > 0)){ + globals$opencond <- 0 + globals$condKeyCntr <- 0 + updateTextInput(session=session, inputId="kcpEdit", value= + paste0(input$kcpEdit,"ENDIF\n","* ",topaste$title,"\n",topaste$kwds,"\n")) + } + }) + } + }) + + ## kcpSaveInRun + observeEvent(input$kcpSaveInRun, { + cat ("kcpSaveInRun\n") + if(!length(input$simCont)){ + cat("No Active Stands\n") + showModal(shiny::modalDialog(title = "Cannot Perform Operation", + "'Run Contents' must contain at least one stand or group to perform this operation ")) + return() + } + if (nchar(input$kcpTitle) == 0) + { + newTit = paste0("Editor: Component ",length(globals$customCmps)+1) + updateTextInput(session=session, inputId="kcpTitle", value=newTit) + } else newTit = paste0("Editor: ",trim(input$kcpTitle)) + newcmp = mkfvsCmp(uuid=uuidgen(),atag="k",kwds=input$kcpEdit,exten="base", + variant=globals$activeVariants[1],kwdName="FreeEdit", + title=newTit,reopn=character(0)) + # find the attachment point. + sel = input$simCont[[1]] + grp = findIdx(globals$fvsRun$grps,sel) + std = if (is.null(grp)) findIdx(globals$fvsRun$stands,sel) else NULL + cmp = NULL + if (is.null(grp) && is.null(std)) + { + for (grp in 1:length(globals$fvsRun$grps)) + { + cmp = findIdx(globals$fvsRun$grps[[grp]]$cmps,sel) + if (!is.null(cmp)) break + } + if (is.null(cmp)) grp = NULL + if (is.null(grp)) for (std in 1:length(globals$fvsRun$stands)) + { + cmp = findIdx(globals$fvsRun$stands[[std]]$cmps,sel) + if (!is.null(cmp)) break + } + } + # attach the new component + if (is.null(grp)) + { + globals$fvsRun$stands[[std]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$stands[[std]]$cmps, newcmp) else + append(globals$fvsRun$stands[[std]]$cmps, newcmp, after=cmp) + } else { + globals$fvsRun$grps[[grp]]$cmps <- if (is.null(cmp)) + append(globals$fvsRun$grps[[grp]]$cmps, newcmp) else + append(globals$fvsRun$grps[[grp]]$cmps, newcmp, after=cmp) + } + mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + globals$changeind <- 1 + output$contChange <- renderText(HTML("*Run*")) + globals$schedBoxPkey <- character(0) + }) + + ## kcpSaveCmps + observe({ + if (length(input$kcpSaveCmps) && input$kcpSaveCmps > 0) + { + isolate ({ +cat ("kcpSaveCmps called, kcpTitle=",input$kcpTitle," isnull=", +is.null(input$kcpTitle),"\n") + if (nchar(input$kcpTitle) == 0) + { + newTit = paste0("Component ",length(globals$customCmps)+1) + updateTextInput(session=session, inputId="kcpTitle", value=newTit) + } else newTit = trim(input$kcpTitle) + globals$customCmps[[newTit]] = input$kcpEdit + customCmps = globals$customCmps + skip1 <- strsplit(as.character(customCmps),"\n")[[1]][length(strsplit(as.character(customCmps),"\n")[[1]])] + skip <- length(grep("ENDIF", toupper(skip1))) + if(length(grep("^--> Kwd",names(globals$kcpAppendConts[length(globals$kcpAppendConts)]))) && !skip) + { + updateTextInput(session=session, inputId="kcpEdit", value= + paste0(customCmps,"EndIf\n")) + customCmps <-as.list(paste0(customCmps,"EndIf\n")) + names(customCmps) <- names(globals$customCmps) + globals$customCmps = customCmps + } + storeOrUpdateObject(dbGlb$prjDB,customCmps) + updateSelectInput(session=session, inputId="kcpSel", + choices=names(globals$customCmps), + selected=newTit) + mkSimCnts(globals$fvsRun,sels=input$simCont[[1]],justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + }) + } + }) + + ## kcpDelete + observe({ + if (length(input$kcpDelete) && input$kcpDelete > 0) + { + isolate ({ +cat ("kcpDelete, input$kcpSel=",input$kcpSel,"\n") + if (length(globals$customCmps)) + { + if(is.null(input$kcpSel)){ + + updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(globals$customCmps)), + selected=names(globals$customCmps)[1]) + return() + } + if(length(globals$customCmps)==1){ + customCmps=NULL + removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() + updateSelectInput(session=session, inputId="kcpSel", choices=list()) + updateTextInput(session=session, inputId="kcpTitle", value="") + updateTextInput(session=session, inputId="kcpEdit", value="") + return() + } + sel = na.omit(match(trim(input$kcpSel),trim(names(globals$customCmps)))) + if (length(sel) && input$kcpSel==input$kcpTitle) globals$customCmps[[sel[1]]] = NULL + customCmps = globals$customCmps + storeOrUpdateObject(dbGlb$prjDB,customCmps) + updateSelectInput(session=session, inputId="kcpSel", choices=names(customCmps)) + if(input$kcpSel!=input$kcpTitle){ + sel = match(trim(input$kcpSel),trim(names(globals$customCmps))) + updateTextInput(session=session, inputId="kcpTitle", + value=names(globals$customCmps)[sel]) + updateTextInput(session=session, inputId="kcpEdit", + value=globals$customCmps[[sel]]) + } + } else { + customCmps=NULL + removeObject(dbGlb$prjDB,"customCmps") + globals$customCmps <- list() + updateSelectInput(session=session, inputId="kcpSel", choices=list()) + updateTextInput(session=session, inputId="kcpTitle", value="") + updateTextInput(session=session, inputId="kcpEdit", value="") + } + }) + } + }) + + ## Download KCP + output$kcpDownload <- downloadHandler(filename=function () + paste0(input$kcpTitle,".kcp"), + content=function (tf = tempfile()) + { + write(input$kcpEdit,tf) + }, contentType="text") + + observe({ + if (input$topPan == "Visualize") + { +cat ("Visualize hit\n") + allRuns = globals$FVS_Runs + runChoices = list() + for (has in names(allRuns)) + { + fn = paste0(allRuns[[has]],"_index.svs") + if (file.exists(fn)) runChoices[[has]] = allRuns[[has]] else + { + fn = file.path(paste0(allRuns[[has]],"-set1"), + paste0(allRuns[[has]],"_index.svs")) + if (file.exists(fn)) runChoices[[has]] = allRuns[[has]] + } + } + updateSelectInput(session=session, inputId="SVSRunList1", + choices=runChoices,selected=0) + updateSelectInput(session=session, inputId="SVSRunList2", + choices=runChoices,selected=0) + updateSelectInput(session=session, inputId="SVSImgList1", choices=list(), + selected=0) + updateSelectInput(session=session, inputId="SVSImgList2", choices=list(), + selected=0) + session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm1').hide();$('#SVSdynIm1').hide();")) + output$SVSqImg1Pers = renderUI(NULL) + output$SVSqImg1Top = renderUI(NULL) + output$SVSqImg1Side = renderUI(NULL) + output$SVSImg1 = renderRglwidget(NULL) + session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm2').hide();$('#SVSdynIm2').hide();")) + output$SVSqImg2Pers = renderUI(NULL) + output$SVSqImg2Top = renderUI(NULL) + output$SVSqImg2Side = renderUI(NULL) + output$SVSImg2 = renderRglwidget(NULL) + } + }) + + ## mkSVSchoices + mkSVSchoices <- function(svsRun) + { + fns = paste0(svsRun,"_index.svs") + if (!file.exists(fns)) + { + fns = NULL + i = 1 + repeat + { + fn = file.path(paste0(svsRun,"-set",i),paste0(svsRun,"_index.svs")) + if (!file.exists(fn)) break + fns = c(fns,fn) + i = i+1 + } + } + index=NULL + for (fn in fns) + { + ind=read.table(file=fn,as.is=TRUE) + if (dirname(fn)!=".") ind[,2]=file.path(dirname(fn),ind[,2]) + index = rbind(index,ind) + } + inv=grep ("Inventory conditions",index[,1]) + if (length(inv)>1) + { + firsts=substr(index[inv,1],1,regexpr(" ",index[inv,1])-1) + names(inv)=firsts + rptrs = cbind(inv,c(inv[2:length(inv)]-1,nrow(index))) + rptrs = data.frame(ids=rownames(rptrs),start=rptrs[,1],stop=rptrs[,2]) + rptrs = rptrs[order(rptrs[,1],rptrs[,2],decreasing=c(FALSE,FALSE),method="radix"),] + dups=table(firsts) + if (any(dups>1)) + { + dups=dups[dups>1] + d2 = rep(1,length(dups)) + for (i in 1:nrow(rptrs)) + { + id=grep(rptrs[i,1],names(dups)) + if (length(id)) + { + index[rptrs[i,2]:rptrs[i,3],1]= + sub(" ",sprintf(" r%03i ",d2[id]),index[rptrs[i,2]:rptrs[i,3],1]) + d2[id]=d2[id]+1 + } + } + } + index = index[unlist(c(apply(rptrs,1,function (x) x[2]:x[3]))),] + } + choices = as.list(index[,2]) + names(choices) = index[,1] + choices + } + + ## SVSRunList1 + observe({ + if (length(input$SVSRunList1)) + { +cat ("Visualize input$SVSRunList1=",input$SVSRunList1,"\n") + choices = mkSVSchoices(input$SVSRunList1) + updateSelectInput(session=session, inputId="SVSImgList1", choices=choices, + selected = 0) + session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm1').hide();$('#SVSdynIm1').hide();")) + output$SVSqImg1Pers = renderUI(NULL) + output$SVSqImg1Top = renderUI(NULL) + output$SVSqImg1Side = renderUI(NULL) + output$SVSImg1 = renderRglwidget(NULL) + } + }) + + ## SVSRunList2 + observe({ + if (length(input$SVSRunList2)) + { +cat ("Visualize input$SVSRunList2=",input$SVSRunList2,"\n") + choices = mkSVSchoices(input$SVSRunList2) + updateSelectInput(session=session, inputId="SVSImgList2", choices=choices, + selected = 0) + session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm2').hide();$('#SVSdynIm2').hide();")) + output$SVSqImg2Pers = renderUI(NULL) + output$SVSqImg2Top = renderUI(NULL) + output$SVSqImg2Side = renderUI(NULL) + output$SVSImg2 = renderRglwidget(NULL) + } + }) + + ## renderSVSImage + renderSVSImage <- function (id,imgfile,subplots=TRUE,downTrees=TRUE, + fireLine=TRUE,rangePoles=TRUE,plotColor="gray") + { +cat ("renderSVSImage, subplots=",subplots," downTrees=",downTrees, + " fireLine=",fireLine," rangePoles=",rangePoles,"\n") + for (dd in rgl.dev.list()) try(rgl.close()) + open3d(useNULL=TRUE) + svs = scan(file=paste0(imgfile),what="character",sep="\n",quiet=TRUE) + treeform = grep ("#TREEFORM",svs) + if (length(treeform)) + { + treeform = scan(text=svs[treeform],what="character",quiet=TRUE)[2] + treeform = tolower(scan(text=treeform,sep=".",what="c",quiet=TRUE)[1]) + if (! (treeform %in% names(treeforms))) + { + output[[id]] <- NULL +cat ("treeform=",treeform," is absent from treeforms, exiting.\n") + return() + } + } + treeform = treeforms[[treeform]] + rcirc = grep ("^#CIRCLE",svs) + if (length(rcirc)) + { +# rgl.viewpoint(theta = 1, phi = -45, fov = 30, zoom = .8, interactive = TRUE) + rgl.viewpoint(theta = 1, phi = -40, fov = 0, zoom = .9, interactive = TRUE) + args = as.numeric(scan(text=svs[rcirc[1]],what="character",quiet=TRUE)[2:4]) +cat ("args=",args,"\n") + plotDef = circle3D(x0=args[1],y0=args[2],r=args[3],col=plotColor,alpha=0.7) + if (subplots && length(rcirc)>1) + { + for (cir in rcirc[2:length(rcirc)]) + { + ca = as.numeric(scan(text=svs[cir],what="character",quiet=TRUE)[2:4]) + circle3D(x0=ca[1],y0=ca[2],r=ca[3],alpha=1,fill=FALSE,col="black") + } + } + pltshp=1 + } else { # assume square, look for arguments of the rectangle. + rgl.viewpoint(theta = 1, phi = -45, fov = 30, zoom = .9, interactive = TRUE) + rect = grep ("^#RECTANGLE",svs) + if (length(rect)) + { + args = as.numeric(scan(text=svs[rect],what="character",quiet=TRUE)[4]) + plotDef = matrix(c(0,0,0,0,args,0,args,args,0,args,0,0,0,0,0),ncol=3,byrow=TRUE) + polygon3d(plotDef,col=plotColor,alpha=0.7) + } + pltshp=0 + } + if (subplots) + { + subplts = grep("^#LINE",svs) + if (length(subplts)) + { + crds = as.numeric(scan(text=substring(svs[subplts],6),what="character",quiet=TRUE)) + crds = cbind(matrix(crds,ncol=2,byrow=TRUE),0) + segments3d(crds,col="black",add=TRUE) + } + } + rpols = grep("^RANGEPOLE",svs) + if (length(rpols)) + { + if (rangePoles) + { + poles = c() + for (line in rpols) + { + pole = as.numeric(scan(text=svs[line],what="character",quiet=TRUE)[c(21,22,7)]) + poles = c(poles,c(pole[1:2],0,pole)) + } + poles = matrix(poles,ncol=3,byrow=TRUE) + segments3d(poles,col="red",lwd=4,add=TRUE) + } + svs=svs[-rpols] + } + calls = 0 + frlineS = grep("^#FIRE_LINE",svs) +cat ("length(frlineS)=",length(frlineS),"fireLine=",fireLine,"\n") + if (length(frlineS)) + { + if (fireLine) + { + fl = as.numeric(scan(text=substring(svs[frlineS],11),what="numeric",quiet=TRUE)) + frline=NULL + if (pltshp) + { + xx = seq(0,args[3]*2,length.out=length(fl)) + r = sqrt(((xx-args[3])^2) + ((fl-args[3])^2)) + k = r<=args[3] + if (any(k)) + { + frline = matrix(c(xx[k],fl[k],rep(0,sum(k))),ncol=3,byrow=FALSE) + frline = frline[nrow(frline):1,] + kep1=which.min(((plotDef[,1]-frline[1,1])**2)+((plotDef[,2]-frline[1,2])**2)) + kep2=which.min(((plotDef[,1]-frline[nrow(frline),1])**2)+((plotDef[,2]-frline[nrow(frline),2])**2)) + frline[1,]=plotDef[kep1,] + frline[nrow(frline),]=plotDef[kep2,] + brnReg = rbind(frline[2:(nrow(frline)-1),],plotDef[kep2:nrow(plotDef),]) + if (kep1<(nrow(plotDef)/2)) brnReg = rbind(plotDef[1:kep1,],brnReg) + polygon3d(brnReg,col="black",alpha=0.5) + } + } else { + frline = matrix(c(seq(0,args[1],length.out=length(fl)), + fl,rep(0,length(fl))),ncol=3,byrow=FALSE) + brnReg = rbind(plotDef[1,],frline,plotDef[4:5,]) + polygon3d(brnReg,col="black",alpha=0.5) + } + if (!is.null(frline)) + { + lines3d(frline,col="red",lwd=4,add=TRUE) + nn=500 + fls = approx(frline[,1],frline[,2],rule=2,n=nn) + fls$z = runif(nn)*3 + fls$y = jitter(fls$y,amount=5) + fls = matrix(c(fls$x,fls$y,fls$z),ncol=3,byrow=FALSE) + fls = t(apply(fls,1,function (x) c(x[1]-x[3],x[2],0,x[1],x[2],x[3]*3, + x[1]+x[3],x[2],0))) + verts = NULL + for (row in 1:nrow(fls)) + { + tlt=runif(1)*40 + rot=runif(1)*360 + mat = matrix(fls[row,],ncol=3,byrow=TRUE) + xs = max(mat[,1])-(diff(range(mat[,1]))*.5) + ys = max(mat[,2])-(diff(range(mat[,2]))*.5) + zs = max(mat[,3])-(diff(range(mat[,3]))*.5) + mat[,1] = mat[,1]-xs + mat[,2] = mat[,2]-ys + mat[,3] = mat[,3]-zs + mat = matRotat(mat,tlt,tlt,rot) + mat[,1] = mat[,1]+xs + mat[,2] = mat[,2]+ys + mat[,3] = mat[,3]+zs + mat[,3] = ifelse(mat[,3]<0,0,mat[,3]) + verts = rbind(verts,mat) + } + triangles3d(verts,col="red") + } + } + svs = svs[-frlineS] + } + progress <- shiny::Progress$new(session,min=1,max=length(svs)+4) + flames = grep("^@flame.eob",svs) +cat("N flames=",length(flames)," fireLine=",fireLine,"\n") + if (length(flames)) + { + if (fireLine) + { + calls = calls+1 + progress$set(message = "Generate flames",value = calls) + allv = NULL + nflsm = 5 + tmp=NULL + for (fl in svs[flames]) + { + fdat = as.numeric(scan(text=substring(fl,30),what="numeric",quiet=TRUE)) + # ht,tilt,rotation,width,x,y,z + fdat = fdat[c(1,2,3,5,15,16,17)] + names(fdat)=c("ht","tlt","rot","wid","x","y","z") + tmp=rbind(tmp,fdat[c("x","y","z")]) + hw=fdat["wid"]*.5 + hwr=rnorm(nflsm,hw,.5) + hwr=ifelse(hwr<(hw*.1),hw*.1,hw) + ht=fdat["ht"] + htr=rnorm(nflsm,ht,1) + htr=ifelse(ht<(htr*.1),ht*.1,ht) + tlt=runif(nflsm)*2*fdat["tlt"] + fbr=rnorm(nflsm,fdat["z"],.5) + fbr=ifelse(fbr<0,0,fbr) + rot=runif(nflsm)*360 + for (i in 1:nflsm) + { + verts = cbind(x=c(-hwr[i],hwr[i],0), + y=c(0,0,0), + z=c(0,0,htr[i])) + verts = matRotat(verts,xa=tlt[i],ya=tlt[i],za=rot[i]) + verts[,1]=verts[,1]+fdat["x"] + verts[,2]=verts[,2]+fdat["y"] + verts[,3]=verts[,3]+rnorm(1,fbr[i],1) + allv = rbind(allv,verts) + } + } + triangles3d(allv[,1],allv[,2],allv[,3],col=c("yellow","red")) + } + svs = svs[-flames] + } +cat("Residual length of svs=",length(svs),"\n") + drawnTrees = list() + trees = list() + for (line in svs) + { + calls = calls+1 + progress$set(message = "Generate trees",value = calls) + c1 = substr(line,1,1) + if (c1 == "#" || c1 == ";") next + tree = scan(text=line,what="character",quiet=TRUE) + if (!downTrees && tree[9]!="0") next + sp = tree[1] + tree=tree[-1] + tree = as.numeric(tree) + names(tree) = c("TrNum","TrCl","CrCl","Stus","DBH","Ht","Lang", + "Fang","Edia","Crd1","Cr1","CrD2","Cr2","CrD3","Cr3", + "CrD4","Cr4","Ex","Mk","Xloc","Yloc","Z") + tree = as.list(tree[c(2,3,4,5,6,7,8,10,11,20,21)]) + tree$sp = sp + ll = matrix(c(tree$Xloc,tree$Yloc,0),nrow=1) + tree$Xloc = ll[1,1] + tree$Yloc = ll[1,2] + drawn = svsTree(tree,treeform) + if (!is.null(drawn)) drawnTrees[[length(drawnTrees)+1]] = drawn +####TESTING if (calls > 60) break + } + progress$set(message = "Display trees",value = length(svs)+1) + displayTrees(drawnTrees) + progress$set(message = "Sending image to browser",value = length(svs)+2) + output[[id]] <- renderRglwidget(rglwidget(scene3d())) + # this code forces the scene to be loaded prior to calling the custom message + # and that is critical to getting all this to work. + callBack <- function() + { + session$sendCustomMessage(type="makeTopSideImages", + c(id,paste0(id,"Pers"),paste0(id,"Top"),paste0(id,"Side"))) + progress$close() + if (id=="SVSImg1") session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm1').show();$('#SVSdynIm1').show();")) else + session$sendCustomMessage(type="jsCode", + list(code= "$('#SVSstaIm2').show();$('#SVSdynIm2').show();")) + } + session$onFlushed(callBack, once = TRUE) + } + + ## SVSImgList1 + observe({ + if (length(input$SVSImgList1)) + { +cat ("Visualize SVSImgList1=",input$SVSImgList1," SVSdraw1=",input$SVSdraw1,"\n") + fn=input$SVSImgList1 + if (!file.exists(fn)) return() + # actual images are loaded into these two img items in the browser when CustomMessage makeTopSideImages is sent + output$SVSqImg1Pers <- renderUI(HTML('Perspective View')) + output$SVSqImg1Top <- renderUI(HTML('Top View')) + output$SVSqImg1Side <- renderUI(HTML('Side View')) + renderSVSImage('SVSImg1',fn, + subplots="subplots" %in% input$SVSdraw1,downTrees="downTrees" %in% input$SVSdraw1, + fireLine="fireLine" %in% input$SVSdraw1,rangePoles="rangePoles" %in% input$SVSdraw1, + plotColor=input$svsPlotColor1) + } + }) + + ## SVSImgList2 + observe({ + if (length(input$SVSImgList2)) + { +cat ("Visualize SVSImgList2=",input$SVSImgList2," SVSdraw1=",input$SVSdraw2,"\n") + fn=input$SVSImgList2 + if (!file.exists(fn)) return() + # actual images are loaded into these two img items in the browser when CustomMessage makeTopSideImages is sent + output$SVSqImg2Pers <- renderUI(HTML('Perspective View')) + output$SVSqImg2Top <- renderUI(HTML('Top View')) + output$SVSqImg2Side <- renderUI(HTML('Side View')) + renderSVSImage('SVSImg2',fn, + subplots="subplots" %in% input$SVSdraw2,downTrees="downTrees" %in% input$SVSdraw2, + fireLine="fireLine" %in% input$SVSdraw2,rangePoles="rangePoles" %in% input$SVSdraw2, + plotColor=input$svsPlotColor2) + } + }) + ## "View On Maps" processing + observe({ + if (input$topPan == "View On Maps") + { +cat ("View On Maps hit\n") + require(rgdal) + theRuns = try(dbGetQuery(dbGlb$dbOcon, + paste0("select distinct RunTitle, KeywordFile from FVS_Cases", + " order by RunDateTime desc"))) + if (class(theRuns)!="try-error" && nrow(theRuns)>0) + { + allRuns=theRuns[,2] + names(allRuns)=theRuns[,1] + updateSelectInput(session=session, inputId="mapDsRunList", + choices=allRuns) + } else updateSelectInput(session=session, inputId="mapDsRunList",choices=list()) + updateSelectInput(session=session, inputId="mapDsTable", choices=list()) + updateSelectInput(session=session, inputId="mapDsVar", choices=list()) + updateSelectInput(session=session, inputId="MapYear", choices=list()) + output$leafletMap = renderLeaflet(NULL) + output$leafletMessage=renderText(NULL) + } + }) + ## mapDsRunList + observe({ + if (length(input$mapDsRunList) && input$topPan == "View On Maps") + { +cat ("mapDsRunList input$mapDsRunList=",input$mapDsRunList,"\n") + cases = try(dbGetQuery(dbGlb$dbOcon, + paste0("select CaseID,StandID from FVS_Cases where KeywordFile = '", + input$mapDsRunList,"'"))) + if (class(cases)=="try-error") return() + # if there are reps (same stand more than once), just use the first rep, ignore the others + cases = cases[!duplicated(cases$StandID),] + dbExecute(dbGlb$dbOcon,"drop table if exists temp.mapsCases") + dbWriteTable(dbGlb$dbOcon,DBI::SQL("temp.mapsCases"),cases[,1,drop=FALSE]) + tabs = setdiff(myListTables(dbGlb$dbOcon), + c("CmpSummary","FVS_Cases","CmpSummary_East")) + tables = list() + for (tab in tabs) + { + tb <- dbGetQuery(dbGlb$dbOcon,paste0("PRAGMA table_info('",tab,"')")) + if (length(intersect(c("caseid","standid","year"),tolower(tb$name))) != 3) next + cnt = try(dbGetQuery(dbGlb$dbOcon,paste0("select count(*) from ",tab, + " where CaseID in (select CaseID from temp.mapsCases) limit 1"))) + if (class(cnt) == "try-error") next + if (cnt[1,1]) tables=append(tables,tab) + } + if (length(tables)) names(tables) = tables + updateSelectInput(session=session, inputId="mapDsTable", choices=tables, + selected=0) + updateSelectInput(session=session, inputId="mapDsVar", choices=list(), + selected=0) + output$leafletMap = renderLeaflet(NULL) + } + }) + ## mapDsTable + observe({ + if (length(input$mapDsTable)) + { + cat ("mapDsRunList input$mapDsTable=",input$mapDsTable,"\n") + vars = setdiff(dbListFields(dbGlb$dbOcon,input$mapDsTable), + c("CaseID","StandID","Year")) + sps = na.omit(match(c("SpeciesFVS","SpeciesPLANTS","SpeciesFIA"),vars)) + if (length(sps)==3) vars = vars[-sps] + vars = vars[! vars == "Characteristic"] + vars = as.list(vars) + names(vars) = vars + updateSelectInput(session=session, inputId="mapDsVar", choices=vars, + selected=0) + output$leafletMap = renderLeaflet(NULL) + } + }) + + ## mapDsVar + observe({ + if (length(input$mapDsVar) && !is.na(match(input$mapDsVar,setdiff( + dbListFields(dbGlb$dbOcon,input$mapDsTable), c("CaseID","StandID","Year"))))) + { +cat ("mapDsRunList input$mapDsTable=",isolate(input$mapDsTable), + " input$mapDsVar=",input$mapDsVar," input$mapDsType=",input$mapDsType,"\n") + # prepare display data + dispData = try(dbGetQuery(dbGlb$dbOcon,paste0("select * from ", + isolate(input$mapDsTable), + " where CaseID in (select CaseID from temp.mapsCases)"))) + if (class(dispData)=="try-error" || nrow(dispData)==0) return() + dispData = dispData[,-1] #remove CaseID + # if species is a variable, pick the one to display and ditch the others + sps = na.omit(match(c("SpeciesFVS","SpeciesPLANTS","SpeciesFIA"),names(dispData))) + if (length(sps)==3) + { + spk = match(paste0("Species",input$spCodes),names(dispData)) + names(dispData)[spk]="Species" + dispData = dispData[,-sps[sps!=spk]] + spk = "Species" + } else { spk = NULL } + keys = setdiff(colnames(dispData),c("StandID","Year","Characteristic",spk)) + for (var in keys) + { + if (class(dispData[,var]) == "character") + { + x = suppressWarnings(as.numeric(dispData[,var])) + if (!any(is.na(x))) dispData[,var] = x + } + } + dvs = intersect(names(dispData), + c("StandID","Year","Characteristic",spk,input$mapDsVar)) + isp = match("Species",dvs) + if (!is.na(isp) && isp != 3) dvs=c(dvs[1:2],"Species",dvs[-c(1,2,isp)]) + dispData = dispData[,dvs] + uidsToGet = unique(dispData$StandID) +cat ("length(uidsToGet)=",length(uidsToGet),"\n") + if (!length(uidsToGet)) return() + uidsFound = NULL + library(sf) + spatdat = "SpatialData.RData" + if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && + file.exists(spatdat)) load(spatdat,envir=dbGlb) + pts = NULL + ptsLbs = NULL + polys = NULL + if (exists("SpatialData",envir=dbGlb,inherit=FALSE)) + { + matchVar = attr(dbGlb$SpatialData,"MatchesStandID") +cat ("1 matchVar=",matchVar,"\n") + # when matchVar is NULL, it means that there is a list of maps that will be searched + # for the spatial data. If it is not null, then there is only one item, so use it. + mapList = if (is.null(matchVar)) dbGlb$SpatialData else list(d=dbGlb$SpatialData) + pts = NULL + polyLbs = NULL + ptsLbs = NULL + for (map in mapList) + { + if (!length(uidsToGet)) break + matchVar = attr(map,"MatchesStandID") +cat ("2 matchVar=",matchVar,"\n") + # if the map has class sp, it needs to be converted. This code was added in Nov 2022 + # and can be removed once all the map data is converted to package sf. Note that + # this code allows for some members of the SpatialData to be sf and others sp. + qsp = attr(class(map),"package") + if (!is.null(qsp) && qsp == "sp") map=st_as_sf(map) + uids=intersect(uidsToGet, map[[matchVar]]) + if (length(uids) == 0) next + uidsFound = c(uidsFound,uids) + pp = st_transform(map[match(uids,map[[matchVar]]),],st_crs("epsg:4326")) + if (length(grep("POLYGON",st_geometry_type(pp)[1]))) + { + polys = if (is.null(polys)) pp else rbind(polys,pp) + polyLbs= if (is.null(polyLbs)) uids else rbind(polyLbs,uids) + } + if (length(grep("POINT",st_geometry_type(pp)[1]))) + { + pts = if (is.null(pts)) pp else rbind(pts,pp) + ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) + } + uidsToGet = setdiff(uidsToGet,uids) + } + } +cat ("left to get: length(uidsToGet)=",length(uidsToGet), + " number found: length(uidsFound)=",length(uidsFound),"\n") + if (length(uidsToGet)) + { + isolate({ + if (globals$fvsRun$uuid == input$mapDsRunList) + inInit = globals$fvsRun$refreshDB else + { + saveFvsRun=loadFVSRun(dbGlb$prjDB,input$mapDsRunList) + if (!is.null(saveFvsRun)) + { + inInit = saveFvsRun$refreshDB + rm(saveFvsRun) + } else inInit=NULL + } + }) + if (is.null(inInit)) inInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") +cat ("mapDsRunList trying to use the table=",inInit,"\n") + dbWriteTable(dbGlb$dbIcon,DBI::SQL("temp.uidsToGet"),data.frame(stds=uidsToGet),overwrite=TRUE) + sid = if (inInit %in% c("FVS_PlotInit","FVS_PlotInit_Plot")) + "StandPlot_ID" else "Stand_ID" + qry = paste0("select distinct ",sid," as Stand_ID,Latitude,Longitude from ",inInit, + " where ",sid," in (select * from temp.uidsToGet)") + latLng = try(dbGetQuery(dbGlb$dbIcon,qry)) + dbExecute(dbGlb$dbIcon,"drop table if exists temp.uidsToGet") + if (class(latLng)!="try-error" && nrow(latLng)) + { + idxLng = grep("Longitude",names(latLng),ignore.case=TRUE) + idxLat = grep("Latitude",names(latLng),ignore.case=TRUE) +cat ("mapDsRunList idxLng=",idxLng," idxLat=",idxLat," names=",names(dbGlb$SpatialData),"\n") + if (length(idxLng) && length(idxLat)) + { + latLng[,idxLng] = as.numeric(latLng[,idxLng]) + latLng[,idxLat] = as.numeric(latLng[,idxLat]) + latLng = na.omit(latLng) + } else latLng = NULL + } else latLng = NULL + if (is.null(latLng) || nrow(latLng) == 0) + { +cat ("mapDsRunList trying PlotInit\n") + inInit = getTableName(dbGlb$dbIcon,"FVS_PlotInit") + if (!is.null(inInit)) + { + latLng = try(dbGetQuery(dbGlb$dbIcon, + paste0("select Stand_ID,avg(Latitude) as Latitude, ", + "avg(Longitude) as Longitude from ",inInit, + " group by Stand_ID;"))) + if (class(latLng)!="try-error") + { + latLng$Longitude = as.numeric(latLng$Longitude) + latLng$Latitude = as.numeric(latLng$Latitude) + latLng = na.omit(latLng) + if (nrow(latLng) > 0) latLng = subset(latLng, Latitude != 0 & Longitude != 0) + } else latLng = NULL + } else latlng = NULL + } + if (!is.null(latLng) && nrow(latLng)>0) + { +cat ("mapDsRunList names(latLng)=",names(latLng)," class(latLng)=",class(latLng),"\n") + idxLng = grep("Longitude",names(latLng),ignore.case=TRUE) + idxLat = grep("Latitude",names(latLng),ignore.case=TRUE) + idxID = grep("Stand_ID",names(latLng),ignore.case=TRUE) +cat (" idxLng=",idxLng," idxLat=",idxLat," idxID=",idxID,"\n") + latLng = latLng[,c(idxID,idxLng,idxLat)] + names(latLng)=c("Stand_ID","Longitude","Latitude") + keep = na.omit(match(uidsToGet,latLng[,"Stand_ID"])) +cat ("rows to keep=",length(keep),"\n") + if (length(keep)) + { + latLng[,"Longitude"] = ifelse(latLng[,"Longitude"]>0, + -latLng[,"Longitude"], latLng[,"Longitude"]) + latLng = latLng[keep,,drop=FALSE] + uniq = unique(latLng[,2:3]) + if (nrow(uniq) < nrow(latLng)) + { + newlatLng = NULL + for (row in 1:nrow(uniq)) + { + sub=subset(latLng,latLng[,2]==uniq[row,1] & latLng[,3]==uniq[row,2]) + if (nrow(sub) > 1) + { + sub = sub[order(sub[,1]),] + delta=nrow(sub)/2*5 + sub[,3] = sub[,3]+seq(-delta,delta,5)[1:nrow(sub)]*.00005 + } + newlatLng = rbind(newlatLng,sub) + } + latLng = newlatLng + } + uids = latLng[,"Stand_ID"] + uidsFound = c(uidsFound,uids) + latLng = st_as_sf(latLng, coords = c("Longitude","Latitude")) + latLng <- try(st_set_crs(latLng, + st_crs("+proj=longlat +ellps=WGS84 +datum=WGS84 +no_defs"))) + if ("try-error" %in% class(latLng)) + { + output$leafletMessage=renderText("Error setting projection in location data.") + return() + } + pp = st_transform(latLng,st_crs("epsg:4326")) + pts= if (is.null(pts)) pp else rbind(pts,pp) + ptsLbs= if (is.null(ptsLbs)) uids else rbind(ptsLbs,uids) + } + } + } + if (!length(uidsFound)) + { + output$leafletMessage=renderText("Couldn't find the stands in the spatial data") + return() + } + progress <- shiny::Progress$new(session,min=1,max=length(uidsFound)) + labs = list() + url = paste0(session$clientData$url_protocol,"//", + session$clientData$url_hostname, + session$clientData$url_pathname) + for (sid in uidsFound) + { + tab = subset(dispData,StandID == sid)[,-1] + labs[[length(labs)+1]] = + if (input$mapDsType == "table") + { + HTML(paste0('

StandID=',sid,df2html(tab))) + } else { + pvar = input$mapDsVar[1] + tab = subset(dispData,StandID == sid)[,intersect(names(dispData),c("Year","Species",pvar))] + pfile=paste0("www/s",sid,".png") +cat ("pfile=",pfile," nrow=",nrow(tab)," sid=",sid,"\n") + CairoPNG(file=pfile,height=1.7,width=2.3,units="in",res=100,bg = "transparent") + if (length(intersect(c("Species","Characteristic"),names(tab))) || + length(table(tab$Year)) == 1) tab$Year = as.factor(tab$Year) + p = ggplot(tab,aes_string(x="Year",y=pvar)) + geom_point() + theme( + legend.position="none", + text=element_text(size=8),axis.text=element_text(face="bold"), + panel.background=element_rect(fill=grDevices::rgb(1, 1, 1, .2, maxColorValue = 1)), + plot.background =element_rect(fill=grDevices::rgb(1, 1, 1, .5, maxColorValue = 1))) + if (!is.factor(tab$Year)) p = p+geom_line() + print(p) + dev.off() + url = paste0(session$clientData$url_protocol,"//", + session$clientData$url_hostname, + session$clientData$url_pathname) + pfile=if (isLocal()) paste0("/www/s",sid,".png") else + paste0(url,"www/s",sid,".png") + HTML(paste0('',sid,'')) + } + progress$set(message = paste0("Preparing ",sid), value = length(labs)) + } + progress$close() + map = leaflet() %>% addTiles() %>% + addTiles(urlTemplate = + paste0("https://mts1.google.com/vt/lyrs=",input$mapDsProvider, + "&hl=en&src=app&x={x}&y={y}&z={z}&s=G"),attribution = 'Google') + lops = labelOptions(opacity=.7) + pops = popupOptions(maxWidth = 2000,autoClose=FALSE,closeButton=TRUE,closeOnClick=FALSE,textOnly=TRUE) + if (length(pts)) + { + lbidx = match(ptsLbs,uidsFound) + map = map %>% addCircleMarkers(data=pts, radius = 6, color="#FFFF00", + stroke = FALSE, fillOpacity = 0.5, popup=labs[lbidx], + popupOptions = pops, label=labs[lbidx], labelOptions = lops) + } + if (length(polys)) + { + lbidx = match(polyLbs,uidsFound) + map = map %>% addPolygons(data=polys, color = "#FFFF00", + weight = 3, smoothFactor = 0.1, opacity = .3, fillOpacity = 0.2, + popup=labs[lbidx], popupOptions = pops, label=labs[lbidx], + labelOptions = lops, + highlightOptions = c(weight = 5, color = "#666", dashArray = NULL, + fillOpacity = 0.3, opacity = .6, bringToFront = TRUE)) + } + output$leafletMap = renderLeaflet(map) + } + }) + + ## Tools, related to Copy + observe({ + if (input$toolsPan == "Copy projects") + { + backups = dir (pattern="ProjectBackup") + if (length(backups)) + { + backups = sort(backups,decreasing=TRUE) + names(backups) = backups + } else backups=list() + updateSelectInput(session=session, inputId="pickBackup", + choices = backups, selected=NULL) + } + }) + + + ## deleteRun + observe({ + if(input$deleteRun > 0) + { + isolate({ + tit = globals$fvsRun$title + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "deleteRunDlg", + message = paste0('Delete run "', + globals$fvsRun$title,'" (and all related outputs)?'))) + }) + } + }) + observe({ + if (input$deleteRunDlgBtn > 0) + { + isolate({ +cat ("delete run",globals$fvsRun$title," uuid=",globals$fvsRun$uuid, + " runSel=",input$runSel,"lenRuns=",length(globals$FVS_Runs),"\n") + killIfRunning(globals$fvsRun$uuid) + removeFVSRunFiles(globals$fvsRun$uuid,all=TRUE) + deleteRelatedDBRows(globals$fvsRun$uuid,dbGlb$dbOcon) + removeFVSRun(dbGlb$prjDB,input$runSel) + if (file.exists("projectId.txt")) + { + prjid = scan("projectId.txt",what="",sep="\n",quiet=TRUE) + write(file="projectId.txt",prjid) + } + globals$saveOnExit = FALSE + globals$reloadAppIsSet=1 + session$reload() + }) + } + }) + + ## deleteAllOutputs + observe({ + if(input$deleteAllOutputs > 0) + { + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "deleteAllOutputsDlg", + message = "Delete all outputs?")) + } + }) + observe({ + if (input$deleteAllOutputsDlgBtn == 0) return() + isolate({ +cat ("delete all outputs\n") + dbGlb$dbOcon <- dbDisconnect(dbGlb$dbOcon ) + unlink("FVSOut.db") + for (uuid in globals$FVS_Runs) removeFVSRunFiles(uuid) + dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),"FVSOut.db") + }) + }) + + ## deleteAllRuns + observe({ + if(input$deleteAllRuns > 0) + { + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "deleteAllRunsDlg", + message = "Delete all runs and outputs?")) + } + }) + observe({ + if (input$deleteAllRunsDlgBtn == 0) return() + isolate({ +cat ("delete all runs and outputs\n") + rmfiles=dir(pattern="[.]pidStatus$") + for (tokill in rmfiles) killIfRunning(sub(".pidStatus","",tokill)) + dbGlb$dbOcon <- dbDisconnect(dbGlb$dbOcon) + unlink("FVSOut.db") + globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) + for (uuid in globals$FVS_Runs) + { + removeFVSRunFiles(uuid,all=TRUE) + removeFVSRun(dbGlb$prjDB,uuid) + } + globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) + dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),"FVSOut.db") + globals$saveOnExit = FALSE + globals$reloadAppIsSet=1 + session$reload() + }) + }) + + ## delZipBackup + observe({ + if(input$delZipBackup > 0) + { + fl = isolate(input$pickBackup) + if (is.null(fl)) return() + if (file.exists(fl)) + { + unlink(fl) + backups = dir (pattern="ProjectBackup") + if (length(backups)) + { + backups = sort(backups,decreasing=TRUE) + names(backups) = backups + } else backups=list() + updateSelectInput(session=session, inputId="pickBackup", + choices = backups, selected=NULL) + } + } + }) + + + ## mkZipBackup + observe({ + if(input$mkZipBackup > 0) + { + flst=dir() + del = grep("^ProjectBackup",flst) + if (length(del)) flst = flst[-del] + del = grep("^www",flst) + if (length(del)) flst = flst[-del] + del = grep("^projectIsLocked",flst) + if (length(del)) flst = flst[-del] + delFVSbin = grep ("^FVSbin",flst) + if (length(delFVSbin)) flst = flst[-delFVSbin] + createdFVSbin=FALSE + if (isolate(input$prjBckCnts)=="projFVS") + { + if (globals$fvsBin != "FVSbin") + { + if (!dir.exists("FVSbin")) dir.create("FVSbin") + fvsPgms = list.files(fvsBin,pattern=paste0(.Platform$dynlib.ext,"$"), + full.names=TRUE) + file.copy(fvsPgms,"FVSbin") + createdFVSbin=TRUE + } + fvsPgms = list.files("FVSbin",pattern=paste0(.Platform$dynlib.ext,"$")) + fvsPgms = paste0("FVSbin","/",fvsPgms) + flst = c(flst,fvsPgms) + } + zfile=paste0("ProjectBackup_",format(Sys.time(),"%Y-%m-%d_%H_%M_%S"),".zip") + # close the input and output databases if they are openned + ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) + icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) + if (ocon) dbDisconnect(dbGlb$dbOcon) + if (icon) dbDisconnect(dbGlb$dbIcon) + progress <- shiny::Progress$new(session,min=1,max=length(flst)) + for (i in 1:length(flst)) + { + x = flst[i] + progress$set(message = paste0("Adding ",x," to ",zfile), value = i) + rtn=if (file.exists(zfile)) try(zipr_append(zfile,x)) else try(zipr(zfile,x)) + if (class(rtn)=="try-error") + { + progress$set(message = paste0("Failed to add ",x," to ",zfile), value = i+1) + Sys.sleep(.2) + } + } + if (createdFVSbin) unlink("FVSbin") + if (ocon) dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbOcon@dbname) + if (icon) dbGlb$dbIcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbIcon@dbname) + Sys.sleep(.2) + progress$close() + backups = dir (pattern="ProjectBackup") + if (length(backups)) + { + backups = sort(backups,decreasing=TRUE) + names(backups) = backups + } else backups=list() + updateSelectInput(session=session, inputId="pickBackup", + choices = backups, selected=NULL) + } + }) + + ## Upload Project Backup--upZipBackup + observe({ + if (!isLocal()) return() + if (is.null(input$upZipBackup)) return() + prjBackupUpload = input$upZipBackup$name +cat ("prjBackupUpload=",prjBackupUpload,"\n") + progress <- shiny::Progress$new(session,min=1,max=5) + progress$set(message = "Begining project backup upload",value = 2) + ind <- grep("ProjectBackup_",prjBackupUpload) + fext <- tools::file_ext(basename(input$upZipBackup$name)) + if (!length(ind) && fext !="zip") + { + output$delPrjActionMsg = renderText("Uploaded file is not a valid project backup zip file") + unlink(input$upZipBackup$datapath) + progress$close() + return() + } + fdir = dirname(input$upZipBackup$datapath) + progress$set(message = "Copying project backup to current project directory",value = 4) + file.copy(input$upZipBackup$datapath,prjBackupUpload) + backups = dir(pattern="ProjectBackup") + if (length(backups)) + { + backups = sort(backups,decreasing=TRUE) + names(backups) = backups + updateSelectInput(session=session, inputId="pickBackup", + choices = backups, selected=backups[length(backups)]) + } else updateSelectInput(session=session, inputId="pickBackup", + choices = list(), selected=NULL) + output$delPrjActionMsg = renderText("Project backup added to above list of backups to process") + progress$close() + }) + + ## restorePrjBackup + observeEvent(input$restorePrjBackup, + { + if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() + cnts = zip_list(input$pickBackup) + if (length(cnts)==0) return() + if(length(grep("FVSbin",cnts$filename)) || + length(grep(paste0("FVS[a-z]*",.Platform$dynlib.ext,"$"),cnts$filename))) + { + output$btnA <-renderUI(HTML("Project files only")) + output$btnB <-renderUI(HTML("Project files and FVS software")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#restorePrjBackupDlgBtnC').show()")) + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "restorePrjBackupDlg", + message = paste0("WARNING: restoring this project backup will overwrite", + " any existing project files in this current project. If you don't", + " want to lose existing project files, consider restoring to a new empty", + " project instead. This backup also contains FVS software that will", + " overwrite your currently installed version with the software in the", + " backup, if selected. What contents would you like to restore?"))) + globals$prjFilesOnly = FALSE + } else { + output$btnA <- renderUI(HTML("Yes")) + output$btnB <-renderUI(HTML("No")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#restorePrjBackupDlgBtnC').hide()")) + globals$prjFilesOnly = TRUE + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "restorePrjBackupDlg", + message = paste0("WARNING: restoring this project backup will overwrite", + " any existing project files in this current project. If you don't", + " want to lose existing project files, consider restoring to a new", + " empty project instead. Are you sure?"))) + } + }) + + observeEvent(input$restorePrjBackupDlgBtnA,{ + isolate({ + if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() + progress <- shiny::Progress$new(session,min=1,max=5) + progress$set(message = "Unzipping project backup",value = 2) + fvsWorkBackup = input$pickBackup +cat ("restorePrjBackupDlgBtB fvsWorkBackup=",fvsWorkBackup,"\n") + if (file.exists(fvsWorkBackup)) + { + progress$set(message = "Checking backup contents",value = 3) + ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) + icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) + if (ocon) dbDisconnect(dbGlb$dbOcon) + if (icon) dbDisconnect(dbGlb$dbIcon) + td <- tempdir() + rtn = try(unzip (paste0(getwd(),"/",fvsWorkBackup),exdir=td, + overwrite=TRUE,junkpaths=FALSE)) + if (class(rtn)=="try-error") return() + zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) + del=NULL + for (todel in c("^www","^rFVS","R$",".html$",".zip$","treeforms.RData", + "^FVSbin","prms.RData",".log$")) del = c(del,grep (todel,zipConts)) + if (length(del)) lapply(paste0(td,"/",zipConts[del]),unlink,recursive=TRUE) + pgms=dir(td,pattern=paste0("FVS[a-z]*",.Platform$dynlib.ext,"$")) + if (length(pgms)) lapply(paste0(td,"/",pgms),unlink,recursive=TRUE) + curcnts=dir() + tokeep = grep("^ProjectBackup",curcnts) + tokeep = c(tokeep,grep("^projectId",curcnts)) + curcnts = curcnts[tokeep] + lapply(paste0(td,"/",curcnts),unlink,recursive=TRUE) + progress$set(message = "Copying backup contents",value = 4) + zipConts <- dir(td,recursive=TRUE) + lapply(zipConts,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) + unlink(td,recursive=TRUE) + } + if (ocon) dbGlb$dbOcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbOcon@dbname) + if (icon) dbGlb$dbIcon <- dbConnect(dbDriver("SQLite"),dbGlb$dbIcon@dbname) + globals$reloadAppIsSet=1 + globals$saveOnExit=FALSE + progress$close() + session$reload() + }) + }) + + observeEvent(input$restorePrjBackupDlgBtnB,{ + isolate({ + if (is.na(input$pickBackup) || is.null(input$pickBackup) || !file.exists(input$pickBackup)) return() + if(globals$prjFilesOnly){ + globals$prjFilesOnly = FALSE + return() + } + progress <- shiny::Progress$new(session,min=1,max=5) + progress$set(message = "Unzipping project backup",value = 2) + fvsWorkBackup = input$pickBackup +cat ("restorePrjBackupDlgBtnA fvsWorkBackup=",fvsWorkBackup,"\n") + if (file.exists(fvsWorkBackup)) + { + progress$set(message = "Checking backup contents",value = 3) + ocon = class(dbGlb$dbOcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbOcon) + icon = class(dbGlb$dbIcon) == "SQLiteConnection" && dbIsValid(dbGlb$dbIcon) + if (ocon) dbDisconnect(dbGlb$dbOcon) + if (icon) dbDisconnect(dbGlb$dbIcon) + curdir=getwd() + td <- paste0(tempdir(),"/pbk") + suppressWarnings(dir.create(td)) + setwd(td) + lapply(dir(),function(x) unlink(x,recursive=TRUE,force=TRUE)) + rtn = try(unzip (paste0(curdir,"/",fvsWorkBackup),exdir=td, + overwrite=TRUE,junkpaths=FALSE)) + if (class(rtn)=="try-error") return() + zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) + del=NULL + # TODO: most of this list is related to old versions the software (pre "package") + # and can be reviewed (many dropped) in the future, say 2024 or so. + for (todel in c("^www","^rFVS","R$",".html$",".zip$","treeforms.RData", + "prms.RData",".log$","FVS_Data.db.default","FVS_Data.db.empty", + "databaseDescription.xlsx","projectIsLocked.txt",".png$", + "SpatialData.RData.default" )) del = c(del,grep (todel,zipConts)) + if (length(del)) lapply(paste0(td,"/",zipConts[del]),unlink,recursive=TRUE) + mkFVSProjectDB() + zipConts <- dir(td,include.dirs=TRUE,recursive=TRUE) + pgms=dir(td,pattern=paste0("FVS[a-z]*",.Platform$dynlib.ext,"$")) + if (length(pgms)) + { + frompgms=paste0(td,"/",pgms) + todir=paste0(td,"/FVSbin") + dir.create(todir) + topgms=paste0(todir,"/",pgms) + file.rename(from=frompgms,to=topgms) + } + setwd(curdir) + curcnts=dir() + tokeep = grep("^ProjectBackup",curcnts) + tokeep = c(tokeep,grep("^projectId",curcnts)) + curcnts = curcnts[tokeep] + lapply(paste0(td,"/",curcnts),unlink,recursive=TRUE) + if (globals$fvsBin != "FVSbin" && length(topgms)) + { + progress$set(message = "Copying backup contents",value = 4) + zipContsFVS <- dir(paste0(td,"/FVSbin"),pattern=paste0("FVS[a-z]*",.Platform$dynlib.ext,"$")) + zipContsPrj <- zipConts[-(match(zipContsFVS,zipConts))] + lapply(zipContsFVS,function(x,td) file.copy(from=paste0(td,"/FVSbin/",x),to=globals$fvsBin,overwrite=TRUE),td) + lapply(zipContsPrj,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) + } else { + progress$set(message = "Copying backup contents",value = 4) + dir.create("FVSbin") + zipConts <- dir(td,recursive=TRUE) + lapply(zipConts,function(x,td) file.copy(from=paste0(td,"/",x),to=x,overwrite=TRUE),td) + } + unlink(td,recursive=TRUE) + } + globals$reloadAppIsSet=1 + globals$saveOnExit=FALSE + progress$close() + session$reload() + }) + }) + + observeEvent(input$restorePrjBackupDlgBtnC, + updateSelectInput(session=session, inputId="pickBackup", selected=NULL) + ) + + + ## PrjDelete + observe({ + if(input$PrjDelete > 0) + { + isolate({ + if (is.null(input$PrjDelSelect)) + { + output$delPrjActionMsg <- renderUI(HTML("No project selected.")) + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "PrjDeleteDlg", message= + paste0('Select a project to delete, press Yes or No to continue.'))) + } else { +cat ("PrjDelete, input$PrjDelSelect=",input$PrjDelSelect,"\n") + prjList=getProjectList() + nm = names(prjList)[charmatch(input$PrjDelSelect,prjList)] + output$delPrjActionMsg <- NULL + msg = if(length(grep("ProjectBackup_",dir("../",input$PrjDelSelect)))) + " contains project backups within it that you may want to download first. " else "" + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "PrjDeleteDlg", message = + paste0(nm,msg,"Are you sure you still want to delete this project?"))) + } + }) + } + }) + observe({ + if (input$PrjDeleteDlgBtn > 0) + { +cat("delete project button.") + isolate({ + if (is.null(input$PrjDelSelect)) + { + output$delPrjActionMsg <- renderUI(HTML("No project selected.")) + } else { + delPrj=paste0("../",input$PrjDelSelect) + if (file.exists(paste0(delPrj,"/projectIsLocked.txt"))) + { + output$delPrjActionMsg <- renderUI(HTML("Cannot delete a locked project.")) + } else { + if (nchar(delPrj)<4 || !dir.exists(delPrj)) + { + output$delPrjActionMsg <- renderUI(HTML("Project directory not found.")) + } else { + unlink(delPrj, recursive=TRUE) + output$delPrjActionMsg <- renderUI(HTML("Project deleted")) + updateProjectSelections() + } + } + } + }) + } + }) + + ## topHelp + observe({ + if (input$topPan == "Help") + { + if (! exists("fvshelp")) data(fvsOnlineHelpRender) + if (! exists("fvshelp")) fvshelp="

No help is available

" + output$uiHelpText <- renderUI(HTML(fvshelp)) + } + }) + + ## df2html + df2html <- function(sdat=NULL) + { + if (is.null(sdat) || nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + sdat[sdat == " "]=NA + html = paste0('") + for (i in 1:nrow(sdat)) + { + tbrow=unlist(lapply(sdat[i,],function (x) if (is.character(x)) x else format(x,digits=3))) + html = paste0(html,"") + } + paste0(html,"
', + paste0(colnames(sdat),collapse=''),"
",paste0(tbrow,collapse=""),"
") + } + + ## xlsx2html + xlsx2html <- function(tab=NULL,xlsxfile=NULL,cols=NULL,addLink=FALSE) + { + if (is.null(xlsxfile) || !file.exists(xlsxfile)) return(NULL) + cleanlines=function(line) + { + line=gsub(pattern="\n",replacement="",x=line,fixed=TRUE) + gsub(pattern="\r",replacement="",x=line,fixed=TRUE) + } + if (!file.exists(xlsxfile) || is.null(tab)) return(NULL) + if (tab %in% getSheetNames(xlsxfile)) + { + sdat = try(read.xlsx(xlsxFile=xlsxfile,sheet=tab)) + if (class(sdat) == "try-error") return (NULL) + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + if (!is.null(cols) && max(cols)<=ncol(sdat)) sdat = sdat[,cols] + sdat[sdat == " "]=NA + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + sdat = sdat[,!apply(sdat,2,function(x) all(is.na(x)))] + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + sdat = sdat[ !apply(sdat,1,function(x) all(is.na(x))),] + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + html = paste0("",tab,"") + html = paste0(html,'

") + for (i in 1:nrow(sdat)) + { + tbrow=cleanlines(as.character(sdat[i,])) + if (addLink) tbrow[1] = paste0('',tbrow[1],'') + html = paste0(html,"") + } + html = paste0(html,"
', + paste0(cleanlines(colnames(sdat)),collapse=""),"
",paste0(tbrow,collapse=""),"

") + return (html) + } else return (NULL) + } + + ## mkTableDescription + mkTableDescription <- function (tab) + { + html = NULL + xlsxfile=system.file("extdata", "databaseDescription.xlsx", package="fvsOL") + if (!is.null(tab) && nchar(tab)>0 && !is.null(xlsxfile) && file.exists(xlsxfile)) + { + sheets = sort(getSheetNames(xlsxfile), decreasing=FALSE) + if ("OutputTableDescriptions" %in% sheets) + { + tabs = read.xlsx(xlsxFile=xlsxfile,sheet="OutputTableDescriptions") + row = charmatch(toupper(tab),toupper(tabs[,1])) + html = paste0("",tab," ",tabs[row,2]) + mhtml = xlsx2html(tab,xlsxfile=xlsxfile,cols=c(1,4)) + if (!is.null(mhtml)) html = paste0(html,mhtml) + } + if ("GuideLinks" %in% sheets) + { + tabs = read.xlsx(xlsxFile=xlsxfile,sheet="GuideLinks") + row = charmatch(toupper(tab),toupper(tabs[,1])) + if(!is.null(html))html = paste0(html,"

Link to reference document for table ",tabs[row,1],"

") + } + } + HTML(html) + } + ## tabDescSel + observe({ + tab = input$tabDescSel +cat ("tabDescSel, tab=",tab,"\n") + output$tabDesc <- renderUI(mkTableDescription(tab)) + }) + ## tabDescSel2 + observe({ + tab = input$tabDescSel2 +cat ("tabDescSel2, tab=",tab,"\n") + output$tabDesc2 <- renderUI(mkTableDescription(tab)) + }) + + ## uploadData button + observe({ + if (input$uploadData > 0) + { + updateTabsetPanel(session=session, inputId="topPan", + selected="Manage Projects") + updateTabsetPanel(session=session, inputId="toolsPan", + selected="Import input data") + updateTabsetPanel(session=session, inputId="inputDBPan", + selected="Upload inventory data") + } + }) + + ## data upload code + observe({ + if(input$toolsPan == "Import input data") + { + updateTabsetPanel(session=session, inputId="inputDBPan", + selected="Upload inventory data") + output$step1ActionMsg <- NULL + output$step2ActionMsg <- NULL + } + }) + observe({ + if(input$inputDBPan == "Upload inventory data") + { +cat ("Upload inventory data\n") + output$step1ActionMsg <- NULL + output$step2ActionMsg <- NULL + } + }) + + ## initNewInputDB + initNewInputDB <- function (session,output,dbGlb) + { + updateSelectInput(session=session, inputId="editSelDBtabs", choices=list()) + updateSelectInput(session=session, inputId="editSelDBvars", choices=list()) + updateSelectInput(session=session, inputId="inVars", choices=list()) + updateSelectInput(session=session, inputId="Groups", choices=list()) + updateSelectInput(session=session, inputId="Stands", choices=list()) + output$tbl <- renderRHandsontable(NULL) + output$stdSel <- output$navRows <- renderUI(NULL) + dbGlb$rows <- NULL + dbGlb$rowSelOn <- dbGlb$navsOn <- FALSE + resetActiveFVS(globals) + } + + ## installDefaultData + installDefaultData <- function(empty=FALSE) + { + dbDisconnect(dbGlb$dbIcon) + if (empty) + { + frm=system.file("extdata", "FVS_Data.db.empty", package="fvsOL") + file.copy(frm,"FVS_Data.db",overwrite=TRUE) + unlink("SpatialData.RData") + } else { + frm=system.file("extdata", "FVS_Data.db.default", package="fvsOL") + file.copy(frm,"FVS_Data.db",overwrite=TRUE) + frm=system.file("extdata", "SpatialData.RData.default",ppackage="fvsOL") + file.copy(frm,"SpatialData.RData",overwrite=TRUE) + } + dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") + initNewInputDB(session,output,dbGlb) + loadStandTableData(globals, dbGlb$dbIcon) + updateStandTableSelection(session,input,globals) + loadVarData(globals,input,dbGlb$dbIcon) + updateVarSelection(globals,session,input) + } + ## installTrainDB + observe({ + if (input$installTrainDB == 0) return() + installDefaultData() + output$step1ActionMsg <- NULL + output$step2ActionMsg <- output$mapActionMsg <- renderText(HTML(paste0("Training database installed", + " (the inventory data and the related spatial data)."))) + }) + ## installTrainDB2 + observe({ + if (input$installTrainDB2 == 0) return() + installDefaultData() + output$mapActionMsg <- renderText(HTML(paste0("Training database installed", + " (the inventory data and the related spatial data)."))) + }) + ## installEmptyDB + observe({ + if (input$installEmptyDB == 0) return() + installDefaultData(empty=TRUE) + output$step1ActionMsg <- NULL + output$step2ActionMsg <- renderText(HTML("Empty database installed and spatial data deleted.")) + dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") + }) + ## Upload new database + observe({ + if (is.null(input$uploadNewDB)) return() + output$step1ActionMsg <- NULL + output$step2ActionMsg <- NULL + fext = tools::file_ext(basename(input$uploadNewDB$name)) +cat ("fext=",fext,"\n") + session$sendCustomMessage(type="jsCode", + list(code= "$('#input$installNewDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#input$addNewDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installTrainDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installEmptyDB').prop('disabled',true)")) + if (! (fext %in% c("accdb","mdb","db","sqlite","xlsx","zip"))) + { + output$step1ActionMsg = renderText("Uploaded file is not suitable database types described in Step 1.") + unlink(input$uploadNewDB$datapath) + return() + } else { + session$sendCustomMessage(type="jsCode", + list(code= "$('#installNewDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#addNewDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installTrainDB').prop('disabled',true)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installEmptyDB').prop('disabled',true)")) + } + fdir = dirname(input$uploadNewDB$datapath) + progress <- shiny::Progress$new(session,min=1,max=20) + if (fext == "zip") + { + progress$set(message = "Unzip data", value = 1) + unzip(input$uploadNewDB$datapath, junkpaths = TRUE, exdir = fdir) + unlink(input$uploadNewDB$datapath) + fname = dir(dirname(input$uploadNewDB$datapath)) + if (length(fname)>1) + { + output$step1ActionMsg = renderText(".zip contains more than one file.") + lapply (dir(dirname(input$uploadNewDB$datapath),full.names=TRUE),unlink) + progress$close() + return() + } else if (length(fname) == 0) { + output$actionMsg = renderText(".zip was empty.") + progress$close() + return() + } + fext = tools::file_ext(fname) + if (! (fext %in% c("accdb","mdb","db","sqlite","xlsx"))) + { + output$step1ActionMsg = renderText(".zip did not contain one of the suitable file types described in Step 1.") + lapply (dir(dirname(input$uploadNewDB$datapath),full.names=TRUE),unlink) + progress$close() + return() + } + } else fname = basename(input$uploadNewDB$datapath) +cat ("fext=",fext," fname=",fname," fdir=",fdir,"\n") + curDir=getwd() + setwd(fdir) + if (fext %in% c("accdb","mdb")) + { + progress$set(message = "Process schema", value = 2) +cat("curDir=",curDir," input dir=",getwd(),"\n") + pgm = if (exists("mdbToolsDir")) file.path(normalizePath(mdbToolsDir),"mdb-schema") else "mdb-schema" + if (.Platform$OS.type == "windows") pgm=paste0(pgm,".exe") + cmd = paste0(pgm," ",fname) +cat ("cmd=",cmd,"\n") + schema = if (.Platform$OS.type == "windows") try(shell(cmd,intern=TRUE)) else + try(system(cmd,intern=TRUE)) + if (class(schema)=="try-error" || !exists("schema") || length(schema) < 2 || schema[1] =="Unknown Jet version.") + { + setwd(curDir) + progress$close() + if (schema[1] =="Unknown Jet version.") output$step1ActionMsg = renderText("Unknown Jet version. Possible corrupt database.") else + output$step1ActionMsg = renderText("Error when attempting to extract data from Access database.") + session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") + return() + } + tbls = grep ("CREATE TABLE",schema,ignore.case=TRUE) + schema = schema[tbls[1]:length(schema)] + schema = gsub("\t"," ",schema,fixed=TRUE) + schema = gsub("[","]",schema,fixed=TRUE) + tbls = grep ("CREATE TABLE",schema,ignore.case=TRUE) + tbln=unlist(lapply(schema[tbls],function(x) if (length(grep("]",x,fixed=TRUE))) + scan(text=x,what="character",sep="]",quiet=TRUE)[2] else + scan(text=x,what="character",quiet=TRUE)[3])) + schema = gsub(" Long Integer"," Integer",schema,ignore.case=TRUE) + schema = gsub(" Int"," Integer",schema,ignore.case=TRUE) + schema = gsub(" Integereger"," Integer",schema,ignore.case=TRUE) + schema = gsub(" Memo.*)"," Text",schema,ignore.case=TRUE) + schema = gsub(" Memo"," Text",schema,ignore.case=TRUE) + schema = gsub(" Text.*)"," Text",schema,ignore.case=TRUE) + schema = gsub(" Double"," Real",schema,ignore.case=TRUE) + schema = gsub(" SHORT_DATE_TIME,"," Text,",schema,ignore.case=TRUE) + schema = gsub(" FLOAT,"," Real,",schema,ignore.case=TRUE) + schema = gsub(" NOT NULL"," ",schema,,ignore.case=TRUE) + schema = gsub(" Single"," Real",schema) + schema = gsub("]",'"',schema,fixed=TRUE) + cat ("begin;\n",file="sqlite3.import") + cat (paste0(schema,"\n"),file="sqlite3.import",append=TRUE) + cat ("commit;\n",file="sqlite3.import",append=TRUE) + progress$set(message = "Extract data", value = 3) + if(!length(grep("FVS_StandInit",tbln,ignore.case=TRUE))){ + setwd(curDir) + progress$close() + output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") + session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") + return() + } + pgm = if (exists("mdbToolsDir")) file.path(normalizePath(mdbToolsDir),"mdb-export") else "mdb-export" + if (.Platform$OS.type == "windows") pgm=paste0(pgm,".exe") + for (tab in tbln) + { + progress$set(message = paste0("Export table ",tab), value = 3) + cat ("begin;\n",file="sqlite3.import",append=TRUE) + cmd = paste0 (pgm," -I sqlite ",fname," ",tab," >> sqlite3.import") + cat ("cmd=",cmd,"\n") + result = if (.Platform$OS.type == "windows") shell(cmd,intern=TRUE) else system(cmd,intern=TRUE) + cat ("commit;\n",file="sqlite3.import",append=TRUE) + } + cat (".quit\n",file="sqlite3.import",append=TRUE) + progress$set(message = "Import data to Sqlite3", value = 4) + pgm = if (exists("sqlite3exe")) sqlite3exe else "sqlite3" + cmd = paste0(pgm," FVS_Data.db < sqlite3.import") +cat ("cmd=",cmd,"\n") + if (.Platform$OS.type == "windows") shell(cmd) else system(cmd) +cat ("cmd done.\n") + dbo = dbConnect(dbDrv,"FVS_Data.db") + } else if (fext == "xlsx") + { + progress$set(message = "Get data sheets", value = 3) + sheets = getSheetNames(fname) + sheetsU <- toupper(sheets) + if(!length(grep("FVS_STANDINIT",sheetsU))) + { + setwd(curDir) + progress$close() + output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") + session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") + return() + } + normNames = c("FVS_GroupAddFilesAndKeywords","FVS_PlotInit", + "FVS_StandInit","FVS_TreeInit") + dbo = dbConnect(dbDrv,"FVS_Data.db") + dbdis=system.file("extdata","databaseDescription.xlsx",package="fvsOL") + standNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_StandInit")) + standNT = if (class(standNT) == "try-error") NULL else apply(standNT[,c(1,3)],2,toupper) + treeNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_TreeInit")) + treeNT = if (class(treeNT) == "try-error") NULL else apply(treeNT[,c(1,3)],2,toupper) + plotNT = try(read.xlsx(xlsxFile=dbdis,sheet="FVS_PlotInit")) + plotNT = if (class(plotNT) == "try-error") NULL else apply(plotNT[,c(1,3)],2,toupper) + i = 3 + for (sheet in sheets) + { + i = i+1 +cat ("sheet = ",sheet," i=",i,"\n") + progress$set(message = paste0("Processing sheet ",i," name=",sheet), value=i) + sdat = read.xlsx(xlsxFile=fname,sheet=sheet) + sdat[[3]] <- gsub("_x000D_", "", sdat[[3]]) + im = grep(sheet,normNames,ignore.case=TRUE) + if (length(im)) sheet = normNames[im] + NT = switch(sheet,"FVS_StandInit"=standNT,"FVS_TreeInit"=treeNT, + "FVS_PlotInit"=plotNT,NULL) + if (!is.null(NT)) + { + std = pmatch(toupper(names(sdat)),NT[,1]) + for (icol in 1:length(sdat)) + { + if (!is.na(std[icol])) sdat[,icol] = + switch(NT[std[icol],2], + "TEXT" = as.character(sdat[,icol]), + "REAL" = as.numeric (sdat[,icol]), + "INTEGER" = as.integer (sdat[,icol])) + } + } + dbWriteTable(conn=dbo,name=sheet,value=sdat) + } + } else { + i = 0 + file.rename(from=fname,to="FVS_Data.db") + dbo = dbConnect(dbDrv,"FVS_Data.db") + tabs = toupper(myListTables(dbo)) + if(!length(grep("FVS_STANDINIT",tabs))) + { + setwd(curDir) + progress$close() + output$step1ActionMsg = renderText("FVS_StandInit table is missing from your input data.") + session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") + return() + } + } + tabs = myListTables(dbo) + fiaData = "FVS_STANDINIT_COND" %in% toupper(tabs) && + "FVS_STANDINIT_PLOT" %in% toupper(tabs) + if (fiaData) + { + fiaMsg=NULL + progress$set(message = "FIA data detected, most checks skipped", value = 1) + # insure that the DSNIn keywords address FVS_Data.db in the FVS_GroupAddFilesAndKeywords table + grpAdd = try(dbGetQuery(dbo,'select * from "fvs_groupaddfilesandkeywords"')) + if (class(grpAdd) != "try.error") + { + kwi = match("FVSKEYWORDS",toupper(names(grpAdd)))[1] + if (!is.na(kwi)) + { + ch = gsub("\nDSNIn\n.{1,}\nStandSQL","\nDSNIn\nFVS_Data.db\nStandSQL",grpAdd[,kwi]) + if (any(ch!=grpAdd[,kwi])) + { + grpAdd[,kwi] = ch + fiaMsg = "FVS_GroupAddFilesAndKeywords FVSKeywords field was modified" + dbWriteTable(dbo,"FVS_GroupAddFilesAndKeywords",grpAdd,overwrite=TRUE) + } + } + } + } else { + # get rid of "NRIS_" part of names if any + for (tab in tabs) + { +cat("loaded table=",tab,"\n") + nn = sub("NRIS_","",tab) + if (nchar(nn) && nn != tab) dbExecute(dbo,paste0("alter table ",tab," rename to ",nn)) + } + tabs = myListTables(dbo) + ltabs = tolower(tabs) + fixTabs=c(grep ("standinit",ltabs,fixed=TRUE),grep ("plotinit",ltabs)) + # if there is a FVS_GroupAddFilesAndKeywords table, grab the unique group codes + grpmsg=NULL + progress$set(message = "Checking FVS_GroupAddFilesAndKeywords", value = 4) + if ("fvs_groupaddfilesandkeywords" %in% ltabs) + { + addgrps=try(dbGetQuery(dbo,'select distinct groups from "fvs_groupaddfilesandkeywords"')) + if (class(addgrps)!="try-error") + { + addgrps=unique(unlist(lapply(addgrps[,1],function (x) scan(text=x,what="character",quiet=TRUE)))) +cat ("addgrps=",paste0(addgrps,collapse=" "),"\n") + for (idx in fixTabs) + { + tab2fix=tabs[idx] + grps=try(dbGetQuery(dbo,paste0("select distinct groups from '",tab2fix,"'"))) + if (class(grps)=="try-error") next + if (is.na(grps[1,1])) next + grps=unique(unlist(lapply(grps[,1],function (x) scan(text=x,what="character",quiet=TRUE)))) + if (any(is.na(match(addgrps,grps))) && !length(match(grps,addgrps))) + { + Tb=try(dbReadTable(dbo,tab2fix)) + if (class(Tb)=="try-error") next + idx=match("groups",tolower(names(Tb))) + if (!is.na(idx) && nrow(Tb)) + { + idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) grep("Plots",addgrps) else grep("Stands",addgrps) + ridxs <- grep(grps[grep("NA",as.list(match(addgrps,grps)))],Tb[,idx]) + Tb[ridxs,idx]=paste0(addgrps[idf]," ",Tb[ridxs,idx]) + if (class(try(dbWriteTable(dbo,tab2fix,Tb,overwrite=TRUE)))!="try-error") + grpmsg=c(grpmsg,tab2fix) + } + } + } + } + } + # checking for required group codes and blank Stand_CN + if ("fvs_standinit" %in% ltabs) + { + qry="update FVS_StandInit set Groups = 'All_Stands '|| Groups where Groups is not null + and Groups not LIKE '%All_Stands%';" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + qry="update FVS_StandInit set Groups = 'All_Stands' where Groups is null;" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + qry="update FVS_StandInit set Stand_CN = (select Stand_ID from FVS_StandInit) where Stand_CN is null;" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + } + if ("fvs_plotinit" %in% ltabs) + { + qry="update FVS_PlotInit set Groups = 'All_Plots '|| Groups where Groups is not null + and Groups not LIKE '%All_Plots%';" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + qry="update FVS_PlotInit set Groups = 'All_Plots' where Groups is null;" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + qry="update FVS_PlotInit set Stand_CN = (select Stand_ID from FVS_PlotInit) where Stand_CN is null;" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + } + if ("fvs_treeinit" %in% ltabs) + { + qry="update FVS_TreeInit set Stand_CN = (select Stand_ID from FVS_TreeInit) where Stand_CN is null;" + rtn=try(dbExecute(dbo,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + } +cat ("checking duplicate stand or standplot ids\n") + progress$set(message = "Checking for duplicate StandID values", value = 5) + # loop over tables and omit duplicate stand or standplot id's from being uploaded + sidmsg=NULL + newID=NULL + for (idx in fixTabs) + { +cat ("checking tabs[idx]=",tabs[idx],"\n") + if (tolower(tabs[idx]) %in% c("fvs_standinit_plot","fvs_standinit_cond", + "fvs_treeinit_plot","fvs_treeinit_cond","fvs_plotinit_plot")) next + tab2fix=tabs[idx] + idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) "standplot_id" else "stand_id" + qry = paste0("select ",idf," from '",tab2fix,"'") +cat ("qry=",qry,"\n") + sidTb=try(dbGetQuery(dbo,qry)) + if (class(sidTb)=="try-error") next + dups = duplicated(sidTb[,1]) + if (all(!dups)) next + keep <- list() + cntr <- 1 + for (i in 1:length(dups)){ + if (dups[i]==FALSE){ + keep[cntr] <- i + cntr <- cntr +1 + } + } + sidTb=try(dbReadTable(dbo,tab2fix)) + if (class(sidTb)=="try-error") next + sidTb=sidTb[as.numeric(keep),] + dbWriteTable(dbo,tab2fix,sidTb,overwrite=TRUE) + sidmsg=c(sidmsg,tab2fix) + } + # remove any leading or trailing spaces in stand id's which blow up the SQL queries at run time + fixTabs=c(grep ("standinit",ltabs,fixed=TRUE),grep ("plotinit",ltabs),grep ("treeinit",ltabs)) + for (idx in fixTabs) + { +cat ("checking tabs[idx]=",tabs[idx],"\n") + if (tolower(tabs[idx]) %in% c("fvs_standinit_plot","fvs_standinit_cond", + "fvs_treeinit_plot","fvs_treeinit_cond","fvs_plotinit_plot")) next + tab2fix=tabs[idx] + idf = if (length(grep("plot",tab2fix,ignore.case=TRUE))) "standplot_id" else "stand_id" + qry = paste0("select ",idf," from '",tab2fix,"'") +cat ("qry=",qry,"\n") + sidTb=try(dbGetQuery(dbo,qry)) + if (class(sidTb)=="try-error") next + if(length(sidTb[[1]])==0) next + sidTb <- data.frame(trim(sidTb[[1]])) + names(sidTb) <- toupper(idf) + sidTbAll=try(dbReadTable(dbo,tab2fix)) + if (idf == "standplot_id") oldSID <- grep("StandPlot_ID",names(sidTbAll),ignore.case=TRUE) else + oldSID <- grep("Stand_ID",names(sidTbAll),ignore.case=TRUE) + sidTbAll <- sidTbAll[,-oldSID] + sidTbAll <- append(sidTbAll,sidTb, after=0) + if (class(sidTbAll)=="try-error") next + dbWriteTable(dbo,tab2fix,data.frame(sidTbAll),overwrite=TRUE) + } +cat ("sidmsg=",sidmsg,"\n") + } + progress$set(message = "Getting row counts", value = 6) + rowCnts = unlist(lapply(tabs,function (x) dbGetQuery(dbo, + paste0("select count(*) as '",x,"' from '",x,"';")))) + msg = lapply(names(rowCnts),function(x) paste0(x," (",rowCnts[x]," rows)")) + msg = paste0("Uploaded data:
",paste0(msg,collapse="
")) + if (!fiaData) + { + if (!is.null(grpmsg)) msg=paste0(msg,"
Groups values were modified in table(s): ", + paste0(grpmsg,collapse=", ")) + if (!is.null(sidmsg)) msg=paste0(msg,"
Duplicate Stand_ID or StandPlot_ID values were found in table(s): ", + paste0(sidmsg,collapse=", "),".
All duplicate values after the first value were not kept.") +cat ("calling fixFVSKeywords\n") + progress$set(message = "Checking FVSKeywords", value = 7) + tt = try(fixFVSKeywords(dbo)) + canuse=class(tt) == "NULL" + if (class(tt)=="character") msg = paste0(msg, + "
Checking keywords: ",tt) + progress$set(message = "Checking for minimum column definitions", value = 8) + tt = try(checkMinColumnDefs(dbo,progress,9)) + canuse=canuse && class(tt) == "NULL" + if (class(tt)=="character") msg = paste0(msg,"
Checking columns: ",tt) + if (!canuse) msg = paste0(msg, + "

Data checks indicate there are unresolved problems in the input.

") +cat ("msg=",msg,"\n") + } else msg = paste0(msg,if (!is.null(fiaMsg)) paste0("
",fiaMsg) else "", + "

Data checks are skipped when FIA data is detected.

") + output$step1ActionMsg = renderUI(HTML(msg)) + dbGlb$newFVSData = tempfile() + dbDisconnect(dbo) + file.copy(from="FVS_Data.db",to=dbGlb$newFVSData,overwrite=TRUE) + session$sendCustomMessage(type = "resetFileInputHandler","uploadNewDB") + session$sendCustomMessage(type="jsCode", + list(code= "$('#installNewDB').prop('disabled',false)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#addNewDB').prop('disabled',false)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installTrainDB').prop('disabled',false)")) + session$sendCustomMessage(type="jsCode", + list(code= "$('#installEmptyDB').prop('disabled',false)")) + setwd(curDir) + progress$close() + }) + ## installNewDB + observe({ + if (input$installNewDB == 0) return() + if (is.null(dbGlb$newFVSData)) return() + if (!file.exists(dbGlb$newFVSData) || file.size(dbGlb$newFVSData) == 0) return() + dbDisconnect(dbGlb$dbIcon) + file.copy(dbGlb$newFVSData,"FVS_Data.db",overwrite=TRUE) + unlink(dbGlb$newFVSData) + dbGlb$newFVSData=NULL + dbGlb$dbIcon <- dbConnect(dbDrv,"FVS_Data.db") + progress <- shiny::Progress$new(session,min=1,max=8) + i = 1 + progress$set(message="Checking for FVS_GroupAddFilesAndKeywords",value=i) + # Add an FVS_GroupAddFilesAndKeywords table if needed. + addkeys = getTableName(dbGlb$dbIcon,"FVS_GroupAddFilesAndKeywords") + if (is.null(addkeys)) need = TRUE else + { + gtab = try(dbReadTable(dbGlb$dbIcon,addkeys)) + need = class(gtab) == "try-error" + if (!need) need = nrow(gtab) == 0 + names(gtab) = toupper(names(gtab)) + if (!need) need = all(is.na(gtab$FVSKEYWORDS)) + if (!need) need = all(gtab$FVSKEYWORDS == "") + } + if (need) + { + treeInit = getTableName(dbGlb$dbIcon,"FVS_TreeInit") + if (is.null(treeInit)) treeInit="FVS_TreeInit" + dfinstand=NULL + grps = list("FVS_StandInit"="All All_Stands", + "FVS_PlotInit"="All All_Plots", + "FVS_StandInit_Cond"="All All_Conds") + for (std in names(grps)) + { + stdInit = getTableName(dbGlb$dbIcon,std) + if (is.null(stdInit)) next + linkID = if(stdInit=="FVS_PlotInit") "StandPlot_ID" else "Stand_ID" + dfinstand = rbind(dfinstand, + data.frame(Groups = grps[[std]],Addfiles = "", + FVSKeywords = paste0("Database\nDSNIn\nFVS_Data.db\nStandSQL\n", + "SELECT * FROM ",stdInit,"\nWHERE ",linkID,"= '%StandID%'\n", + "EndSQL\nTreeSQL\nSELECT * FROM ",treeInit,"\n", + "WHERE ",linkID,"= '%StandID%'\nEndSQL\nEND"))) + } + dbWriteTable(dbGlb$dbIcon,"FVS_GroupAddFilesAndKeywords",value=dfinstand,overwrite=TRUE) + } + tabs = myListTables(dbGlb$dbIcon) + for (tb in tabs) + { + i = i+1 + progress$set(message = paste0("Setting up index for table ",tb), value=i) + if (tolower(tb) == "fvs_climattr") + { + rtn = try(dbExecute(dbGlb$dbIcon,"drop index if exists StdScnIndex")) + if (class(try)!="try-error") + { + qry = "create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);" +cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } else if (tolower(tb) == "fvs_standinit_cond" || tolower(tb) == "fvs_treeinit_cond") + { + tbidx = grep(tb,c("FVS_StandInit_Cond","FVS_TreeInit_Cond"),ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") +cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + } else if (tolower(tb) == "fvs_standinit_plot") + { + tbidx = grep(tb,c("FVS_StandInit_Plot","FVS_TreeInit_Plot"),ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") +cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + } else if (tolower(tb) == "fvs_plotinit_plot") + { + tbidx = grep(tb,c("FVS_PlotInit_Plot"), + ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") +cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + } + else if (tolower(tb) == "fvs_treeinit_plot") + { + tbidx = grep(tb,c("FVS_TreeInit_Plot"), + ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") + cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + }else if (tolower(tb) == "fvs_plotinit") + { + tbidx = grep(tb,c("FVS_PlotInit","FVS_TreeInit"), + ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (StandPlot_ID);") + cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + }else { + tbidx = grep(tb,c("FVS_StandInit","FVS_TreeInit"), + ignore.case=TRUE) + if (length(tbidx)) + { + tbinx = paste0("idx",tb) + rtn = try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + if (class(try)!="try-error") + { + qry = paste0("create index ",tbinx," on ",tb," (Stand_ID);") +cat ("index creation, qry=",qry,"\n") + try(dbExecute(dbGlb$dbIcon,qry)) + } + } + } + } + progress$set(message = "Load variant data", value = i+1) + resetActiveFVS(globals) + loadVarData(globals,input,dbGlb$dbIcon) + output$step2ActionMsg = renderText(HTML(paste0("
Uploaded data installed.
", + "WARNING: If existing runs in this project were created using input ", + "data that are not present in the database just installed, ", + "you will need to re-load those data to run them again.
", + "Note that the output from the previous runs will remain in the output database."))) + initNewInputDB(session,output,dbGlb) + progress$close() + }) + + ## addNewDB + observe({ + if (input$addNewDB == 0) return() + output$step2ActionMsg <- NULL + if (is.null(dbGlb$newFVSData)) {output$step1ActionMsg<-NULL;return()} + dbo = dbConnect(dbDrv,dbGlb$newFVSData) + newtabs = myListTables(dbo) + dbDisconnect(dbo) + if (length(newtabs)==0) return() + # set an exclusive lock on the database + dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = EXCLUSIVE") + progress <- shiny::Progress$new(session,min=1,max=length(newtabs)*2+3) + i=2 + progress$set(message = "Getting exclusive database lock", value=1) + trycnt=0 + while (TRUE) + { + trycnt=trycnt+1 + if (trycnt > 1000) + { + dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = NORMAL") + myListTables(dbGlb$dbIcon) # this forces the new locking mode to take effect + output$step2ActionMsg <- renderText("Error: Exclusive lock was not obtained.") + progress$close() + return() + } +cat ("try to get exclusive lock on input database, trycnt=",trycnt,"\n"); + rtn <- try(dbExecute(dbGlb$dbIcon,"create table dummy (dummy int)")) + if (class(rtn) != "try-error") break; + Sys.sleep (1) + } + dbExecute(dbGlb$dbIcon,"drop table if exists dummy") + oldInds = dbGetQuery(dbGlb$dbIcon,"select name from sqlite_master where type='index';")[,1] + for (idx in oldInds) dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",idx,";")) + oldtabs = myListTables(dbGlb$dbIcon) + progress$set(message = "Attaching new database.", value=2) + attach = try(dbExecute(dbGlb$dbIcon,paste0("attach '",dbGlb$newFVSData,"' as addnew;"))) + if (class(attach) == "try-error") + { + output$step2ActionMsg <- renderText("New data could not be added") + unlink(dbGlb$newFVSData) + progress$close() + dbGlb$newFVSData=NULL + } + justNew = setdiff(newtabs,oldtabs) + for (tab in justNew) + { + i=i+1 + progress$set(message = paste0("Loading ",tab), value = i) + qry=paste0("create table ",tab," as select * from addnew.",tab) +cat("qry=",qry,"\n") + rtn = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(rtn)=="try-error") cat ("qry failed:",qry,"\n") + } + newtabs = setdiff(newtabs,justNew) + for (tab in newtabs) + { + i=i+1 + progress$set(message = paste0("Loading ",tab), value = i) + rows=try(dbGetQuery(dbGlb$dbIcon,paste0("select count(*) from ",tab))) + if (class(rows)=="try-error") next + if (class(rows)=="data.frame" && rows[1,1]==0) + { + cat ("no rows in ",tab,"\n") + next + } + newTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma addnew.table_info(",tab,")")) + trgTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma table_info(",tab,")")) + sid1 = toupper(newTdef$name) + sid2 = toupper(trgTdef$name) + if ("STAND_ID" %in% sid1 && "STAND_ID" %in% sid2) + { + qry = paste0("delete from ",tab," where Stand_ID in ", + "(select Stand_ID from addnew.",tab,")") + rtn = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(rtn)=="try-error") cat ("removing duplicated Stand_IDs failed.") + } + if (tolower(tab) == "fvs_groupaddfilesandkeywords") + dbExecute(dbGlb$dbIcon,paste0("delete from ",tab," where 'Groups' in ", + " (select 'Groups' from addnew.",tab,")")) + # homogenize table structure and then do the insert from ... + newTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma addnew.table_info(",tab,")")) + trgTdef = dbGetQuery(dbGlb$dbIcon,paste0("pragma table_info(",tab,")")) + newTdef$lcname = tolower(newTdef$name) + trgTdef$lcname = tolower(trgTdef$name) + missingInTrg = setdiff(newTdef$lcname,trgTdef$lcname) + missingIndx = match(missingInTrg,newTdef$lcname) + if (length(missingIndx) && !any(is.na(missingIndx))) + { + for (ii in missingIndx) + { + qry = paste0("alter table '",tab,"' add column ",newTdef$name[ii], + " ",newTdef$type[ii],";") +cat ("alter table qry=",qry,"\n") + rtn = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(rtn)=="try-error") cat ("qry failed\n") + } + } + alln = paste0(newTdef$name,collapse=",") + qry = paste0("insert into ",tab," (",alln,") select ",alln, + " from addnew.",tab,";") +cat ("insert qry=",qry,"\n") + rtn = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(rtn)=="try-error") cat ("qry failed\n") + } + dbExecute(dbGlb$dbIcon,paste0("detach addnew;")) + unlink(dbGlb$newFVSData) + dbGlb$newFVSData=NULL + # fix up the DBH/DIAMETER mess. If DIAMETER is in the data table, then it needs to take on the values + # of DBH if they are also in the table. + cols=tolower(dbGetQuery(dbGlb$dbIcon,"PRAGMA table_info('FVS_TreeInit')")[,"name"]) + if ("dbh" %in% cols && "diameter" %in% cols) + { + qry=paste0("update FVS_TreeInit set DIAMETER = (select DBH where DIAMETER is null ", + "and DBH is not null) where DIAMETER is null and DBH is not null;") + rtn=try(dbExecute(dbGlb$dbIcon,qry)) +cat ("qry=",qry,"\nrtn=",rtn,"\n") + } + tabs = dbGetQuery(dbGlb$dbIcon,"select * from sqlite_master where type='table'")[,"tbl_name"] + i = i+1 + progress$set(message = "Setting up indices", value=i) + for (tb in tabs) + { + i = i+1 + progress$set(message = paste0("Setting up index for table ",tb), value=i) + if (tolower(tb) == "fvs_climttr") + { + dbExecute(dbGlb$dbIcon,"drop index if exists StdScnIndex") + dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") + } else if ("Stand_ID" %in% dbListFields(dbGlb$dbIcon,tb)) + { + tbinx = paste0("idx",tb) + try(dbExecute(dbGlb$dbIcon,paste0("drop index if exists ",tbinx))) + try(dbExecute(dbGlb$dbIcon,paste0("create index ",tbinx," on ",tb," (Stand_ID);"))) + } + } + dbExecute(dbGlb$dbIcon,"PRAGMA locking_mode = NORMAL") + rowCnts = unlist(lapply(tabs,function (x) dbGetQuery(dbGlb$dbIcon, + paste0("select count(*) as ",x," from ",x,";")))) + msg = lapply(names(rowCnts),function(x) paste0(x," (",rowCnts[x]," rows)")) + msg = paste0("Combined (newly installed) database:
",paste0(msg,collapse="
")) + output$step2ActionMsg <- renderText(msg) + loadVarData(globals,input,dbGlb$dbIcon) + initNewInputDB(session,output,dbGlb) + progress$close() + }) + + ## AppendCSV + observe({ + if(input$inputDBPan == "Append .csv data to existing tables") + { +cat ("Upload new rows\n") + tbs <- myListTables(dbGlb$dbIcon) + dbGlb$tbsCTypes <- lapply(tbs,function(x,dbIcon) + { + tb <- dbGetQuery(dbIcon,paste0("PRAGMA table_info('",x,"')")) + tbtypes = toupper(tb[,"type"]) + res = vector("logical",length(tbtypes)) + res[grep ("INT",tbtypes)] = TRUE + res[grep ("FLOAT",tbtypes)] = TRUE + res[grep ("REAL",tbtypes)] = TRUE + names(res) = tb[,"name"] + res[] = !res + }, dbGlb$dbIcon) + names(dbGlb$tbsCTypes) = tbs + if (length(tbs)) + { + idx <- grep ("FVS_ClimAttrs",tbs,ignore.case=TRUE) + if (length(idx)) tbs = tbs[-idx] + idx <- grep ("StandInit",tbs) + if (length(idx) == 0) idx=1 + updateSelectInput(session=session, inputId="uploadSelDBtabs", choices=tbs, + selected=tbs[idx]) + } else updateSelectInput(session=session, inputId="uploadSelDBtabs", + choices=list()) + output$step2ActionMsg <- renderText(if (length(tbs)) "" else + "No tables in existing database.") + initNewInputDB(session,output,dbGlb) + } + }) + ## uploadStdTree + observe({ + if (is.null(input$uploadStdTree)) return() + isolate({ + indat = try(read.csv(file=input$uploadStdTree$datapath,as.is=TRUE,colClasses="character")) + unlink(input$uploadStdTree$datapath) + if (class(indat) == "try-error" || is.null(indat) || nrow(indat)==0) + { + output$uploadActionMsg = renderText("Input empty, no data loaded.") + Sys.sleep(1) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + return() + } + del = apply(indat,1,function (x) + { + x = as.vector(x) + x[is.na(x)] = "" + all(x == "") + }) + indat = indat[!del,,drop=FALSE] + if (nrow(indat)==0) + { + output$uploadActionMsg = renderText("All rows were empty, no data loaded.") + Sys.sleep(1) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + return() + } + cols = na.omit(charmatch(tolower(colnames(indat)), + tolower(names(dbGlb$tbsCTypes[[input$uploadSelDBtabs]])))) + if (length(cols) == 0) + { + output$uploadActionMsg = renderText(paste0("No columns match what is defined for ", + input$uploadSelDBtabs,", no data loaded.")) + Sys.sleep(1) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + return() + } + addCols = attr(cols,"na.action") +cat ("addCols=",addCols,"\n") + if (length(addCols)) + { + types = dbGlb$tbsCTypes[[input$uploadSelDBtabs]] + for (icol in addCols) + { + newVar=names(indat)[icol] + defType=charmatch(tolower(newVar),tolower(names(types))) + dtyp = if (is.na(defType)) "character" else + if (types[defType]) "character" else "real" + qry = paste0("alter table ",input$uploadSelDBtabs," add column ", + newVar," ",dtyp,";") +cat ("add column qry=",qry,"\n") + added = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(added) != "try-error") + { + v = dtyp == "character" + names(v) = newVar + dbGlb$tbsCTypes[[input$uploadSelDBtabs]] = c(dbGlb$tbsCTypes[[input$uploadSelDBtabs]],v) + } + } + } + cols = na.omit(charmatch(tolower(colnames(indat)), + tolower(names(dbGlb$tbsCTypes[[input$uploadSelDBtabs]])))) + types = dbGlb$tbsCTypes[[input$uploadSelDBtabs]][cols] + req = switch(tolower(input$uploadSelDBtabs), + fvs_standinit = c("stand_id","variant","inv_year"), + fvs_plotinit = c("stand_id","variant","inv_year"), + fvs_treeinit = c("stand_id","species","dbh"), + fvs_groupaddfilesandkeywords = c("groups"), + NULL) + if (!is.null(req) && !all(req %in% tolower(names(types)))) + { + output$uploadActionMsg = renderText(paste0("Required columns were missing for ", + input$uploadSelDBtabs,", no data loaded.")) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + return() + } + nums = tolower(names(types[!types])) + lnams = tolower(names(indat)) + for (nn in nums) + { + indx=match(nn,lnams) + indat[,indx] = as.numeric(indat[,indx]) + } + + sids=try(dbGetQuery(dbGlb$dbIcon,paste0("select distinct stand_id from ", + isolate(input$uploadSelDBtabs)))) + sids=if (class(sids)=="try-error") NA else sids[,1] + isid=charmatch("stand_id",tolower(names(indat))) + msg=NULL + if (!(is.na(sids) || is.na(isid))) + { + tokeep=is.na(match(indat[,isid],sids)) + ntokill=sum(!tokeep) + if (ntokill==nrow(indat)) + { + output$uploadActionMsg = renderUI(HTML("All uploaded data have Stand_ID(s) that are already loaded and are ignored.")) + return() + } else { + msg = paste0(ntokill," lines of uploaded data have Stand_ID(s) that are already loaded and are ignored.") + indat = indat[tokeep,,drop=FALSE] + } + } + dbBegin(dbGlb$dbIcon) + err = FALSE + insertCount = 0 + for (i in 1:nrow(indat)) + { + row = indat[i,,drop=FALSE] + row = row[,!is.na(row),drop=FALSE] + if (ncol(row) == 0) next + row = row[,row != "'NA'",drop=FALSE] + if (ncol(row) == 0) next + vals=paste0(lapply(row[1,],function (x) if (class(x)=="character") paste0('"',x,'"') else x),collapse=",") + qry = paste0("insert into ",input$uploadSelDBtabs," (", + paste0(colnames(row),collapse=","),") values (",vals,");") +cat ("insert qry=",qry,"\n") + res = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(res) == "try-error") {err=TRUE; break} else insertCount = insertCount+1 + } + if (err) + { + dbRollback(dbGlb$dbIcon) + output$uploadActionMsg = renderUI(HTML(paste0("Error processing: ",qry))) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + return() + } else { +cat ("insertCount=",insertCount,"\n") + dbCommit(dbGlb$dbIcon) + msg=paste0(msg,"
",insertCount," row(s) inserted into ",isolate(input$uploadSelDBtabs)) + output$uploadActionMsg = renderUI(HTML(msg)) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + loadVarData(globals,input,dbGlb$dbIcon) + } + Sys.sleep(1) + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + # this section removes records that have missing values for standID or group + keyCol = NULL + if (length(grep("standinit",input$uploadSelDBtabs,ignore.case=TRUE)) || + length(grep("treeinit", input$uploadSelDBtabs,ignore.case=TRUE)) || + length(grep("plotinit", input$uploadSelDBtabs,ignore.case=TRUE))) + keyCol = "Stand_ID" + if (length(grep("GroupAddFilesAndKeywords",input$uploadSelDBtabs, + ignore.case=TRUE))) keyCol = "Groups" + if (!is.null(keyCol)) + { + # the key column must not be null, if it is delete the rows. + try(dbExecute(dbGlb$dbIcon,paste0("delete from ", + input$uploadSelDBtabs," where ",keyCol," is null"))) + # update the stand selector list if it exists and if we are not doing groups + if (keyCol != "Groups") + { + dbGlb$sids = dbGetQuery(dbGlb$dbIcon,paste0("select distinct Stand_ID from ", + input$uploadSelDBtabs))[,1] + if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" + if (dbGlb$rowSelOn && length(dbGlb$sids)) + updateSelectInput(session=session, inputId="rowSelector", + choices = as.list(dbGlb$sids), selected=unique(indat[,"Stand_ID"])) else + output$stdSel <- mkStdSel(dbGlb) + + qry <- paste0("select _ROWID_,* from ",input$uploadSelDBtabs) + qry <- if (length(input$rowSelector)) + paste0(qry," where Stand_ID in (", + paste0("'",input$rowSelector,"'",collapse=","),");") else + paste0(qry,";") + dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) + rownames(dbGlb$tbl) = dbGlb$tbl$rowid + for (col in 2:ncol(dbGlb$tbl)) dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) + if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else + { + dbGlb$tbl$Delete = FALSE + dbGlb$rows <- c(dbGlb$rows[1], + min(nrow(dbGlb$tbl),dbGlb$rows[2])) + output$tbl <- renderRHandsontable(rhandsontable( + dbGlb$tbl[dbGlb$rows[1]:dbGlb$rows[2], + union(c("Delete"),input$selectdbvars),drop=FALSE], + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + } + } + } + session$sendCustomMessage(type = "resetFileInputHandler","uploadStdTree") + initNewInputDB(session,output,dbGlb) + }) + }) + ## delCurClimData + observe({ + if (input$delCurClimData) + { + dbExecute(dbGlb$dbIcon,'drop table if exists "FVS_ClimAttrs"') + output$uploadClimActionMsg = renderText(HTML("FVSClimAttrs table deleted if it existed.")) + } + }) + ## ClimateMsgs + observe({ + if (input$topPan == "Manage Projects" && input$inputDBPan == "Upload Climate-FVS data") + { + exTabs=dbListTables(dbGlb$dbIcon) + if ("FVS_ClimAttrs" %in% exTabs) + { + nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") + nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") + output$uploadClimActionMsg = renderText(HTML(paste0("Existing FVSClimAttrs data contains ", + nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) + } else output$uploadClimActionMsg = renderText(HTML(paste0("There is no existing FVSClimAttrs data."))) + } + }) + ## climateFVSUpload + observe({ + if (is.null(input$climateFVSUpload)) return() + progress <- shiny::Progress$new(session,min=1,max=10) + progress$set(message = "Loading data set",value = 2) + climAtt="FVSClimAttrs.csv" + curdir=getwd() + setwd(dirname(input$climateFVSUpload$datapath)) + if (input$climateFVSUpload$type == "application/zip") + try(unzip(input$climateFVSUpload$datapath, files = climAtt)) else + file.copy(input$climateFVSUpload$datapath,climAtt, + overwrite = TRUE) + if (!file.exists(climAtt)) + { +cat ("no FVSClimAttrs.csv file\n") + output$uploadClimActionMsg = renderText("FVSClimAttrs.csv not found.") + progress$set(message = "FVSClimAttrs.csv not found", value = 6) + Sys.sleep (2) + session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") + progress$close() + setwd(curdir) + unlink(input$climateFVSUpload$datapath) + return() + } +cat ("processing FVSClimAttrs.csv\n") + progress$set(message = "Loading data set (big files take a while)",value = 2) + climd = read.csv(climAtt,nrows=1) + climd = read.csv(climAtt,colClasses=c(rep("character",2), + "integer",rep("numeric",ncol(climd)-3)),as.is=TRUE) + unlink(climAtt) + unlink(input$climateFVSUpload$datapath) + setwd(curdir) + if (names(climd)[2] != "Scenario") + { + output$uploadClimActionMsg = renderText(HTML("FVSClimAttrs.csv does not contain expected column names.")) + progress$set(message = "FVSClimAttrs.csv not as expected", value = 6) + Sys.sleep (2) + session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") + progress$close() + rm(climd) + return() + } + names(climd)[1]="Stand_ID" + cdnames=colnames(climd) + periods=grep(".",cdnames,fixed=TRUE) + if (length(periods)) + { + message = paste0("Illegal period(s) in column name(s): ", + paste0(cdnames[periods],collapse=",")) + progress$set(message,value = 4) + Sys.sleep (.5) + progress$close() + output$uploadClimActionMsg = renderText(HTML(paste0("",message,". Data not loaded."))) + rm(climd) + return() + } + climTab <- myListTables(dbGlb$dbIcon) + if (!("FVS_ClimAttrs" %in% climTab)) + { +cat ("no current FVS_ClimAttrs\n") + progress$set(message = "Building FVS_ClimAttrs table",value = 4) + dbWriteTable(dbGlb$dbIcon,"FVS_ClimAttrs",climd) + rm (climd) + progress$set(message = "Creating FVS_ClimAttrs index",value = 6) + dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') + dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") + nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") + nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") + output$uploadClimActionMsg = renderText(HTML(paste0("FVSClimAttrs data contains ", + nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) + progress$set(message = "Done", value = 9) + Sys.sleep (.5) + progress$close() + return() + } + progress$set(message = "Building temporary FVS_ClimAttrs table",value = 4) + dbWriteTable(dbGlb$dbIcon,"temp.FVS_ClimAttrs",climd,overwrite=TRUE) + rm (climd) + progress$set(message = "Query distinct stands and scenarios",value = 5) + distinct = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID,Scenario from 'temp.FVS_ClimAttrs'") + progress$set(message = "Cleaning previous climate data as needed",value = 6) + dbBegin(dbGlb$dbIcon) + results = apply(distinct,1,function (x,dbIcon) + { + dbExecute(dbIcon,paste0('delete from FVS_ClimAttrs where Stand_ID = "', + x[1],'" and Scenario = "',x[2],'"')) + }, dbGlb$dbIcon) + dbCommit(dbGlb$dbIcon) + dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') + # get the table: + progress$set(message = "Inserting new data",value = 8) + oldAttrs = dbGetQuery(dbGlb$dbIcon,"select * from FVS_ClimAttrs limit 1") + if (nrow(oldAttrs) == 0) + { +cat ("simple copy from new, all rows were deleted\n") + dbExecute(dbGlb$dbIcon,"drop table FVS_ClimAttrs") + dbExecute(dbGlb$dbIcon,"create table 'FVS_ClimAttrs' as select * from 'temp.FVS_ClimAttrs'") + } else { + newAttrs = dbGetQuery(dbGlb$dbIcon,"select * from 'temp.FVS_ClimAttrs' limit 1") + if (!identical(colnames(oldAttrs),colnames(newAttrs))) + { +cat ("need to match columns, cols are not identical\n") + oldAttrs=colnames(oldAttrs)[-(1:3)] + newAttrs=colnames(newAttrs) + ssid = newAttrs[1:3] + newAttrs = newAttrs[-(1:3)] + oldsp=unlist(lapply(oldAttrs,function (x) if (toupper(x) == x) x else NULL)) + newsp=unlist(lapply(newAttrs,function (x) if (toupper(x) == x) x else NULL)) + bothsp = union(oldsp,newsp) + oldot=setdiff(oldAttrs,bothsp) + newot=setdiff(newAttrs,bothsp) + bothot = union(oldot,newot) + newall = c(bothsp,bothot) + oldmiss= setdiff(newall,oldAttrs) + newmiss= setdiff(newall,newAttrs) + newall = c(ssid,newall) + selnew = paste0(newall,collapse=",") +cat ("length(newmiss)=",length(newmiss)," selnew=",selnew,"\n") + if (length(newmiss) > 0) + { + dbBegin(dbGlb$dbIcon) + for (mis in newmiss) dbExecute(dbGlb$dbIcon, + paste0('alter table "temp.FVS_ClimAttrs" add "',mis,'" real')) + dbCommit(dbGlb$dbIcon) + } +cat ("length(oldmiss)=",length(oldmiss),"\n") + if (length(oldmiss) > 0) + { + dbBegin(dbGlb$dbIcon) + for (mis in oldmiss) dbExecute(dbGlb$dbIcon, + paste0('alter table FVS_ClimAttrs add "',mis,'" real')) + dbCommit(dbGlb$dbIcon) + } + } + attrs = colnames(dbGetQuery(dbGlb$dbIcon,"select * from 'FVS_ClimAttrs' limit 1")) + sel = paste0(attrs,collapse=",") + qry=paste0("insert into FVS_ClimAttrs (",sel,") select ",sel," from 'temp.FVS_ClimAttrs'") +cat("insert qry=",qry,"\n") + dbExecute(dbGlb$dbIcon,qry) + } + dbExecute(dbGlb$dbIcon,'drop table "temp.FVS_ClimAttrs"') + progress$set(message = "Recreating FVS_ClimAttrs index",value = 9) + dbExecute(dbGlb$dbIcon,'drop index if exists StdScnIndex') + dbExecute(dbGlb$dbIcon,"create index StdScnIndex on FVS_ClimAttrs (Stand_ID, Scenario);") + nstds = dbGetQuery(dbGlb$dbIcon,"select distinct Stand_ID from 'FVS_ClimAttrs'") + nsenc = dbGetQuery(dbGlb$dbIcon,"select distinct Scenario from 'FVS_ClimAttrs'") + output$uploadClimActionMsg = renderText(HTML(paste0("FVSClimAttrs data contains ", + nrow(nstds)," stands and ",nrow(nsenc)," scenarios"))) + progress$set(message = "Done", value = 10) + Sys.sleep (2) + session$sendCustomMessage(type = "resetFileInputHandler","climateFVSUpload") + progress$close() + }) + + ## View and edit existing tables + observe({ + if(input$inputDBPan == "View and edit existing tables" && input$topPan == "Manage Projects") + { +cat ("dataEditor View and edit existing tables\n") + tbs <- myListTables(dbGlb$dbIcon) + dbGlb$tbsCTypes <- lapply(tbs,function(x,dbIcon) + { + tb <- dbGetQuery(dbIcon,paste0("PRAGMA table_info('",x,"')")) + tbtypes = toupper(tb[,"type"]) + res = vector("logical",length(tbtypes)) + res[grep ("INT",tbtypes)] = TRUE + res[grep ("FLOAT",tbtypes)] = TRUE + res[grep ("REAL",tbtypes)] = TRUE + names(res) = tb[,"name"] + res[] = !res + }, dbGlb$dbIcon) + names(dbGlb$tbsCTypes) = tbs + idx <- grep ("StandInit",tbs,ignore.case=TRUE) + if (length(idx) == 0) idx=1 + updateSelectInput(session=session, inputId="editSelDBtabs", choices=tbs, + selected=tbs[idx]) + } + }) + + ## editSelDBtabs + observe({ +cat ("editSelDBtabs, input$editSelDBtabs=",input$editSelDBtabs, + " input$mode=",input$mode,"\n") + if (length(input$editSelDBtabs)) + { + dbGlb$tblName <- input$editSelDBtabs + fixEmptyTable(dbGlb) + msg=checkMinColumnDefs(dbGlb$dbIcon) +cat ("msg=",msg,"\n") + dbGlb$tbl <- NULL + dbGlb$tblCols <- names(dbGlb$tbsCTypes[[dbGlb$tblName]]) + if (length(grep("Stand_ID",dbGlb$tblCols,ignore.case=TRUE))) + { + rtn = try(dbGetQuery(dbGlb$dbIcon, + paste0("select distinct Stand_ID from '",dbGlb$tblName,"'"))) + if (class(rtn)=="try-error") + { +cat ("stand_ID query error.\n") + return() + } else dbGlb$sids = rtn[,1] + if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" + if (length(dbGlb$sids) > 0) + { + if (dbGlb$rowSelOn) updateSelectInput(session=session, + inputId="rowSelector",choices = dbGlb$sids) else + output$stdSel <- mkStdSel(dbGlb) + } + } else { + dbGlb$sids <- NULL + output$stdSel <- renderUI(NULL) + dbGlb$rowSelOn <- FALSE + } + updateSelectInput(session=session, inputId="editSelDBvars", + choices=as.list(dbGlb$tblCols),selected=dbGlb$tblCols) + html=NULL + xlsxFile=system.file("extdata", "databaseDescription.xlsx", package="fvsOL") + tabs = try(read.xlsx(xlsxFile=xlsxFile,sheet="InputTableDescriptions")) + if (class(tabs) != "try-error") + { + row = charmatch(toupper(input$editSelDBtabs),toupper(tabs[,1])) + if (!is.na(row)) + { + tab = tabs[row,1] + html = paste0("",tab," ",tabs[row,2]) + mhtml = xlsx2html(tab,xlsxfile=xlsxFile) + if (!is.null(mhtml)) html = paste0(html,mhtml) + } + } + output$inputTabDesc <- renderUI(HTML(html)) + } +cat ("editSelDBtabs returns\n") + }) + + ## editSelDBvars + observe({ + if (length(input$editSelDBvars)) + { +cat ("editSelDBvars, input$editSelDBvars=",input$editSelDBvars," mode=",input$mode,"\n") + ndr = suppressWarnings(as.numeric(input$disprows)) + if (is.na(ndr) || is.nan(ndr) || ndr < 1 || ndr > 500) ndr = 20 + dbGlb$disprows <- ndr + switch(input$mode, + "New rows"= + { + dbGlb$rows <- NULL + tbl <- as.data.frame(matrix("",ncol=length(input$editSelDBvars), + nrow=dbGlb$disprows)) + colnames(tbl) <- input$editSelDBvars + output$tbl <- renderRHandsontable(rhandsontable(tbl, + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE,width="100%")) + output$stdSel <- output$navRows <- renderUI(NULL) + dbGlb$rowSelOn <- dbGlb$navsOn <- FALSE + }, + Edit = + { + qry <- paste0("select _ROWID_,* from '",dbGlb$tblName,"'") + qry <- if (length(intersect("stand_id",tolower(dbGlb$tblCols))) && + length(input$rowSelector)) + paste0(qry," where Stand_ID in (", + paste0("'",input$rowSelector,"'",collapse=","),");") else + paste0(qry,";") + dbGlb$tbl <- suppressWarnings(dbGetQuery(dbGlb$dbIcon,qry)) + lnames = tolower(colnames(dbGlb$tbl)) + stdSearch = trim(input$editStandSearch) + if (nchar(stdSearch)>0) + { + keep = try(grep (stdSearch,dbGlb$tbl[,charmatch("stand_id",lnames)])) + if (class(keep) != "try-error" && length(keep)) dbGlb$tbl = dbGlb$tbl[keep,] + } + rownames(dbGlb$tbl) = dbGlb$tbl$rowid + for (col in 2:ncol(dbGlb$tbl)) + if (! ("character" %in% class(dbGlb$tbl[[col]]))) + dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) + if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else + { + dbGlb$tbl$Delete = FALSE + dbGlb$rows <- c(1,min(nrow(dbGlb$tbl),dbGlb$disprows)) + output$tbl <- renderRHandsontable( + rhandsontable(dbGlb$tbl[1:min(nrow(dbGlb$tbl),dbGlb$disprows), + union(c("Delete"),input$editSelDBvars),drop=FALSE], + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + if (!dbGlb$navsOn) + { + dbGlb$navsOn <- TRUE + output$navRows <- renderUI(list( + actionButton("previousRows","<< previous rows"), + actionButton("nextRows","next rows >>"), + textOutput("rowRng",inline=TRUE))) + } + output$rowRng <- renderText(paste0(dbGlb$rows[1]," to ", + dbGlb$rows[2]," of ",nrow(dbGlb$tbl))) + if (!dbGlb$rowSelOn && length(dbGlb$sids)) + output$stdSel <- mkStdSel(dbGlb) + } + } + ) + } + }) + + ## nextRows + observe({ + if (length(input$nextRows) && input$nextRows > 0) + { + if (is.null(dbGlb$tbl)) return() + input$disprows + newBot <- min(dbGlb$rows[2]+dbGlb$disprows,nrow(dbGlb$tbl)) + newTop <- max(newBot-dbGlb$disprows-1,1) + dbGlb$rows <- c(newTop,newBot) + output$tbl <- renderRHandsontable(rhandsontable(dbGlb$tbl[newTop:newBot, + union(c("Delete"),isolate(input$editSelDBvars)), + drop=FALSE],readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + output$rowRng <- renderText(paste0(newTop," to ", + newBot," of ",nrow(dbGlb$tbl))) + } + }) + + ## previousRows + observe({ + if (length(input$previousRows) && input$previousRows > 0) + { + if (is.null(dbGlb$tbl)) return() + input$disprows + newTop <- max(dbGlb$rows[1]-dbGlb$disprows,1) + newBot <- min(newTop+dbGlb$disprows-1,nrow(dbGlb$tbl)) + dbGlb$rows <- c(newTop,newBot) + output$tbl <- renderRHandsontable(rhandsontable(dbGlb$tbl[newTop:newBot, + union(c("Delete"),isolate(input$editSelDBvars)), + drop=FALSE],readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + output$rowRng <- renderText(paste0(newTop," to ", + newBot," of ",nrow(dbGlb$tbl))) + } + }) + + # commitChanges + observe({ + if (input$commitChanges > 0) + { + isolate({ +cat ("commitChanges, mode=",input$mode,"len tbl=",length(input$tbl),"\n") + dd = lapply(input$tbl$params$data,function (jj) + lapply(jj,function(x) if (is.null(x)) NA else x)) + inputTbl = matrix(unlist(dd), + ncol=length(input$tbl$params$columns),byrow=TRUE) + inputTbl[inputTbl=="NA"] = NA + colnames(inputTbl) = unlist(input$tbl$params$colHeaders) + rownames(inputTbl) = unlist(input$tbl$params$rowHeaders) + switch(input$mode, + "New rows"= + { + inserts <- mkInserts(inputTbl,dbGlb$tblName, + dbGlb$tbsCTypes[[dbGlb$tblName]]) + if (length(inserts)) + { + dbBegin(dbGlb$dbIcon) + err = FALSE + for (ins in inserts) + { + res = try(dbExecute(dbGlb$dbIcon,ins)) + if (class(res) == "try-error") {err=TRUE; break} + } + if (err) + { + dbRollback(dbGlb$dbIcon) + output$actionMsg = renderText(paste0("Error processing: ",ins)) + return() + } else { + dbCommit(dbGlb$dbIcon) + output$actionMsg = renderText(paste0(length(inserts)," insert(s) processed.")) + } + tbl <- as.data.frame(matrix("", + ncol=length(input$editSelDBvars),nrow=dbGlb$disprows)) + colnames(tbl) <- input$editSelDBvars + output$tbl <- renderRHandsontable(rhandsontable(tbl, + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + } + }, + Edit = + { + err=FALSE + nrows = nrow(inputTbl) + nprocess = 0 + dbBegin(dbGlb$dbIcon) + if (nrows) for (rn in 1:nrows) + { + row = inputTbl[rn,] + id = rownames(inputTbl)[rn] + if (row["Delete"] == "TRUE") + { + qry = paste0("delete from ",dbGlb$tblName," where _ROWID_ = ", + id) +cat ("edit del, qry=",qry,"\n") + res = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(res) == "try-error") {err=TRUE; break} + nprocess = nprocess+1 + if (!is.null(dbGlb$sids)) dbGlb$sids = NULL + } else { + row = inputTbl[rn,] + if (length(row) < 2) next + row = row[-1] + row[is.na(row)] = "" + row[row == "NA"] = "" + org = subset(dbGlb$tbl,rowid == id) + org = as.character(org[,names(row),drop=TRUE]) + org[is.na(org)] = "" + org[org=="character(0)"] = "" + org[org == "NA"] = "" + names(org)=names(row) + neq = vector("logical",length(row)) + for (i in 1:length(row)) neq[i]=!identical(row[i],org[i]) + if (sum(neq) == 0) next + update = row[neq] + toquote = dbGlb$tbsCTypes[[dbGlb$tblName]][names(update)] + if (!is.null(dbGlb$sids) && + !is.na(toquote["Stand_ID"])) dbGlb$sids = NULL + if (any(toquote)) + { + for (toq in names(toquote[toquote])) + { + update[toq] = if (update[toq]=="") "NULL" else + paste0("'",gsub("'","''",update[toq]),"'") + } + } + update[update==""] = "NULL" + qry = paste0("update ",dbGlb$tblName," set ", + paste(paste0(names(update)," = ",update),collapse=", "), + " where _ROWID_ = ",id) +cat ("edit upd, qry=",qry,"\n") + res = try(dbExecute(dbGlb$dbIcon,qry)) + if (class(res) == "try-error") {err=TRUE; break} + nprocess = nprocess+1 + } + } + if (err) + { + dbRollback(dbGlb$dbIcon) + output$actionMsg = renderText(paste0("Error processing: ",qry)) + return() + } else { + dbCommit(dbGlb$dbIcon) + output$actionMsg = renderText(paste0(nprocess," change(s) processed.")) + } + fixEmptyTable(dbGlb) +cat ("after commit, is.null(dbGlb$sids)=",is.null(dbGlb$sids), + " dbGlb$tblName=",dbGlb$tblName, + " Stand_ID yes=",length(intersect("stand_id",tolower(dbGlb$tblCols))),"\n") + if (is.null(dbGlb$sids) && + length(intersect("stand_id",tolower(dbGlb$tblCols)))) + { + dbGlb$sids = dbGetQuery(dbGlb$dbIcon,paste0("select distinct Stand_ID from ", + dbGlb$tblName))[,1] + if (any(is.na(dbGlb$sids))) dbGlb$sids[is.na(dbGlb$sids)] = "" + if (dbGlb$rowSelOn && length(dbGlb$sids)) + updateSelectInput(session=session, inputId="rowSelector", + choices = dbGlb$sids) else + output$stdSel <- mkStdSel(dbGlb) + } + + qry <- paste0("select _ROWID_,* from ",dbGlb$tblName) + qry <- if (length(grep("stand_id",tolower(dbGlb$tblCols))) && + length(input$rowSelector)) + paste0(qry," where Stand_ID in (", + paste0("'",input$rowSelector,"'",collapse=","),");") else + paste0(qry,";") + dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) + rownames(dbGlb$tbl) = dbGlb$tbl$rowid + for (col in 2:ncol(dbGlb$tbl)) + if (class(dbGlb$tbl[[col]])[1] != "character") + dbGlb$tbl[[col]] = as.character(dbGlb$tbl[[col]]) + if (nrow(dbGlb$tbl) == 0) dbGlb$rows = NULL else + { + dbGlb$tbl$Delete = FALSE + dbGlb$rows <- c(dbGlb$rows[1], + min(nrow(dbGlb$tbl),dbGlb$rows[2])) + output$tbl <- renderRHandsontable(rhandsontable( + dbGlb$tbl[dbGlb$rows[1]:dbGlb$rows[2], + union(c("Delete"),input$editSelDBvars),drop=FALSE], + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + } + } + ) + }) + } + reloadStandSelection(session,input) + }) + + ## Remove all rows and commit + observe({ + if(input$clearTable > 0) + { + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "clearTableDlg", + message = "Are you sure you want to delete all rows from this database table?")) + } + }) + + observe({ + if(input$clearTableDlgBtn == 0) return() +cat ("clearTable, tbl=",dbGlb$tblName,"\n") + dbExecute(dbGlb$dbIcon,paste0("delete from ",dbGlb$tblName)) + dbGlb$navsOn <- FALSE + dbGlb$rowSelOn <- FALSE + dbGlb$sids <- NULL + output$stdSel <- renderUI(NULL) + tmp = as.data.frame(lapply(dbGlb$tbsCTypes[[dbGlb$tblName]], + function (x) vector(if (x) "character" else "numeric",1)), + stringsAsFactors=FALSE) + tmp[1,] = NA + dbWriteTable(dbGlb$dbIcon,dbGlb$tblName,tmp,overwrite=TRUE) + qry <- paste0("select _ROWID_,* from ",dbGlb$tblName) + dbGlb$tbl <- dbGetQuery(dbGlb$dbIcon,qry) + rownames(dbGlb$tbl) = dbGlb$tbl$rowid + dbGlb$tbl$Delete = FALSE + output$tbl <- renderRHandsontable(rhandsontable( + dbGlb$tbl[,union(c("Delete"),input$selectdbvars),drop=FALSE], + readOnly=FALSE,useTypes=TRUE,contextMenu=FALSE)) + output$rowRng <- renderText("1 to 1 of 1") + isolate(if (input$mode=="New rows") updateRadioButtons(session=session, + inputId="mode",selected="Edit")) + }) + + ## Upload Map data + observe({ + if(input$inputDBPan == "Upload Map data") + { +cat ("Map data hit.\n") + library(sf) + updateSelectInput(session=session, inputId="mapUpLayers", choices=list(), + selected=0) + output$mapActionMsg = renderText(" ") + } + }) + ## mapUpload + observe({ + if(is.null(input$mapUpload)) return() + { +cat ("mapUpload\n") + progress <- shiny::Progress$new(session,min=1,max=3) + if (file.exists(input$mapUpload$datapath)) + { + fileEnding = tolower(tools::file_ext(basename(input$mapUpload$datapath))) +cat ("mapUpload, filename=",input$mapUpload$datapath," ending=",fileEnding,"\n") + if (fileEnding != "zip") + { + output$mapActionMsg = renderText(paste0("Upload a .zip file")) + progress$close() + return() + } + mapDir = paste0(dirname(input$mapUpload$datapath),"/mapData") + unlink(mapDir,recursive=TRUE) + dir.create(mapDir) + file.copy(from=input$mapUpload$datapath,to=mapDir) + zipName = basename(input$mapUpload$datapath) + unlink(input$mapUpload$datapath) + progress$set(message = "Unzipping",value = 1) + curdir = getwd() + setwd(mapDir) + unzip(zipName) + unlink(zipName) + if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) + progress$set(message = "Getting layers",value = 2) + if (length(dir(mapDir)) > 1) mapDir = dirname(mapDir) + setwd(mapDir) + lyrs = try(sf::st_layers(dir(mapDir))) + setwd(curdir) +cat ("mapUpload, class(lyrs)=",class(lyrs),"\n") + if ("try-error" %in% class(lyrs) || length(lyrs$name)==0) + { + output$mapActionMsg = renderText("Can not find layers in data") + progress$close() + return() + } + lyrs = as.list(lyrs$name) + if (length(lyrs) > 1) + { + lyr = grep ("poly",names(lyrs),ignore.case=TRUE) + if (length(lyr) == 0 || any(is.na(lyr))) lyr = 1 + if (length(lyr) > 1) lyr = lyr[which.min(nchar(names(lyrs)[lyr]))] + lyr = names(lyrs)[lyr] + } else lyr = lyrs[1] + lyr = unlist(lyr) + updateSelectInput(session=session, inputId="mapUpLayers", choices=lyrs, + selected=lyr) + progress$close() + } + } + }) + ## mapUpLayers + observe({ + if (is.null(input$mapUpLayers)) return() + datadir = dirname(isolate(input$mapUpload$datapath)) + if (!dir.exists(datadir)) return() + curdir = getwd() + setwd(datadir) + datadir = dir() +cat ("input$mapUpLayers =",input$mapUpLayers,"\n") + if (length(dir(datadir)) == 1) setwd(datadir) + progress <- shiny::Progress$new(session,min=1,max=3) + progress$set(message = paste0("Loading map: ",datadir," Layer: ",input$mapUpLayers),value=2) + txtoutput = capture.output(dbGlb$spd <- try(st_read(dir(),input$mapUpLayers))) + setwd(curdir) + if ("try-error" %in% class(dbGlb$spd)) + { + output$mapActionMsg = renderText(paste0("Map read error: ",dbGlb$spd)) + progress$close() + setwd(curdir) + return() + } + txtoutput = paste0(txtoutput,collapse="\n") + output$mapActionMsg = renderText(txtoutput) + progress$set(message = txtoutput,value=3) + stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") + ids = try(dbGetQuery(dbGlb$dbIcon,paste0('select Stand_ID from ',stdInit))) +cat ("length(ids)=",length(ids),"\n") + choices = setdiff(names(dbGlb$spd),"geometry") + names(choices) = choices + if ("try-error" %in% class(ids) || nrow(ids) == 0) + { + selected = grep("ID",choices,ignore.case=TRUE)[1] + if (is.na(selected)) selected=0 + } else { + ids = unlist(ids) + names(ids) = NULL + cnts = NULL + for (col in choices) + cnts = c(cnts,length(na.omit(match(ids,dbGlb$spd[,col][[col]])))) + cnts = cnts/length(ids)*100 + choices = paste0(choices," ",format(cnts,digits=3),"%") + selected = choices[which.max(cnts)] + } +cat ("input$mapUpLayers, number of layers (choices)=",length(choices)," selected=",selected,"\n") + updateSelectInput(session=session, inputId="mapUpIDMatch", + choices=choices,selected=selected) + progress$close() + }) + + prepSpatialData = function(dbGlb) + { + if (!exists("spd",envir=dbGlb,inherit=FALSE)) return(NULL) + stdInit = getTableName(dbGlb$dbIcon,"FVS_StandInit") + ids1 = try(dbGetQuery(dbGlb$dbIcon,paste0('select distinct Stand_ID from ',stdInit))) + ids1 = if (class(ids1)=="try-error") list() else unlist(ids1) + names(ids1) = NULL + if ("FVS_Cases" %in% + dbGetQuery(dbGlb$dbOcon,"SELECT * FROM sqlite_master where type='table'")$name) + { + ids2 = try(dbGetQuery(dbGlb$dbOcon,'select distinct StandID from FVS_Cases;')) + ids2 = if ("try-error" %in% class(ids2)) list() else unlist(ids2) + names(ids2) = NULL + keep=union(ids1,ids2) + } else keep=ids1 + matID = unlist(strsplit(input$mapUpIDMatch," "))[1] + keep=na.omit(charmatch(keep,dbGlb$spd[,matID][[matID]])) + if (length(keep)) + { + SpatialData=dbGlb$spd[keep,] + attr(SpatialData,"MatchesStandID") = matID + output$mapActionMsg = renderText(paste0("Map saved for this project, StandID match=", + matID,", Number of objects kept=",nrow(SpatialData))) + } else { + SpatialData=NULL + output$mapActionMsg = renderText("No map or data to save.") + } + rm (spd,envir=dbGlb) + return(SpatialData) + } + ## mapUpSave + observe({ + if(input$mapUpSave > 0) + { + SpatialData=prepSpatialData(dbGlb) + if (!is.null(SpatialData)) + { + save (SpatialData,file="SpatialData.RData") + dbGlb$SpatialData = SpatialData + } + } + }) + ## mapUpAdd + observe({ + if(input$mapUpAdd > 0) + { + NewSpatialData=prepSpatialData(dbGlb) + if (!is.null(NewSpatialData)) + { + spatdat="SpatialData.RData" + if (file.exists(spatdat)) load(file=spatdat) + if (!exists("SpatialData")) SpatialData=NewSpatialData else + SpatialData = if (class(SpatialData)=="list") + append(after=0,NewSpatialData) else list(SpatialData,NewSpatialData) + save (SpatialData,file=spatdat) + dbGlb$SpatialData = SpatialData + } + } + }) + ## Import runs and other items + observe({ + if(input$toolsPan == "Import runs and other items") + { + choices = getProjectList(includeLocked=TRUE) + actprj <- grep(basename(getwd()),choices) # remove current project + if (length(actprj)) choices <- choices[-actprj] + updateSelectInput(session=session, inputId="impPrjSource", + choices=choices,selected=0) + output$selectedSourceMsg <- renderText( + paste0('

', + 'No source selected.')) + output$impPrjSourceMsg <- NULL + output$uploadRunsRdatMsg <- NULL + output$impRunsMsg <- NULL + output$impCustomCmpsMsg <- NULL + output$impGraphSettingMsg <- NULL + output$impCustomQueriesMsg <- NULL + output$impFVSDataMsg <- NULL + output$impSpatialDataMsg <- NULL + updateSelectInput(session=session, inputId="uploadRunsRdat",choices=list()) + updateSelectInput(session=session, inputId="impRuns",choices=list()) + updateSelectInput(session=session, inputId="impCustomCmps",choices=list()) + updateSelectInput(session=session, inputId="impGraphSettings",choices=list()) + updateSelectInput(session=session, inputId="impCustomQueries",choices=list()) + updateSelectInput(session=session, inputId="impFVSData",choices=list()) + updateSelectInput(session=session, inputId="impSpatialData",choices=list()) + } + }) + ## mkSrcMsgAndList + mkSrcMsgAndList <- function(db,nruns) + { + msg = paste0("File contains ",nruns," runs") + tbs=dbListTables(db) + itms=listTableNames(db) + itms=intersect(itms,c("GraphSettings","customCmps","customQueries")) + if (file.exists("SpatialData.RData")) itms=c(itms,"SpatialData") + if (file.exists("FVS_Data.db")) itms=c(itms,"FVS_Data") + if (length(itms)>0) msg=paste0(msg," plus: ",paste0(itms,collapse=", ")) + if (nruns > 0) itms=c(itms,"Runs") + rtn = list(itms,msg) + attr(rtn,"dir") = getwd() + for (itm in itms) + { + switch(itm, + "Runs" = { + updateSelectInput(session=session, inputId="impRuns", + choices=getFVSRuns(db)) + }, + "GraphSettings" = { + loadObject(db,"GraphSettings") + names=setdiff(names(GraphSettings),"None") + updateSelectInput(session=session, inputId="impGraphSettings", + choices=as.list(names)) + }, + "customCmps" = { + loadObject(db,"customCmps") + updateSelectInput(session=session, inputId="impCustomCmps", + choices=as.list(names(customCmps))) + }, + "customQueries" = { + loadObject(db,"customQueries") + updateSelectInput(session=session, inputId="impCustomQueries", + choices=as.list(names(customQueries))) + }) + } + zout = setdiff(c("Runs","GraphSettings","customCmps","customQueries"),itms) + for (itm in zout) + { + switch(itm, + "Runs" = updateSelectInput(session=session, inputId="impRuns",choices=list()), + "GraphSettings" = updateSelectInput(session=session, inputId="impGraphSettings",choices=list()), + "customCmps" = updateSelectInput(session=session, inputId="impCustomCmps",choices=list()), + "customQueries" = updateSelectInput(session=session, inputId="impCustomQueries",choices=list()) + ) + } + rtn + } + + ## Upload zip file. + observe({ + if (is.null(input$uploadRunsRdat)) return() + if (!length(grep("zip",input$uploadRunsRdat$type))) { + output$uploadRunsRdatMsg <- renderText("Uploaded file is not a .zip") + } else { + isolate({ + if (length(globals$importItems)) + { + if (attr(globals$importItems,"temp")) + unlink(attr(globals$importItems,"dir"),recursive = TRUE) + globals$importItems=list() + } + curdir = getwd() + tdir = dirname(input$uploadRunsRdat$datapath) + setwd(tdir) + tmpPrj = uuidgen() + dir.create(tmpPrj) + tmpPrj = file.path(getwd(),tmpPrj) + setwd(tmpPrj) + uz = try(unzip(input$uploadRunsRdat$datapath)) + if (class(uz)=="try-error") + { +cat("uploaded zip failed\n") + output$uploadRunsRdatMsg <- renderText("Uploaded file could not be unzipped.") + unlink(input$uploadRunsRdat$datapath) + unlink(tmpPrj,recursive=TRUE) + } else { + updateSelectInput(session=session, inputId="impPrjSource",selected=0) + nruns=mkFVSProjectDB() + db=connectFVSProjectDB() + ml = mkSrcMsgAndList(db,nruns) + dbDisconnect(db) + output$uploadRunsRdatMsg <- renderUI(HTML(ml[[2]])) + attr(ml,"temp") = TRUE # this directory can be deleted + output$selectedSourceMsg <- renderText( + paste0('

Source: ', + ml[[2]])) + globals$importItems = ml +cat("unload zip had ",length(uz),"items. ml[[2]]=",ml[[2]],"\n") + } + setwd(curdir) + }) + } + session$sendCustomMessage(type = "resetFileInputHandler","uploadRunsRdat") + }) + + ## impPrjSource + observe({ + if (is.null(input$impPrjSource)) return() + { + curdir = getwd() + setwd("../") + tmpPrj = file.path(getwd(),input$impPrjSource) + if (dir.exists(tmpPrj)) + { + setwd(tmpPrj) + db = connectFVSProjectDB() + nruns=mkFVSProjectDB() + ml = mkSrcMsgAndList(db,nruns) + ml[[2]] = gsub("File",paste("Project",input$impPrjSource),ml[[2]]) + dbDisconnect(db) + output$selectedSourceMsg <- renderText( + paste0('

Source: ', + ml[[2]])) + attr(ml,"temp") = FALSE # don't delete this source directory + globals$importItems = ml + } + setwd(curdir) + } + }) + + ## doImpRuns + observe({ + if (input$doImpRuns > 0) + {isolate({ + if (is.null(input$impRuns)) return() + prjDir=attr(globals$importItems,"dir") + pDB=connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(pDB)) + curRuns = names(getFVSRuns(dbGlb$prjDB)) + theRun = loadFVSRun(pDB,input$impRuns) + if (is.null(theRun)) + { + output$impRunsMsg = renderText("The run could not be loaded.") + return() + } + curTitle = theRun$title + theRun$title = mkNameUnique(curTitle,names(getFVSRuns(dbGlb$prjDB))) + theRun$uuid = uuidgen() + storeFVSRun(dbGlb$prjDB,theRun) + globals$FVS_Runs = getFVSRuns(dbGlb$prjDB) + output$impRunsMsg = renderText(paste0('Run "',curTitle,'" imported and ', + ' is named "',theRun$title,'" in your current project.')) + updateSelectInput(session=session, inputId="runSel", + choices=globals$FVS_Runs,selected=globals$fvsRun$uuid) + })} + }) + + ## doImpCustomCmps + observe({ + if (input$doImpCustomCmps > 0) + {isolate({ + if (is.null(input$impCustomCmps)) return() + prjDir=attr(globals$importItems,"dir") + pDB=connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(pDB)) + loadObject(pDB,"customCmps",asName="source") + loadObject(dbGlb$prjDB,"customCmps") + curTitle = input$impCustomCmps + if(exists("customCmps")){ + newtitle = mkNameUnique(curTitle,names(customCmps)) + } else{ + customCmps = list() + newtitle = mkNameUnique(curTitle,customCmps) + } + customCmps[newtitle] = source[curTitle] + storeOrUpdateObject(dbGlb$prjDB,customCmps) + output$impCustomCmpsMsg = renderText(paste0('Component "',curTitle,'" imported and ', + ' is named "',newtitle,'" in your current project.')) + globals$customCmps = customCmps + updateSelectInput(session=session,inputId="kcpSel",choices=as.list(names(customCmps)), + selected=names(customCmps)[1]) + })} + }) + + ## doImpGraphSettings + observe({ + if (input$doImpGraphSettings > 0) + {isolate({ + if (is.null(input$impGraphSettings)) return() + prjDir=attr(globals$importItems,"dir") + pDB=connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(pDB)) + loadObject(pDB,"GraphSettings",asName="source") + loadObject(dbGlb$prjDB,"GraphSettings") + curTitle = input$impGraphSettings + if(exists("GraphSettings")){ + newtitle = mkNameUnique(curTitle,names(GraphSettings)) + } else{ + GraphSettings = list() + newtitle = mkNameUnique(curTitle,GraphSettings) + } + GraphSettings[newtitle] = source[curTitle] + storeOrUpdateObject(dbGlb$prjDB,GraphSettings) + output$impGraphSettingsMsg = renderText(paste0('Graph setting "',curTitle,'" imported and ', + ' is named "',newtitle,'" in your current project.')) + updateSelectInput(session=session,inputId="OPsettings",choices=as.list(names(GraphSettings)), + selected=names(GraphSettings)[1]) + })} + }) + + ## doImpCustomQueries + observe({ + if (input$doImpCustomQueries > 0) + {isolate({ + if (is.null(input$impCustomQueries)) return() + prjDir=attr(globals$importItems,"dir") + pDB=connectFVSProjectDB(prjDir) + on.exit(dbDisconnect(pDB)) + loadObject(pDB,"customQueries",asName="source") + loadObject(dbGlb$prjDB,"customQueries") + curTitle = input$impCustomQueries + if(exists("customQueries")){ + newtitle = mkNameUnique(curTitle,names(customQueries)) + } else{ + customQueries = list() + newtitle = mkNameUnique(curTitle,customQueries) + } + globals$customQueries[newtitle]= source[curTitle] + customQueries[newtitle] = source[curTitle] + storeOrUpdateObject(dbGlb$prjDB,customQueries) + output$impCustomQueriesMsg = renderText(paste0('Query "',curTitle,'" imported and ', + ' is named "',newtitle,'" in your current project.')) + updateSelectInput(session=session,inputId="sqlSel",choices=as.list(names(customQueries)), + selected="") + })} + }) + + ## impFVS_Data + observe({ + if (input$impFVS_Data > 0) + { +cat(" input$impFVS_Data=",input$impFVS_Data,"\n") + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "impFVS_DataDlg", + message = "This action overwrites your current FVS_Data.db")) + } + }) + observe({ + if (input$impFVS_DataDlgBtn == 0) return() + isolate({ +cat(" input$impFVS_DataDlgBtn=",input$impFVS_DataDlgBtn,"\n") + needfile = file.path(attr(globals$importItems,"dir"),"FVS_Data.db") + if (length(needfile) && nchar(needfile) && file.exists(needfile)) + { + file.copy(from=needfile,to="FVS_Data.db",overwrite=TRUE) + output$impFVS_DataMsg = renderText("FVS_Data.db has been imported.") + } else output$impFVS_DataMsg = renderText("Source FVS_Data.db was NOT found.") + }) + }) + ## impSpatialData + observe({ + if(input$impSpatialData > 0) + { +cat(" input$impSpatialData=",input$impSpatialData,"\n") + session$sendCustomMessage(type = "dialogContentUpdate", + message = list(id = "impSpatialDataDlg", + message = "This action adds this SpatialData your current SpatialData")) + } + }) + observe({ + if (input$impSpatialDataDlgBtn == 0) return() + isolate({ +cat(" input$impSpatialDataDlgBtn=",input$impSpatialDataDlgBtn,"\n") + needfile = file.path(attr(globals$importItems,"dir"),"SpatialData.RData") + if (length(needfile) && nchar(needfile) && file.exists(needfile)) + { + spatdat = "SpatialData.RData" + if (!exists("SpatialData",envir=dbGlb,inherit=FALSE) && file.exists(spatdat)) + { + load(spatdat,envir=dbGlb) + if (class(dbGlb$SpatialData)=="SpatialPolygonsDataFrame") + dbGlb$SpatialData=list(d=dbGlb$SpatialData) + load(needfile) #loads into the current frame (local environment). + dbGlb$SpatialData <- append(dbGlb$SpatialData,SpatialData) + save(SpatialData,envir=dbGlb,file="SpatialData.RData") + } else file.copy(from=needfile,to="SpatialData.RData",overwrite=TRUE) + output$impSpatialDataMsg = renderText("SpatialData.RData has been added to this project's spatial data.") + } else output$impSpatialDataMsg = renderText("Source SpatialData.RData was not found.") + }) + }) + + # runScript selection + observe(if (length(input$runScript)) customRunOps()) + ## customRunOps + customRunOps <- function () + { + isolate({ + if (length(input$runScript) == 0) + { +cat ("in customRunOps runScript is empty\n") + return() + } +cat ("in customRunOps runScript: ",input$runScript,"\n") + globals$fvsRun$runScript = input$runScript + output$uiCustomRunOps = renderUI(NULL) + if (input$runScript != "fvsRun") + { + fn=paste0("customRun_",globals$fvsRun$runScript,".R") + if (!file.exists(fn)) fn=system.file("extdata", fn, package="fvsOL") + if (!file.exists(fn)) return() + 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() + output$uiCustomRunOps = renderUI(uiF(globals$fvsRun)) + } else { + globals$fvsRun$uiCustomRunOps = list() + } +if (length(globals$fvsRun$uiCustomRunOps)) lapply(names(globals$fvsRun$uiCustomRunOps), function (x,y) +cat ("globals$fvsRun$uiCustomRunOps$",x,"=",y[[x]],"\n",sep=""),globals$fvsRun$uiCustomRunOps) else +cat ("globals$fvsRun$uiCustomRunOps is empty\n") + }) + } + ## updateProjectSelections + updateProjectSelections <- function () + { + selChoices = getProjectList() + nsel = charmatch(basename(getwd()),selChoices) + if(length(globals$lastNewPrj)) nsel = charmatch(globals$lastNewPrj,selChoices) + sel = if (is.null(nsel)) NULL else selChoices[[nsel]] + updateSelectInput(session=session, inputId="PrjSelect", + choices=selChoices,selected=sel) + ### Block the ability to delete Project_1 on windows + if(.Platform$OS.type == "windows") + { + prj1 = charmatch("Project_1",selChoices) + if (!is.na(prj1)) selChoices=selChoices[-prj1] + actprj <- grep(basename(getwd()),selChoices) + if (length(actprj)) selChoices <- selChoices[-actprj] + } + updateSelectInput(session=session, inputId="PrjDelSelect",choices=selChoices, + selected=0) + backups = dir (pattern="ProjectBackup") + if (length(backups)) + { + backups = sort(backups,decreasing=TRUE) + names(backups) = backups + } else backups=list() + updateSelectInput(session=session, inputId="pickBackup", + choices = backups, selected=NULL) + } + + ## Projects hit + observe({ + if (input$topPan == "Manage Projects" && input$toolsPan == "Manage project") + { +cat ("Manage project hit\n") + updateProjectSelections() + } + + }) + + ## Make New Project (PrjNew) + observe({ + if (length(input$PrjNew)==0 || input$PrjNew == 0) return() + isolate({ +cat ("Make new project, input$PrjNewTitle=",input$PrjNewTitle,"\n") + if (nchar(input$PrjNewTitle)==0) return() + prjid = if (file.exists("projectId.txt")) scan("projectId.txt", + what="character",sep="\n",quiet=TRUE) else NUL + fbin = Sys.readlink(fvsBin) #will be na if file does not exist, "" if not symbolic link. + if (is.na(fbin)) return() + curdir = getwd() + setwd("../") + newTitle = input$PrjNewTitle + newTitle=mkNameUnique(newTitle,setOfNames=names(getProjectList(includeLocked=TRUE))) + ntit=paste0("title= ",newTitle) + fn = if (isLocal()) + { + basedir = basename(curdir) + newTitle <- mkFileNameUnique(newTitle) + newTitle + } else uuidgen() + dir.create(fn) + setwd(fn) + newdir=getwd() + if (dirname(fvsBin) == ".") #fvsBin points to an entry in the current dir. + { + if (nchar(fbin) && .Platform$OS.type=="unix") file.symlink(fbin, "FVSbin") else + file.copy(paste0(normalizePath(curdir),"/FVSbin"), getwd(), recursive = TRUE, + copy.mode = TRUE, copy.date = TRUE) + } + idrow = grep("title=",prjid) + if (length(idrow)==0) prjid=c(prjid,ntit) else prjid[idrow]=ntit +cat ("new project dir=",getwd()," prjid=",prjid,"\n") + write(file="projectId.txt",prjid) + updateTextInput(session=session, inputId="PrjNewTitle",value="") + setwd(curdir) + file.copy(from="app.R",to=paste0(normalizePath(newdir),"/app.R")) + globals$lastNewPrj=newTitle + updateProjectSelections() + }) + }) + ## PrjOpen + observe(if (length(input$PrjOpen) && input$PrjOpen > 0) + { + isolate({ + newPrj=paste0("../",input$PrjSelect) + plk = file.exists(paste0(newPrj,"/projectIsLocked.txt")) +cat("PrjOpen to=",newPrj," dir.exists(newPrj)=",dir.exists(newPrj), +" locked=",plk,"\n") + if (plk) {updateProjectSelections();return()} + if (dir.exists(newPrj)) + { + if (isLocal()) + { + rscript = if (exists("RscriptLocation")) RscriptLocation else + { + exefile=normalizePath(commandArgs(trailingOnly=FALSE)[1]) + bin = if(.Platform$OS.type == "windows") + regexpr("\\\\bin\\\\",exefile) else regexpr("/bin/",exefile) + bin = substr(exefile,1,bin+attr(bin,"match.length")-2) + if(.Platform$OS.type == "windows") + file.path(bin,"Rscript.exe") else file.path(bin,"Rscript") + } + rscript=gsub("\\\\","/",rscript) + defs=paste0("RscriptLocation='",rscript,"';") + if (exists("mdbToolsDir")) defs=paste0(defs,"mdbToolsDir='",mdbToolsDir,"';") + if (exists("sqlite3exe")) defs=paste0(defs,"sqlite3exe='",sqlite3exe,"';") +cat(".libPaths=",unlist(.libPaths()),"\n") + if (exists("RscriptLocation")) { + Rlib2Use <- paste0(dirname(dirname(dirname(RscriptLocation))),"/library") + defs=paste0(defs,".libPaths('",Rlib2Use,"');") + } + cmd = paste0("$",rscript,"$ --vanilla -e $",defs,"require(fvsOL)", + ";fvsOL(prjDir='",newPrj,"',fvsBin='",fvsBin,"');quit()$") + cmd = gsub('$','\"',cmd,fixed=TRUE) + if (.Platform$OS.type == "unix") cmd = paste0("nohup ",cmd," >> /dev/null") + rtn=try(system (cmd,wait=FALSE)) +cat ("cmd for launch project=",cmd,"\nrtn=",rtn,"\n") + } else { + url = paste0(session$clientData$url_protocol,"//", + session$clientData$url_hostname,"/FVSwork/",input$PrjSelect) +cat ("launch url:",url,"\n") + session$sendCustomMessage(type = "openURL",url) + } + Sys.sleep(5) + updateProjectSelections() + } + }) + }) + + ## Full run/Just groups + observe({ + mkSimCnts(globals$fvsRun,justGrps=input$simContType=="Just groups") + updateSelectInput(session=session, inputId="simCont", + choices=globals$fvsRun$simcnts, selected=globals$fvsRun$selsim) + }) + + ## saveRun + saveRun <- function(input,session) + { + isolate({ + runName = trim(input$title) + if (nchar(input$title) == 0) runName <- nextRunName(names(globals$FVS_Runs)) + me=match(globals$fvsRun$uuid,globals$FVS_Runs) +cat ("saveRun, length(me)=",length(me)," uuid=",globals$fvsRun$uuid," class(globals$fvsRun)=",class(globals$fvsRun),"\n") + if (length(me)==0 || is.na(me)) return() else runNames=names(globals$FVS_Runs)[-me] + runName=mkNameUnique(runName,runNames) + if (runName != input$title) updateTextInput(session=session, inputId="title", + value=runName) + globals$fvsRun$title = runName +cat ("in saveRun, globals$fvsRun$defMgmtID=",globals$fvsRun$defMgmtID," input$defMgmtID=",input$defMgmtID,"\n") + globals$fvsRun$defMgmtID = input$defMgmtID + globals$fvsRun$runScript = if (length(input$runScript)) input$runScript else "fvsRun" + if (globals$fvsRun$runScript == "fvsRun") globals$fvsRun$uiCustomRunOps = list() else + { + for (item in names(globals$fvsRun$uiCustomRunOps)) + globals$fvsRun$uiCustomRunOps[[item]] = input[[item]] + } +cat ("saveRun class(globals$fvsRun)=",class(globals$fvsRun),"\n") + # sometimes the class fvsRun is assigned to package ".GlobalEnv" and it + # should be the for this package. + if (attr(class(globals$fvsRun),"package")==".GlobalEnv") + attr(class(globals$fvsRun),"package") = "fvsOL" + storeFVSRun(dbGlb$prjDB,globals$fvsRun) + globals$FVS_Runs=getFVSRuns(dbGlb$prjDB) +cat ("saveRun, input$inVars=",input$inVars,"\n") + globals$lastRunVar = globals$activeVariants[1] +cat ("leaving saveRun, globals$lastRunVar=",globals$lastRunVar,"\n") + }) + } +} + diff --git a/fvsOL/R/svsTree.R b/fvsOL/R/svsTree.R index b80a8f6..f1664b1 100644 --- a/fvsOL/R/svsTree.R +++ b/fvsOL/R/svsTree.R @@ -1,423 +1,423 @@ -svsTree <- function(tree,treeform) -{ - # data in the treeform (inforation form Bob's documentation): - # Sp Species - # TrCl tree class - # CrCl crown class - # PlFrm plant form or plant type, Bits 1-4 as follows: - # 0=single leader form, 1=multiple leader with strong central, - # 2=multiple leader with weak central, 3=no central. - # Bits 5-8: foliage damage, bits 9-12 branch damage. - # Foliage damage codes are: 0=no damage, 1=top 1/3, 2=top 2/3, - # 3=bot 1/3, 4=bot 2/3, 5=entire crown. - # Branch damage information: 0=no damage, 1=top 1/3 dead branches, - # 2=top 2/3, 3=bot 1/3, 4=bot 2/3, 5=entire crown - # Nbrchs for single leader forms, number of branches, for multi leader - # this is the number of heavy branches - # NWorls for single leader forms, number of whorls, for multi leader - # it is the number of leaves - # BrBase Location of the branching point relative to base of live crown - # (used on multiple leader trees). - # BrAngle Angular increment between branches and leaf structures - # LoX the portion of the crown width for the lower radius - # LoY the portion of the crown length for the lower radius - # HiX the portion of the crown width for the upper radius - # HiY the poriton of the crown length for the upper radius - # BaseUp branch insertation angle for branches near the bottom - # TopUp branch insertation angle for branches near the top - # StemC Stem color - # BrCol Branch color - # FlCol1 Foliage color for 75% - # FlCol2 Foliage color for 25% - # SampHt Ht of sample trees used by SVS tree designer - # SampCR Crown radio ... ditto - # SampCDia Crown diameter ... ditto - # SampScale Object scaling, not used here - - # CURRENT TREE CLASSES: from FVS svout.f - # 0 - GREEN TREE (STANDING OR RECENTLY CUT TREE) - # 90 - NEW WESTWIDE PINE BEETLE KILL, OFF-GREEN - # 91 - 1 YEAR OLD WWPB KILL, RED TREE - # 92 - 2 YEAR OLD WWPB KILL, FADING TREE - # 94 - SNAG - # 95 - RED AND GREEN TREE (BURNT 99) NOT USED YET - # 96 - GREY SNAG (BURNT 94) - OLDER BURNED TREE - # 97 - GREY TREE (BURNT 98 OR 99) - RECENTLY BURNED TREE - # 98 - RED TREE (RECENTLY DEAD STANDING OR DOWN TREE) - # 99 - WILD CARD, WE DON'T USE THIS CODE...IT IS A GREEN - # TREE (STANDING OR RECENTLY CUT TREE) - - colors=c(rgb(210, 66, 14, maxColorValue=255), - rgb(163, 117, 0, maxColorValue=255), - rgb(119, 42, 24, maxColorValue=255), - rgb( 98, 98, 98, maxColorValue=255), - rgb(112, 153, 0, maxColorValue=255), - rgb( 0, 86, 26, maxColorValue=255), - rgb( 20, 66, 42, maxColorValue=255), - rgb( 0, 76, 0, maxColorValue=255), - rgb( 62, 45, 45, maxColorValue=255), - rgb( 98, 18, 0, maxColorValue=255), - rgb( 88, 55, 57, maxColorValue=255), - rgb( 52, 149, 64, maxColorValue=255), - rgb( 0, 58, 44, maxColorValue=255), - rgb( 90, 64, 38, maxColorValue=255), - rgb(115, 82, 0, maxColorValue=255), - rgb(137, 137, 0, maxColorValue=255), - rgb( 69, 72, 72, maxColorValue=255), - rgb( 86, 64, 16, maxColorValue=255), - rgb( 0, 107, 0, maxColorValue=255), - rgb( 76, 46, 0, maxColorValue=255)) - - if (any(is.na(tree))) return(NULL) - if (tree$DBH == 0) return(NULL) - tree$DBH = tree$DBH/12 - CL = tree$Ht*tree$Cr1 - fallangle=tree$Fang - HCB = tree$Ht*(1-tree$Cr1) - ttcl = if (tree$TrCl == 0) 99 else tree$TrCl - tr = subset(treeform,Sp == tree$sp & TrCl == ttcl) - tr = as.list(tr[1,]) - tltslp = diff(c(tr$BaseUp,tr$TopUp)) - tree$crowncolor= c(colors[tr$FlCol1+1],colors[tr$FlCol2+1]) - tree$crowncolor= tree$crowncolor[!duplicated(tree$crowncolor)] - tree$stemcolor = colors[tr$StemC+1] - - if (tree$Cr1 && tree$Crd1 && HCB && CL) - { - branchList = list() - # single leader - if (tr$PlFrm == 0) - { - # single leader, then ignore the nwhorl and nbran data from treeform - nwhorl = tr$Nwhorls - nbran = tr$Nbrchs # total number - # limit the number of branches to 4 per foot of crown length - if (nbran > 4*CL) nbran = 4*CL - if (nwhorl == 0) nwhorl = nbran - nwhorl = ceiling(nwhorl) - if (nwhorl > 0) - { - nbran = max(3,floor(nbran/nwhorl)) # branches per whorl - xtap = c(HCB,HCB+CL*tr$LoY,HCB+CL*tr$HiY,tree$Ht) - ytap = c(0,tree$Crd1*tr$LoX,tree$Crd1*tr$HiX,0) - distfun <- approxfun(xtap,ytap,rule=2,ties="ordered") - rsc = runif(nwhorl)*min(1/nwhorl,.05) - z <- rep((seq(0,1,length=nwhorl)+rsc),each=nbran) - z[z>1] = 1 - # tlt in degrees. - tlt <- tr$BaseUp + tltslp*z - # tlt in slope proprtion - tlt <- tan(tlt*pi/180) - z <- HCB+CL*z - angs <- rep(seq(0,2*pi,length=nbran),nwhorl) - startang = runif(nwhorl*nbran)*2*pi - angs = angs+startang - r <- tree$Crd1/2 - ll <- distfun(z) - x <- tree$Xloc + ll*cos(angs) - y <- tree$Yloc + ll*sin(angs) - ll <- ll * tlt * .5 - ans = cbind(x,y,z) - for (row in 1:nrow(ans)) - { - lin = rbind(c(x=tree$Xloc,y=tree$Yloc,ans[row,3]),ans[row,]) - lin[1,3] = lin[1,3]-ll[row] - lin[2,3] = lin[2,3]+ll[row] - lin[lin[,3] > tree$Ht,3] = tree$Ht - branchList[[row]] = lin - } - branchList = branchList[!duplicated(branchList)] - tree$branches = list() - if (fallangle==0) - { - tree$baseht = 0 - tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) - if (length(branchList)) - { - if (length(tree$crowncolor) > 1) - { - c1 = sort(sample.int(n=length(branchList),size=floor(length(branchList)*.75))) - tree$branches[[1]] = do.call(rbind,branchList[ c1]) - tree$branches[[2]] = do.call(rbind,branchList[-c1]) - } else { - tree$branches[[1]] = do.call(rbind,branchList) - } - } - } else { - tree$baseht=tree$DBH/2 - tree$branches[[1]] = do.call(rbind,branchList) - tree=fellTree(fallangle,tree) - } - } else { - if (fallangle==0) - { - tree$baseht = 0 - tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) - } else { - tree$baseht=tree$DBH/2 - tree=fellTree(fallangle,tree) - } - } - } else { # multi leader 2=multiple leader with weak central - nbran = tr$Nwhorl - nleaves = tr$Nbrchs - if (nbran == 0) - { -cat ("svsTree, multiple leader, nbran == 0, tree not drawn.\n") - return(NULL) - } - xtap = c(HCB,HCB+CL*tr$LoY,HCB+CL*tr$HiY,tree$Ht) - ytap = c(0,tree$Crd1*tr$LoX,tree$Crd1*tr$HiX,0) - distfun <- approxfun(xtap,ytap,rule=2,ties="ordered") - rsc = runif(nbran)*min(1/nbran,.05) - z <- rep(seq(0,1,length=nbran)+rsc) - z[z>1] = 1 - # tlt in degrees. - tlt <- tr$BaseUp + tltslp*z - # tlt in slope proprtion - tlt <- tan(tlt*pi/180) - z <- HCB+CL*z - angs <- seq(0,2*pi,length=nbran) - startang = runif(nbran)*.5*pi - angs = angs+startang - r <- tree$Crd1/2 - ll <- distfun(z)*.7 #just make them shorter. - x <- tree$Xloc + ll*cos(angs) - y <- tree$Yloc + ll*sin(angs) - ll <- ll * tlt * .5 - ans = as.matrix(cbind(x,y,z),ncol=3) - for (row in 1:nrow(ans)) - { - lin = rbind(c(x=tree$Xloc,y=tree$Yloc,ans[row,3]),ans[row,]) - lin[1,3] = lin[1,3]-ll[row] - lin[2,3] = lin[2,3]+ll[row] - #branches can not be taller than the tree - lin[lin[,3] > tree$Ht,3] = tree$Ht - branchList[[row]] = lin - } - branchList = branchList[!duplicated(branchList)] - tree$branches = list() - tree$branches[[1]] = do.call(rbind,branchList) - tree$leaves = list() - # draw the leaves if there are some. - if (nleaves>0) - { - #adjust the leaf count - lm3 = nleaves/(tr$SampHt*tr$SampCR*tr$SampCDia) - nleaves = max(5,floor(lm3*CL*tree$Crd1*5)) # 5 comes from experimentation - angs = runif(nleaves)*2*pi - z = runif(nleaves) - z = HCB+CL*z - ll <- distfun(z)*runif(nleaves) - x <- tree$Xloc + ll*cos(angs) - y <- tree$Yloc + ll*sin(angs) - lvs = as.matrix(cbind(x,y,z),ncol=3) - if (length(tree$crowncolor) > 1 && nleaves >= 5) - { - n1 = floor(nleaves)*.75 - tree$leaves[[1]] = lvs[1:n1,,drop=FALSE] - tree$leaves[[2]] = lvs[(n1+1):nleaves,,drop=FALSE] - } else tree$leaves[[1]] = lvs - } - # fell the tree if indicated - tree$baseht = 0 - if (fallangle>0) - { - tree$baseht=tree$DBH/2 - tr=try(fellTree(fallangle,tree)) - tree = tr - } else { - tree$baseht = 0 - tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) - } - } - } - tree -} - -fellTree <- function (fallangle,tree) -{ - if (fallangle == 0) return(tree) - fallangle=(fallangle*pi/180) - sinfa = sin(fallangle) - cosfa = cos(fallangle) - tx90 = matrix(c(1,0,0,0,0,-1,0,1,0),nrow=3,byrow=TRUE) - ty90 = matrix(c(0,0,1,0,1,0,-1,0,0),nrow=3,byrow=TRUE) - tzfa = matrix(c(cosfa,-sinfa,0,sinfa,cosfa,0,0,0,1),nrow=3,byrow=TRUE) - tree$tip = c(tree$Xloc+tree$Ht*cosfa,tree$Yloc+tree$Ht*sinfa,0) - if (length(tree$branches)) - { - down = tree$branches[[1]] - if (nrow(down) == 0) next - down[,1] = (tree$branches[[1]][,2]-tree$Yloc) - down[,2] = tree$branches[[1]][,3] - down[,3] = -(tree$branches[[1]][,1]-tree$Xloc) - down = t(apply(down,1,function(x) - { - tt = as.vector(tzfa %*% (ty90 %*% (tx90 %*% x))[,1]) - c(tt[1]+tree$Xloc,tt[2]+tree$Yloc,tt[3]) - })) - del = down[,3]<0 - if (any(del)) - { - even = seq(2,length(del),2) - del = even[del[even]] - down = down[-c(del-1,del),] - tree$branches[[1]] = down - } - } - if (length(tree$leaves)) - { - for (ilv in 1:length(tree$leaves)) - { - down = tree$leaves[[ilv]] - if (nrow(down) == 0) next - down[,1] = (tree$leaves[[ilv]][,2]-tree$Yloc) - down[,2] = tree$leaves[[ilv]][,3] - down[,3] = -(tree$leaves[[ilv]][,1]-tree$Xloc) - down = t(apply(down,1,function(x) - { - tt = as.vector(tzfa %*% (ty90 %*% (tx90 %*% x))[,1]) - c(tt[1]+tree$Xloc,tt[2]+tree$Yloc,tt[3]) - })) - del = down[,3]<0 - if (any(del)) down = down[!del,] - tree$leaves[[ilv]] = down - } - } - tree -} - -displayTrees <- function (drawnTrees) -{ - #draw the trunks - alltr = list() - for (tree in drawnTrees) - { - if (is.null(tree$baseht)) next - line = rbind(c(tree$Xloc,tree$Yloc,tree$baseht),tree$tip) - alltr[[tree$stemcolor]] = if (is.null(alltr[[tree$stemcolor]])) line - else rbind(alltr[[tree$stemcolor]], line) - } - for (col in names(alltr)) segments3d(alltr[[col]],col=col,lwd=3,alpha=1,add=TRUE) - #make big trees cones ... this code could be much faster by making a list of all triangles. - for (tree in drawnTrees) - { - if (is.null(tree$baseht)) next - if (tree$DBH > 1) # note that dbh is in feet. - { - cone3d(base=c(tree$Xloc,tree$Yloc,tree$baseht),tip=tree$tip, - rad=tree$DBH/2,n= 5, col=tree$stemcolor) - } - } - allbr = list() - alllv = list() - # draw the crowns when they are made up of branches or leaves - # draw all the line segments of the given color - for (tree in drawnTrees) - { - if (length(tree$branches)) - { - ic = 0 - cols = if (length(tree$leaves)) tree$stemcolor else tree$crowncolor - for (col in cols) - { - ic = ic+1 - if (length(tree$branches) < ic) break - allbr[[col]] = if (is.null(allbr[[col]])) tree$branches[[ic]] else - rbind(allbr[[col]],tree$branches[[ic]]) - } - } - if (length(tree$leaves)) - { - ic = 0 - for (col in tree$crowncolor) - { - ic = ic+1 - alllv[[col]] = if (is.null(alllv[[col]])) tree$leaves[[ic]] else - rbind(alllv[[col]],tree$leaves[[ic]]) - } - } - } - for (col in names(allbr)) segments3d(allbr[[col]],col=col, lwd=1,alpha=1,add=TRUE) - for (col in names(alllv)) points3d(alllv[[col]],col=col,cex=.5,alpha=1,add=TRUE,pch=".") #17) -} - -cone3d <- function(base=c(0,0,0),tip=c(0,0,1),rad=1,n=8,draw.base=TRUE, - trans = par3d("userMatrix"), ...) { - ax <- tip-base - if (missing(trans) && !rgl.cur()) trans <- diag(4) - ### is there a better way? - if (ax[1]!=0) { - p1 <- c(-ax[2]/ax[1],1,0) - p1 <- p1/sqrt(sum(p1^2)) - if (p1[1]!=0) { - p2 <- c(-p1[2]/p1[1],1,0) - p2[3] <- -sum(p2*ax) - p2 <- p2/sqrt(sum(p2^2)) - } else { - p2 <- c(0,0,1) - } - } else if (ax[2]!=0) { - p1 <- c(0,-ax[3]/ax[2],1) - p1 <- p1/sqrt(sum(p1^2)) - if (p1[1]!=0) { - p2 <- c(0,-p1[3]/p1[2],1) - p2[3] <- -sum(p2*ax) - p2 <- p2/sqrt(sum(p2^2)) - } else { - p2 <- c(1,0,0) - } - } else { - p1 <- c(0,1,0); p2 <- c(1,0,0) - } - degvec <- seq(0,2*pi,length=n+1)[-1] - ecoord2 <- function(theta) - { - base+rad*(cos(theta)*p1+sin(theta)*p2) - } - i <- rbind(1:n,c(2:n,1),rep(n+1,n)) - v <- cbind(sapply(degvec,ecoord2),tip) - if (draw.base) - { - v <- cbind(v,base) - i.x <- rbind(c(2:n,1),1:n,rep(n+2,n)) - i <- cbind(i,i.x) - } - triangles3d(v[1,i],v[2,i],v[3,i],...) -} - -circle3D <- function (x0=0,y0=0,z0=0,r=1,n=60,col="gray",alpha=.5,...) -{ - theta <- seq(0, 2*pi, len=n) - cords = cbind((cos(theta)*r) + x0,(sin(theta)*r) + y0, 0) - polygon3d(cords,color=col,alpha=alpha,...) - cords -} - -matRotat <- function(mat,xa=0,ya=0,za=0) -{ - x = 0.01745329 # x = pi/180 - sinxa = sin(xa*x) - sinya = sin(ya*x) - sinza = sin(za*x) - cosxa = cos(xa*x) - cosya = cos(ya*x) - cosza = cos(za*x) - mx = matrix(c(1,0,0,0,cosxa,-sinxa,0,sinxa,cosxa),nrow=3,byrow=TRUE) - my = matrix(c(cosya,0,sinya,0,1,0,-sinya,0,cosya),nrow=3,byrow=TRUE) - mz = matrix(c(cosza,-sinza,0,sinza,cosza,0,0,0,1),nrow=3,byrow=TRUE) - rm = mx %*% my %*% mz - mat %*% rm -} - -matRotateZ180 <- function(mat,offset) -{ - mat[,1] = mat[,1]-offset - mat[,2] = mat[,2]-offset - mat = mat %*% diag(c(-1,-1,1)) - mat[,1] = mat[,1]+offset - mat[,2] = mat[,2]+offset - mat -} - +svsTree <- function(tree,treeform) +{ + # data in the treeform (inforation form Bob's documentation): + # Sp Species + # TrCl tree class + # CrCl crown class + # PlFrm plant form or plant type, Bits 1-4 as follows: + # 0=single leader form, 1=multiple leader with strong central, + # 2=multiple leader with weak central, 3=no central. + # Bits 5-8: foliage damage, bits 9-12 branch damage. + # Foliage damage codes are: 0=no damage, 1=top 1/3, 2=top 2/3, + # 3=bot 1/3, 4=bot 2/3, 5=entire crown. + # Branch damage information: 0=no damage, 1=top 1/3 dead branches, + # 2=top 2/3, 3=bot 1/3, 4=bot 2/3, 5=entire crown + # Nbrchs for single leader forms, number of branches, for multi leader + # this is the number of heavy branches + # NWorls for single leader forms, number of whorls, for multi leader + # it is the number of leaves + # BrBase Location of the branching point relative to base of live crown + # (used on multiple leader trees). + # BrAngle Angular increment between branches and leaf structures + # LoX the portion of the crown width for the lower radius + # LoY the portion of the crown length for the lower radius + # HiX the portion of the crown width for the upper radius + # HiY the poriton of the crown length for the upper radius + # BaseUp branch insertation angle for branches near the bottom + # TopUp branch insertation angle for branches near the top + # StemC Stem color + # BrCol Branch color + # FlCol1 Foliage color for 75% + # FlCol2 Foliage color for 25% + # SampHt Ht of sample trees used by SVS tree designer + # SampCR Crown radio ... ditto + # SampCDia Crown diameter ... ditto + # SampScale Object scaling, not used here + + # CURRENT TREE CLASSES: from FVS svout.f + # 0 - GREEN TREE (STANDING OR RECENTLY CUT TREE) + # 90 - NEW WESTWIDE PINE BEETLE KILL, OFF-GREEN + # 91 - 1 YEAR OLD WWPB KILL, RED TREE + # 92 - 2 YEAR OLD WWPB KILL, FADING TREE + # 94 - SNAG + # 95 - RED AND GREEN TREE (BURNT 99) NOT USED YET + # 96 - GREY SNAG (BURNT 94) - OLDER BURNED TREE + # 97 - GREY TREE (BURNT 98 OR 99) - RECENTLY BURNED TREE + # 98 - RED TREE (RECENTLY DEAD STANDING OR DOWN TREE) + # 99 - WILD CARD, WE DON'T USE THIS CODE...IT IS A GREEN + # TREE (STANDING OR RECENTLY CUT TREE) + + colors=c(rgb(210, 66, 14, maxColorValue=255), + rgb(163, 117, 0, maxColorValue=255), + rgb(119, 42, 24, maxColorValue=255), + rgb( 98, 98, 98, maxColorValue=255), + rgb(112, 153, 0, maxColorValue=255), + rgb( 0, 86, 26, maxColorValue=255), + rgb( 20, 66, 42, maxColorValue=255), + rgb( 0, 76, 0, maxColorValue=255), + rgb( 62, 45, 45, maxColorValue=255), + rgb( 98, 18, 0, maxColorValue=255), + rgb( 88, 55, 57, maxColorValue=255), + rgb( 52, 149, 64, maxColorValue=255), + rgb( 0, 58, 44, maxColorValue=255), + rgb( 90, 64, 38, maxColorValue=255), + rgb(115, 82, 0, maxColorValue=255), + rgb(137, 137, 0, maxColorValue=255), + rgb( 69, 72, 72, maxColorValue=255), + rgb( 86, 64, 16, maxColorValue=255), + rgb( 0, 107, 0, maxColorValue=255), + rgb( 76, 46, 0, maxColorValue=255)) + + if (any(is.na(tree))) return(NULL) + if (tree$DBH == 0) return(NULL) + tree$DBH = tree$DBH/12 + CL = tree$Ht*tree$Cr1 + fallangle=tree$Fang + HCB = tree$Ht*(1-tree$Cr1) + ttcl = if (tree$TrCl == 0) 99 else tree$TrCl + tr = subset(treeform,Sp == tree$sp & TrCl == ttcl) + tr = as.list(tr[1,]) + tltslp = diff(c(tr$BaseUp,tr$TopUp)) + tree$crowncolor= c(colors[tr$FlCol1+1],colors[tr$FlCol2+1]) + tree$crowncolor= tree$crowncolor[!duplicated(tree$crowncolor)] + tree$stemcolor = colors[tr$StemC+1] + + if (tree$Cr1 && tree$Crd1 && HCB && CL) + { + branchList = list() + # single leader + if (tr$PlFrm == 0) + { + # single leader, then ignore the nwhorl and nbran data from treeform + nwhorl = tr$Nwhorls + nbran = tr$Nbrchs # total number + # limit the number of branches to 4 per foot of crown length + if (nbran > 4*CL) nbran = 4*CL + if (nwhorl == 0) nwhorl = nbran + nwhorl = ceiling(nwhorl) + if (nwhorl > 0) + { + nbran = max(3,floor(nbran/nwhorl)) # branches per whorl + xtap = c(HCB,HCB+CL*tr$LoY,HCB+CL*tr$HiY,tree$Ht) + ytap = c(0,tree$Crd1*tr$LoX,tree$Crd1*tr$HiX,0) + distfun <- approxfun(xtap,ytap,rule=2,ties="ordered") + rsc = runif(nwhorl)*min(1/nwhorl,.05) + z <- rep((seq(0,1,length=nwhorl)+rsc),each=nbran) + z[z>1] = 1 + # tlt in degrees. + tlt <- tr$BaseUp + tltslp*z + # tlt in slope proprtion + tlt <- tan(tlt*pi/180) + z <- HCB+CL*z + angs <- rep(seq(0,2*pi,length=nbran),nwhorl) + startang = runif(nwhorl*nbran)*2*pi + angs = angs+startang + r <- tree$Crd1/2 + ll <- distfun(z) + x <- tree$Xloc + ll*cos(angs) + y <- tree$Yloc + ll*sin(angs) + ll <- ll * tlt * .5 + ans = cbind(x,y,z) + for (row in 1:nrow(ans)) + { + lin = rbind(c(x=tree$Xloc,y=tree$Yloc,ans[row,3]),ans[row,]) + lin[1,3] = lin[1,3]-ll[row] + lin[2,3] = lin[2,3]+ll[row] + lin[lin[,3] > tree$Ht,3] = tree$Ht + branchList[[row]] = lin + } + branchList = branchList[!duplicated(branchList)] + tree$branches = list() + if (fallangle==0) + { + tree$baseht = 0 + tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) + if (length(branchList)) + { + if (length(tree$crowncolor) > 1) + { + c1 = sort(sample.int(n=length(branchList),size=floor(length(branchList)*.75))) + tree$branches[[1]] = do.call(rbind,branchList[ c1]) + tree$branches[[2]] = do.call(rbind,branchList[-c1]) + } else { + tree$branches[[1]] = do.call(rbind,branchList) + } + } + } else { + tree$baseht=tree$DBH/2 + tree$branches[[1]] = do.call(rbind,branchList) + tree=fellTree(fallangle,tree) + } + } else { + if (fallangle==0) + { + tree$baseht = 0 + tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) + } else { + tree$baseht=tree$DBH/2 + tree=fellTree(fallangle,tree) + } + } + } else { # multi leader 2=multiple leader with weak central + nbran = tr$Nwhorl + nleaves = tr$Nbrchs + if (nbran == 0) + { +cat ("svsTree, multiple leader, nbran == 0, tree not drawn.\n") + return(NULL) + } + xtap = c(HCB,HCB+CL*tr$LoY,HCB+CL*tr$HiY,tree$Ht) + ytap = c(0,tree$Crd1*tr$LoX,tree$Crd1*tr$HiX,0) + distfun <- approxfun(xtap,ytap,rule=2,ties="ordered") + rsc = runif(nbran)*min(1/nbran,.05) + z <- rep(seq(0,1,length=nbran)+rsc) + z[z>1] = 1 + # tlt in degrees. + tlt <- tr$BaseUp + tltslp*z + # tlt in slope proprtion + tlt <- tan(tlt*pi/180) + z <- HCB+CL*z + angs <- seq(0,2*pi,length=nbran) + startang = runif(nbran)*.5*pi + angs = angs+startang + r <- tree$Crd1/2 + ll <- distfun(z)*.7 #just make them shorter. + x <- tree$Xloc + ll*cos(angs) + y <- tree$Yloc + ll*sin(angs) + ll <- ll * tlt * .5 + ans = as.matrix(cbind(x,y,z),ncol=3) + for (row in 1:nrow(ans)) + { + lin = rbind(c(x=tree$Xloc,y=tree$Yloc,ans[row,3]),ans[row,]) + lin[1,3] = lin[1,3]-ll[row] + lin[2,3] = lin[2,3]+ll[row] + #branches can not be taller than the tree + lin[lin[,3] > tree$Ht,3] = tree$Ht + branchList[[row]] = lin + } + branchList = branchList[!duplicated(branchList)] + tree$branches = list() + tree$branches[[1]] = do.call(rbind,branchList) + tree$leaves = list() + # draw the leaves if there are some. + if (nleaves>0) + { + #adjust the leaf count + lm3 = nleaves/(tr$SampHt*tr$SampCR*tr$SampCDia) + nleaves = max(5,floor(lm3*CL*tree$Crd1*5)) # 5 comes from experimentation + angs = runif(nleaves)*2*pi + z = runif(nleaves) + z = HCB+CL*z + ll <- distfun(z)*runif(nleaves) + x <- tree$Xloc + ll*cos(angs) + y <- tree$Yloc + ll*sin(angs) + lvs = as.matrix(cbind(x,y,z),ncol=3) + if (length(tree$crowncolor) > 1 && nleaves >= 5) + { + n1 = floor(nleaves)*.75 + tree$leaves[[1]] = lvs[1:n1,,drop=FALSE] + tree$leaves[[2]] = lvs[(n1+1):nleaves,,drop=FALSE] + } else tree$leaves[[1]] = lvs + } + # fell the tree if indicated + tree$baseht = 0 + if (fallangle>0) + { + tree$baseht=tree$DBH/2 + tr=try(fellTree(fallangle,tree)) + tree = tr + } else { + tree$baseht = 0 + tree$tip = c(tree$Xloc,tree$Yloc,tree$Ht) + } + } + } + tree +} + +fellTree <- function (fallangle,tree) +{ + if (fallangle == 0) return(tree) + fallangle=(fallangle*pi/180) + sinfa = sin(fallangle) + cosfa = cos(fallangle) + tx90 = matrix(c(1,0,0,0,0,-1,0,1,0),nrow=3,byrow=TRUE) + ty90 = matrix(c(0,0,1,0,1,0,-1,0,0),nrow=3,byrow=TRUE) + tzfa = matrix(c(cosfa,-sinfa,0,sinfa,cosfa,0,0,0,1),nrow=3,byrow=TRUE) + tree$tip = c(tree$Xloc+tree$Ht*cosfa,tree$Yloc+tree$Ht*sinfa,0) + if (length(tree$branches)) + { + down = tree$branches[[1]] + if (nrow(down) == 0) next + down[,1] = (tree$branches[[1]][,2]-tree$Yloc) + down[,2] = tree$branches[[1]][,3] + down[,3] = -(tree$branches[[1]][,1]-tree$Xloc) + down = t(apply(down,1,function(x) + { + tt = as.vector(tzfa %*% (ty90 %*% (tx90 %*% x))[,1]) + c(tt[1]+tree$Xloc,tt[2]+tree$Yloc,tt[3]) + })) + del = down[,3]<0 + if (any(del)) + { + even = seq(2,length(del),2) + del = even[del[even]] + down = down[-c(del-1,del),] + tree$branches[[1]] = down + } + } + if (length(tree$leaves)) + { + for (ilv in 1:length(tree$leaves)) + { + down = tree$leaves[[ilv]] + if (nrow(down) == 0) next + down[,1] = (tree$leaves[[ilv]][,2]-tree$Yloc) + down[,2] = tree$leaves[[ilv]][,3] + down[,3] = -(tree$leaves[[ilv]][,1]-tree$Xloc) + down = t(apply(down,1,function(x) + { + tt = as.vector(tzfa %*% (ty90 %*% (tx90 %*% x))[,1]) + c(tt[1]+tree$Xloc,tt[2]+tree$Yloc,tt[3]) + })) + del = down[,3]<0 + if (any(del)) down = down[!del,] + tree$leaves[[ilv]] = down + } + } + tree +} + +displayTrees <- function (drawnTrees) +{ + #draw the trunks + alltr = list() + for (tree in drawnTrees) + { + if (is.null(tree$baseht)) next + line = rbind(c(tree$Xloc,tree$Yloc,tree$baseht),tree$tip) + alltr[[tree$stemcolor]] = if (is.null(alltr[[tree$stemcolor]])) line + else rbind(alltr[[tree$stemcolor]], line) + } + for (col in names(alltr)) segments3d(alltr[[col]],col=col,lwd=3,alpha=1,add=TRUE) + #make big trees cones ... this code could be much faster by making a list of all triangles. + for (tree in drawnTrees) + { + if (is.null(tree$baseht)) next + if (tree$DBH > 1) # note that dbh is in feet. + { + cone3d(base=c(tree$Xloc,tree$Yloc,tree$baseht),tip=tree$tip, + rad=tree$DBH/2,n= 5, col=tree$stemcolor) + } + } + allbr = list() + alllv = list() + # draw the crowns when they are made up of branches or leaves + # draw all the line segments of the given color + for (tree in drawnTrees) + { + if (length(tree$branches)) + { + ic = 0 + cols = if (length(tree$leaves)) tree$stemcolor else tree$crowncolor + for (col in cols) + { + ic = ic+1 + if (length(tree$branches) < ic) break + allbr[[col]] = if (is.null(allbr[[col]])) tree$branches[[ic]] else + rbind(allbr[[col]],tree$branches[[ic]]) + } + } + if (length(tree$leaves)) + { + ic = 0 + for (col in tree$crowncolor) + { + ic = ic+1 + alllv[[col]] = if (is.null(alllv[[col]])) tree$leaves[[ic]] else + rbind(alllv[[col]],tree$leaves[[ic]]) + } + } + } + for (col in names(allbr)) segments3d(allbr[[col]],col=col, lwd=1,alpha=1,add=TRUE) + for (col in names(alllv)) points3d(alllv[[col]],col=col,cex=.5,alpha=1,add=TRUE,pch=".") #17) +} + +cone3d <- function(base=c(0,0,0),tip=c(0,0,1),rad=1,n=8,draw.base=TRUE, + trans = par3d("userMatrix"), ...) { + ax <- tip-base + if (missing(trans) && !rgl.cur()) trans <- diag(4) + ### is there a better way? + if (ax[1]!=0) { + p1 <- c(-ax[2]/ax[1],1,0) + p1 <- p1/sqrt(sum(p1^2)) + if (p1[1]!=0) { + p2 <- c(-p1[2]/p1[1],1,0) + p2[3] <- -sum(p2*ax) + p2 <- p2/sqrt(sum(p2^2)) + } else { + p2 <- c(0,0,1) + } + } else if (ax[2]!=0) { + p1 <- c(0,-ax[3]/ax[2],1) + p1 <- p1/sqrt(sum(p1^2)) + if (p1[1]!=0) { + p2 <- c(0,-p1[3]/p1[2],1) + p2[3] <- -sum(p2*ax) + p2 <- p2/sqrt(sum(p2^2)) + } else { + p2 <- c(1,0,0) + } + } else { + p1 <- c(0,1,0); p2 <- c(1,0,0) + } + degvec <- seq(0,2*pi,length=n+1)[-1] + ecoord2 <- function(theta) + { + base+rad*(cos(theta)*p1+sin(theta)*p2) + } + i <- rbind(1:n,c(2:n,1),rep(n+1,n)) + v <- cbind(sapply(degvec,ecoord2),tip) + if (draw.base) + { + v <- cbind(v,base) + i.x <- rbind(c(2:n,1),1:n,rep(n+2,n)) + i <- cbind(i,i.x) + } + triangles3d(v[1,i],v[2,i],v[3,i],...) +} + +circle3D <- function (x0=0,y0=0,z0=0,r=1,n=60,col="gray",alpha=.5,...) +{ + theta <- seq(0, 2*pi, len=n) + cords = cbind((cos(theta)*r) + x0,(sin(theta)*r) + y0, 0) + polygon3d(cords,color=col,alpha=alpha,...) + cords +} + +matRotat <- function(mat,xa=0,ya=0,za=0) +{ + x = 0.01745329 # x = pi/180 + sinxa = sin(xa*x) + sinya = sin(ya*x) + sinza = sin(za*x) + cosxa = cos(xa*x) + cosya = cos(ya*x) + cosza = cos(za*x) + mx = matrix(c(1,0,0,0,cosxa,-sinxa,0,sinxa,cosxa),nrow=3,byrow=TRUE) + my = matrix(c(cosya,0,sinya,0,1,0,-sinya,0,cosya),nrow=3,byrow=TRUE) + mz = matrix(c(cosza,-sinza,0,sinza,cosza,0,0,0,1),nrow=3,byrow=TRUE) + rm = mx %*% my %*% mz + mat %*% rm +} + +matRotateZ180 <- function(mat,offset) +{ + mat[,1] = mat[,1]-offset + mat[,2] = mat[,2]-offset + mat = mat %*% diag(c(-1,-1,1)) + mat[,1] = mat[,1]+offset + mat[,2] = mat[,2]+offset + mat +} + diff --git a/fvsOL/R/ui.R b/fvsOL/R/ui.R index 9271b80..f041dfc 100644 --- a/fvsOL/R/ui.R +++ b/fvsOL/R/ui.R @@ -331,6 +331,7 @@ FVSOnlineUI <- fixedPage( myRadioGroup("dlRDType","Type", c(".xlsx",".csv"))), tags$style(type="text/css","#tableLimitMsg{color:darkred;}"), fixedRow(column(width=12,textOutput("tableLimitMsg"))), + #div(id='testDiv', overflow-scroll), fixedRow(column(width=12,rHandsontableOutput("table"))) ) ), tabPanel("Graphs", @@ -549,37 +550,24 @@ FVSOnlineUI <- fixedPage( textOutput("leafletMessage"), leafletOutput("leafletMap",height="800px",width="100%"))) ), #END View On Maps + + # START Manage Projects Tab tabPanel("Manage Projects", tags$style(type="text/css","#toolsPan {background-color: rgb(255,227,227);}"), tabsetPanel(id="toolsPan", - tabPanel("Manage project", - h4(),h4("Start another project"), + # START Manage project sub tab + tabPanel("Manage project", + div( + h4("Start another project"), selectInput("PrjSelect", "Select project", multiple=FALSE, choices = list(), selectize=FALSE), actionButton("PrjOpen","Open selected project"),h4(), h4("Create a new project"), textInput("PrjNewTitle", "New project title", ""), - actionButton("PrjNew","Make new project"), - h4("Delete outputs in current project"), - list( - modalTriggerButton("deleteAllOutputs", "#deleteAllOutputsDlg", - "Delete ALL outputs in current project"), - modalDialog(id="deleteAllOutputsDlg", footer=list( - modalTriggerButton("deleteAllOutputsDlgBtn", "#deleteAllOutputsDlg", - "Yes"), - tags$button(type = "button", class = "btn btn-primary", - 'data-dismiss' = "modal", "Cancel"))) - ), - h4(),h4("Delete runs in current project"), - list( - modalTriggerButton("deleteAllRuns", "#deleteAllRunsDlg", - "Delete ALL runs and related outputs in current project"), - modalDialog(id="deleteAllRunsDlg", footer=list( - modalTriggerButton("deleteAllRunsDlgBtn", "#deleteAllRunsDlg", - "Yes"),tags$button(type = "button", class = "btn btn-primary", - 'data-dismiss' = "modal", "Cancel"))) - ), - h4(),h4("Make new project backup file"), + actionButton("PrjNew","Make new project") + ), + div(style= "margin-top: 48px;", + h4("Make new project backup file"), radioButtons("prjBckCnts",NULL,width="50%",choices= list("Project files only"="projOnly", "Project files and FVS software"="projFVS"), @@ -602,10 +590,11 @@ FVSOnlineUI <- fixedPage( modalTriggerButton("restorePrjBackupDlgBtnC", "#restorePrjBackupDlg", "Cancel"))) ), - if(isLocal()) h4(), - if(isLocal()) h4("Upload existing project backup file into current project"), - if(isLocal()) fileInput("upZipBackup","Upload project backup zip file", - width="30%"), + if(isLocal()){div( + h4("Upload existing project backup file into current project"), + fileInput("upZipBackup","Upload project backup zip file",width="30%")) + }), + div(style= "margin-top: 32px; margin-bottom: 12px;", uiOutput("delPrjActionMsg"), h4("Delete entire project"), selectInput("PrjDelSelect", "Select project to delete", multiple=FALSE, @@ -613,10 +602,24 @@ FVSOnlineUI <- fixedPage( list(modalTriggerButton("PrjDelete", "#PrjDeleteDlg", "Delete project"), modalDialog(id="PrjDeleteDlg", footer=list( modalTriggerButton("PrjDeleteDlgBtn", "#PrjDeleteDlg","Yes"), - tags$button(type = "button", class = "btn btn-primary", - 'data-dismiss' = "modal", "No")))), - h6(),tags$style(type="text/css","#delPrjActionMsg{color:darkred;}") - ), # END Manage Project + tags$button(type = "button", class = "btn btn-primary",'data-dismiss' = "modal", "No")))), + h6(),tags$style(type="text/css","#delPrjActionMsg{color:darkred;}"), + h4("Delete outputs in current project"), + list( + modalTriggerButton("deleteAllOutputs", "#deleteAllOutputsDlg", "Delete ALL outputs in current project"), + modalDialog(id="deleteAllOutputsDlg", footer=list( + modalTriggerButton("deleteAllOutputsDlgBtn", "#deleteAllOutputsDlg", "Yes"), + tags$button(type = "button", class = "btn btn-primary", 'data-dismiss' = "modal", "Cancel"))) + ), + h4(),h4("Delete runs in current project"), + list( + modalTriggerButton("deleteAllRuns", "#deleteAllRunsDlg", "Delete ALL runs and related outputs in current project"), + modalDialog(id="deleteAllRunsDlg", footer=list(modalTriggerButton("deleteAllRunsDlgBtn", "#deleteAllRunsDlg", "Yes"), + tags$button(type = "button", class = "btn btn-primary", 'data-dismiss' = "modal", "Cancel"))) + ) + ) + ), # END Manage project sub tab + tabPanel("Import input data", fixedRow(column(width=12,offset=0, tags$style(type="text/css","#inputDBPan {background-color: rgb(255,227,227);}"), diff --git a/fvsOL/inst/extdata/AcadianGY.R b/fvsOL/inst/extdata/AcadianGY.R index 5f36d27..6819dbf 100644 --- a/fvsOL/inst/extdata/AcadianGY.R +++ b/fvsOL/inst/extdata/AcadianGY.R @@ -1,6 +1,6 @@ # $Id: AcadianGY.R 3968 2022-04-28 10:36:05Z nickcrookston $ ################################################################################ -# v12.1.5.r +# v12.3.1.r # # Acadian Variant of the Forest Vegetation Simulator (FVS-ACD) # # Developed by Aaron Weiskittel, University of Maine, School of Forest Resources @@ -12,22 +12,38 @@ # time of thinning 'BApre', and year of commercial thinning 'YEAR_CT' need to # be defined # -# For SBW modifiers, cummulative defoliation % 'CDEF', initial year of +# For SBW modifiers, cumulative defoliation % 'CDEF', initial year of # spruce budworm outbreak 'SBW.YR', and duration of spruce budworm # outbreak in years 'SBW.DUR' # # ################################################################################ -library(plyr) #needed for ddply -library(dplyr) # added 12/21/2020 for dplyr::arrange, mutate, rowwise, left_join, tribble -library(nlme) #needed for groupedData and gsummary +library(plyr) # needed for ddply +library(dplyr) # added 12/21/2020 for dplyr::arrange, mutate, rowwise, left_join, tribble, select, group_by, summarise +library(nlme) # needed for groupedData and gsummary +library(purrr) # needed for pmap_* -AcadianVersionTag = "AcadianV12.1.5" +AcadianVersionTag = "AcadianV12.3.1" ############################## #### major update summary #### -# +#### + +# 12.3.1 + # dBA_plot_fun() modified to incorporate new stand basal area increment equation from Aaron Weiskittel + # new functions: make_acd_tree(); make_fvs_tree(); make_fvs_regen() to facilitate reading and writing FVS tree lists + +# 12.3.0 + # Implemented plot basal area constraint from Chen et al (in review) applied to tree diameter increment + # new functions: dBA_plot_fun(); calc_plot_ba() + # AcadianGYOneStand function + # Created code to catch tree records with DBH=0 and add 0.01 + # Limit model execution to species defined in height and diameter increment parameters; others assigned species 99 + +# 12.2.0 + # updated mortality calculation to Chen et al (in review) and updated mortality modifier function names + # new functions: mort_plot_prob(); mort_plot_ba(); surv_tree(); calc_mortality # 12.1.5 # ING.TreeList function @@ -48,6 +64,7 @@ AcadianVersionTag = "AcadianV12.1.5" # 12.1.1 # Weiskittel edits 12/1/2020 # Rice edits integrate new dHt and dDBH functions with FVS version 12/21/2020 + # removed sort.data.frame <- function(form,dat) substitute dplyr::arrange # 11.1 Aaron edits 6/6/2019 and several edits # from Ben Rice and Jereme Frank to resolve errors @@ -57,7 +74,6 @@ AcadianVersionTag = "AcadianV12.1.5" #Define all functions below - # 12/21/2020 removed sort.data.frame <- function(form,dat) substitute dplyr::arrange #Species function @@ -436,82 +452,6 @@ risk.prob=function(SPP,DBH) } #### Diameter increment #### -#Kershaw's basal area increment model (7/25/2012) -dBA=function(SPP,DBH,BalSW,BalHW,SI) -{ - CSA=.00007854*DBH^2 - b0 = 0.0413607 #0.0131971 13504625 3.1341 0.0017 - b1 = 0.7185669 #0.0389550 13504625 18.4461 0.0000 - b2 =-0.0000131 #0.0000008 13504625 -16.3136 0.0000 - b3 =-1.8972591 #1.4650514 13504625 -1.2950 0.1953 - b4 =-0.2036994 #0.0004054 13504625 -502.4644 0.0000 - b5 =-0.1413207 #0.0005636 13504625 -250.7436 0.0000 - switch (SPP, - 'WC' = {b0.sp=-0.0324097292965914; b1.sp=0.0243026410845147; b3.sp=0.430381603974945} , - 'AB' = {b0.sp=-0.032155055953277; b1.sp=-0.0758315347115737; b3.sp=-2.50500288487142} , - 'AE' = {b0.sp=-0.00289573737773235; b1.sp=0.164454907254628; b3.sp=-6.02159281182253} , - 'AH' = {b0.sp=-0.0387554478607925; b1.sp=-0.131070957848901; b3.sp=0.86295454504863} , - 'AP' = {b0.sp=-0.0404142788897025; b1.sp=-0.417150782675109; b3.sp=12.2287533013831} , - 'BA' = {b0.sp=-0.0406718461197018; b1.sp=-0.448802152885325; b3.sp=13.5274116013659} , - 'BC' = {b0.sp=-0.0395355190760311; b1.sp=-0.39435159750363; b3.sp=10.1996802993411} , - 'BF' = {b0.sp=-0.0238599785985451; b1.sp=0.0599181413858148; b3.sp=-1.96717173815071} , - 'BL' = {b0.sp=-0.0254421996077096; b1.sp=-0.0458182877381106; b3.sp=0.223430786484162} , - 'BN' = {b0.sp=0.230460620310085; b1.sp=0.448539282082155; b3.sp=-9.00775634833792} , - 'BO' = {b0.sp=-0.0379602681851854; b1.sp=-0.410744374095436; b3.sp=9.13627859872479} , - 'BP' = {b0.sp=-0.0208547961977369; b1.sp=0.000958603708340414; b3.sp=-7.82720052419057}, - 'BS' = {b0.sp=-0.037626849456682; b1.sp=-0.1348833308022; b3.sp=3.17628561025152} , - 'BT' = {b0.sp=-0.0354478542328709; b1.sp=-0.239043702000071; b3.sp=3.99536659734977} , - 'BW' = {b0.sp=-0.00947170831202568; b1.sp=0.325441763047741; b3.sp=-3.9987202147779} , - 'CC' = {b0.sp=0.0714993646284334; b1.sp=0.394591009428293; b3.sp=-3.09637218566955} , - 'EH' = {b0.sp=-0.0212940442931163; b1.sp=0.0863071462419658; b3.sp=-0.671821932228896} , - 'GA' = {b0.sp=0.180801022123542; b1.sp=0.737159162730291; b3.sp=-12.1095097605942} , - 'GB' = {b0.sp=-0.0405993487574885; b1.sp=-0.479578793537049; b3.sp=12.7602000821997} , - 'HH' = {b0.sp=-0.0381534872012484; b1.sp=-0.147981828194394; b3.sp=1.19510436897729} , - 'HT' = {b0.sp=-0.03321566435831; b1.sp=-0.0476969903766449; b3.sp=1.21464678110164} , - 'JP' = {b0.sp=-0.00962669999406432; b1.sp=0.315133580664912; b3.sp=-10.0582402432695} , - 'LD' = {b0.sp=0.151020547228814; b1.sp=0.518105809959927; b3.sp=-2.95111484704989} , - 'MA' = {b0.sp=-0.018153353182371; b1.sp=0.155653255018945; b3.sp=-11.9908675554091} , - 'MM' = {b0.sp=-0.0265332913512398; b1.sp=0.121550356703452; b3.sp=33.9624348473053} , - 'NM' = {b0.sp=0.0660698688832786; b1.sp=0.185189239318732; b3.sp=-6.44317574120285} , - 'NS' = {b0.sp=0.58765147428241; b1.sp=0.766068463693553; b3.sp=-15.4055499203027} , - 'PB' = {b0.sp=-0.0357555924895321; b1.sp=-0.0803912110328488; b3.sp=-1.6664777029937} , - 'PP' = {b0.sp=-0.0373144797077465; b1.sp=-0.350049097337305; b3.sp=-4.21041059617322} , - 'PR' = {b0.sp=-0.0346701336372091; b1.sp=-0.10912826421038; b3.sp=-2.01542362791443} , - 'QA' = {b0.sp=-0.0311387037811782; b1.sp=-0.0998723553810821; b3.sp=1.41747311042227} , - 'RM' = {b0.sp=-0.0312020217524753; b1.sp=0.00720903134134884; b3.sp=0.101816615489034} , - 'RN' = {b0.sp=-0.0094347931012042; b1.sp=-0.0396817282548712; b3.sp=-10.1183218991636} , - 'RO' = {b0.sp=-0.0141447389984494; b1.sp=0.152148606230763; b3.sp=-1.17046078486604} , - 'RS' = {b0.sp=-0.0301196550138488; b1.sp=0.0152297971351949; b3.sp=0.38931544768626} , - 'SB' = {b0.sp=-0.0377098791144756; b1.sp=-0.114120076436571; b3.sp=5.65813496069566} , - 'SC' = {b0.sp=-0.0199477693630853; b1.sp=0.0891064466739558; b3.sp=12.2330640504621} , - 'SE' = {b0.sp=-0.038061047232242; b1.sp=-0.0315005432260497; b3.sp=21.7211732839993} , - 'SM' = {b0.sp=-0.0267410758112335; b1.sp=0.0726112628173826; b3.sp=-0.602423638822342} , - 'ST' = {b0.sp=-0.0242569297411646; b1.sp=0.0396034490624144; b3.sp=-27.2777484752897} , - 'SV' = {b0.sp=-0.0385773040278896; b1.sp=-0.433046128822715; b3.sp=2.33236188029167} , - 'TA' = {b0.sp=-0.00915581932849924; b1.sp=0.286151134082257; b3.sp=-3.57106100780012} , - 'WA' = {b0.sp=-0.0309530979243472; b1.sp=-0.0403566782836099; b3.sp=1.32035673823902} , - 'WI' = {b0.sp=-0.0338956617806498; b1.sp=-0.0295693742206591; b3.sp=-1.6320012371658} , - 'WO' = {b0.sp=-0.0388162527590804; b1.sp=-0.254244901384475; b3.sp=7.83872933989312} , - 'WP' = {b0.sp=-0.0158814221367455; b1.sp=0.107642128140552; b3.sp=0.0495265132219116} , - 'WS' = {b0.sp=-0.0226927810269686; b1.sp=0.072532663216557; b3.sp=-2.89254036760573} , - 'YB' = {b0.sp=-0.0324235742130594; b1.sp=-0.0800526792453781; b3.sp=-0.788476908030292}, - 'AL' = {b0.sp=-0.037877520095339; b1.sp=-0.0284909664165172; b3.sp=1.41806369173224} , - 'BE' = {b0.sp=0.00580751714164938; b1.sp=-0.0542581267639763; b3.sp=-0.100295148320291}, - 'EC' = {b0.sp=0.205274222529117; b1.sp=0.217179977143035; b3.sp=-12.5449424235925} , - 'EL' = {b0.sp=-0.0399169173458411; b1.sp=-0.072162484493935; b3.sp=1.52617139302259} , - 'EO' = {b0.sp=-0.0315612449379492; b1.sp=-0.0471643139545318; b3.sp=1.04781938732441} , - 'SH' = {b0.sp=-0.0358714607608239; b1.sp=-0.0529795666761078; b3.sp=1.29375459356858} , - 'SW' = {b0.sp=-0.0339616970717493; b1.sp=-0.0581425807898783; b3.sp=0.344946824221794} , - 'OH' = {b0.sp=-0.0328689129083733; b1.sp=-0.172713736309933; b3.sp=0.868819474238827} , - 'OK' = {b0.sp=-0.0280501839217296; b1.sp=-0.197650906495178; b3.sp=-3.27034720730148} , - 'XX' = {b0.sp=-0.0315633927941656; b1.sp=-0.0359255416466161; b3.sp=1.35548365118208} , - 'BH' = {b0.sp=-0.0289434160385741; b1.sp=-0.00833226438922751; b3.sp=2.08508775264873} , - {b0.sp=0.0; b1.sp=0.0; b3.sp=0.0} - ) - CSAgrow=(b0+b0.sp)*(CSA^((b1+b1.sp)+b2*SI))*exp(((b3+b3.sp)+b4*BalSW+b5*BalHW)*CSA) - return(CSAgrow=CSAgrow) -} - #species random effects ddbh.fun.spp=tribble( @@ -720,6 +660,84 @@ dDBH.SBW.mod=function(Region,SPP,DBH,BAL.SW,BAL.HW,CR,avgDBH.SW,topht,CDEF=NA) return(dDBH.mod) } +#### Plot basal area increment #### +#### 2/22/2023 version 12.3.0 + #### Chen, Cen; Rijal, Baburam and Weiskittel, Aaron. Draft + #### Comparative assessment of time-explicit, state-space and simultaneous + #### models for stand-level volume growth and yield predictions across + #### complex forest stands in the Acadian region of North America + +### * required tree list variables ### + ## Existing ACD variables (trees df) + # BAPH = total plot basal area (m2 per ha) + # pHW.ba = plot percent HW basal area (calculated in the "temp" table- temp$pHW.ba) + # RD.mod = plot relative density SDI/SDImax (calculated in the "temp" table- temp$RD.mod using different calculation with stand stand qmd<10) + +###* Additional required variables ### + # CSI = climate site index global variable from .GlobalEnv$CSI --stand$CSI (default= 12) + # q0; q1; q2; q3; q4 and k parameter estimates (defined inside function) + +# Plot BA increment calculation + dBA_plot_fun=function(RD, CSI, pHW.ba, Ba){ + + # Weiskittel revised parameter estimates + q0 = 0.04968 + q1 =-0.15018 + q2 =-0.13355 + q3 = 0.00010 + q4 = 0.11753 + k = 64.45952 + + ## Equation 3 + # dBa/dt=rt*Ba*(1-Ba/k) + ## assuming t=1 + + # rt=q0+q1*RD+q2*CSI+q3*pHW.ba + # dBa= rt*Ba*(1-Ba/k) + + + #Weiskittel revised eqation form + dBa=(q0+q1*log(RD+1e-6)+q2*log(CSI)+q3*log(pHW.ba*100+1e-6)+q4*log(CSI*RD+1e-6))*Ba*(1-(Ba/k)) + + dBa + + } + +# wrapper function executes dBA_plot_fun() and sets dDBH if plot dBA is less than sum of tree level BA increment + calc_plot_ba= function(tree.list, plot.smry){ + + # calculate plot level basal area increment) + plot.smry = plot.smry %>% + dplyr::group_by(PLOT) %>% + dplyr::summarise(dBA = dBA_plot_fun(RD=RD.mod, + CSI=CSI, + pHW.ba=pHW.ba, + Ba=BAPH)) %>% + ungroup() %>% + dplyr::mutate(dBA=ifelse(dBA<0, 0, dBA)) # constrain to minimum zero + + + tree.list=tree.list %>% + dplyr::mutate(dBA.tree=(dDBH^2*0.00007854)*EXPF) %>% # tree level diameter increment equation ba + # sum tree level BA increment + dplyr::group_by(PLOT) %>% + dplyr::mutate(dBA.tree.sum=sum(dBA.tree, na.rm=T)) %>% + dplyr::ungroup() %>% + # allocate plot level BA increment using tree level BA increment as percent of plot total tree level BA increment + dplyr::left_join(plot.smry, + by='PLOT') %>% + dplyr::mutate(dBA.tree.plot=dBA*(dBA.tree/dBA.tree.sum), + dDBH=ifelse(dBA.tree.sum>dBA, sqrt(dBA.tree.plot/0.00007854/EXPF), dDBH)) %>% + dplyr::select(-dBA.tree, + -dBA.tree.sum, + -dBA.tree.plot, + -dBA) + + tree.list + } + + + #### Height increment #### # 12/21/2020 removed Htincr(); not called in code Height increment (10/8/14) (Russell et al. 2014 EJFR) # Htincr=function(SPP,HT,CR,BAL.SW,BAL.HW,BAPH,CSI) @@ -905,280 +923,777 @@ dHCB.thin.mod = function(SPP, PERCBArm, BApre, QMDratio, YEAR_CT, YEAR){ } #### Mortality #### -#Mortality using the approach of Kershaw -stand.mort.prob=function(Region,BA,BAG,QMD,pBA.BF,pBA.IH) -{ - BA.BF=pBA.BF*BA - BA.IH=pBA.IH*BA - if(Region=='ME'){b0=0.6906978; b1=0.149228; b2=-0.001855535; b3=-2.557345; b4=-0.05507579; b5=0.06414701; b6=0.0432701; cut=0.871958} - else if(Region=='NB'){b0=0.699147; b1=0.1250758; b2=-0.001855535; b3=-2.557345; b4=-0.05507579; b5=0.06414701; b6=0.0432701; cut=0.7268086} - else if(Region=='NS'){b0=0.2756542; b1=0.1499495; b2=-0.001855535; b3=-2.557345; b4=-0.05507579; b5=0.06414701; b6=0.0432701; cut=0.9148455} - else if(Region=='PQ'){b0=1.0472726; b1=0.161746; b2=-0.001855535; b3=-2.557345; b4=-0.05507579; b5=0.06414701; b6=0.0432701; cut=0.7351621} - else{b0=0.6906978; b1=0.149228; b2=-0.001855535; b3=-2.557345; b4=-0.05507579; b5=0.06414701; b6=0.0432701; cut=0.871958} - k=b0+b1*BA+b2*BA^2+b3*BAG+b4*QMD+b5*BA.BF+b6*BA.IH - prob=exp(k)/(1+exp(k)) - return(c(prob=prob,cut=cut)) -} - -stand.mort.BA=function(Region,BA,BAG,QMD,QMD.BF,pBA.bf,pBA.ih) -{ - BA.BF=pBA.bf*BA - BA.IH=pBA.ih*BA - if(Region=='ME'){b0=0.1857844; b1=0.2315199; b2=0.02020253; b3=0.5674303; b4=-2.037042; b5=0.06815229; - b6=0.3345308; b7=0.09950853} - else if(Region=='NB'){b0=0.5987741; b1=0.2315199; b2=0.02020253; b3=0.1888859; b4=-2.037042; b5=0.14607033; - b6=0.3284819; b7=0.09950853} - else if(Region=='NS'){b0=0.1302331; b1=0.2315199; b2=0.02020253; b3=0.589446; b4=-2.037042; b5=0.0867806; - b6=0.2243597; b7=0.09950853} - else if(Region=='PQ'){b0=0.1068258; b1=0.2315199; b2=0.02020253; b3=0.6810417; b4=-2.037042; b5=0.01171661; - b6=0.494071; b7=0.09950853} - else{b0=0.1857844; b1=0.2315199; b2=0.02020253; b3=0.5674303; b4=-2.037042; b5=0.06815229; - b6=0.3345308; b7=0.09950853} - BA.mort=(b0+b1*pBA.bf+b2*pBA.ih)*BA^(b3+b4*BAG) - BF.mort=ifelse(QMD==0,0,b5*BA.BF^b6+b7*(QMD.BF/QMD)) - mort.tot=BA.mort+BF.mort - return(mort.tot=mort.tot) -} +# Cen Chen, John Kershaw Jr, Aaron Weiskittel, Elizabeth McGarrigle, Mike Lavigne. +# Can a multistage approach improve individual tree mortality predictions across the complex +# mixed-species and managed forests of eastern North America? + +# Application of multistage approach: + # 1) Calculate the annual probability that a plot will experience mortality (p) + # 2) Assign value to (I) where I = 0 if p < v and I = 1 otherwise, where v is a plot mortality threshold value + # 3) Calculate the per ha basal area mortality (m) for each plot (m2 ha-1 yr-1) + # 4) Multiply (m) by (I) + # 5) Calculate annual tree survival probabilities (s) each tree record + # 6) In the Acadian framework calculate tree and stand level mortality and survival modifiers, applying to the (p) and (m) values + # 7) Stand level mortality disaggregation using ratio approach using the stand mortality (m) / sum(tree mortality (p) * tree BA) + # 8) Calculate mortality trees per ha (dEXPF) + + + +### * required tree list variables ### + ## Existing ACD variables (trees df) + # DBH = tree record diameter at breast height (cm) + # BAPH = total plot basal area (m2 per ha) + # ba = plot basal area (m2 per ha) for each tree record + # pBF.ba = plot percent BF basal area + # pIHW.ba = plot percent intolerant hardwood basal area tree$SPtype=='HW' & tree$shade<2.0) + # qmd = plot QMD + # BAL = plot basal area in larger trees + # SP = species (FVS Alpha) + +###* Additional variables ### + # Region = ACD region (default ME) + # CSI = climate site index global variable from stand$CSI (default= 12) + + +###* Parameter estimates ### + + ##** fixed parameter estimates ### + # p and s by model type + mort.modtype.fixed=tribble( + ~model.type, ~p.p1, ~p.p2, ~p.p3, ~p.p4, ~p.p5, ~s.p0, ~s.p1, ~s.p2, ~s.p3, ~s.p4, ~s.p5, + #model.type-|--p.p1-|--p.p2-|--p.p3-|--p.p4-|--p.p5-|---s.p0-|---s.p1-|---s.p2-|---s.p3-|---s.p4-|---s.p5- + 'logistic', -0.054, -0.047, 0.065, 0.230, -0.811, -3.4250, -0.1358, 0.0035, 0.0400, -0.0530, 0.0319, + 'gompit', 0.036, 0.031, -0.044, -0.115, 0.474, 1.2171, 0.0417, -0.0008, -0.0092, 0.0118, -0.0071 + ) + + # m + mort.fixed=tribble( + ~m.p0, ~m.p1, ~m.p2, ~m.p3, ~m.p4, + #--m.p0--|--m.p1--|--m.p2--|--m.p3--|--m.p4--| + 84.2843, -1.1754, 83.4725, 13.3258, 0.0005) + + ##** random parameter estimates ### + # region random effects + mort.region.random=tribble( + ~Region, ~m.p0.region, ~m.p4.region, + #-Region-|--m.p0---|--m.p4---| + 'ME', 44.8462, 0.0009, # Maine + 'NB', -8.2982, 0.0012, # New Brunswick + 'NS', -17.6687, -0.0018, # Nova Scotia + 'QC', -11.9457, 0.0028 # Quebec + ) + + # region * model type random effects + mort.modtype.region.random=tribble( + ~model.type, ~Region, ~p.p0.region, ~s.p0.region, + #model.type-|-Region-|--p.p0--|-s.p0------| + 'logistic', 'ME', 1.441, -0.2134, # Maine + 'logistic', 'NB', -0.135, -0.6260, # New Brunswick + 'logistic', 'NS', -0.170, 0.0845, # Nova Scotia + 'logistic', 'QC', -0.839, 0.5464, # Quebec + 'gompit', 'ME', -1.352, 0.0080, # Maine + 'gompit', 'NB', -0.331, 0.1018, # New Brunswick + 'gompit', 'NS', -0.225, -0.0550, # Nova Scotia + 'gompit', 'QC', 0.151, -0.1702 # Quebec + ) + + # s intercept: species random effects + mort.s.p0.species.random=tribble( + ~Species, ~SpeciesCommon, ~s.p0.species.logistic, ~s.p0.species.gompit, + #Sp-|--SpeciesCommon-|--p0.species.logistic-|--p0.species.gompit-| + 'AB', 'American beech', -0.5126, 0.1978, + 'AE', 'American elm', -0.1830, 0.1019, + 'AH', 'American hornbeam', -0.5147, -0.0384, + 'AI', 'ailanthus', 0.0733, -0.0256, + 'AP', 'apple spp.', 0.3698, -0.0642, + 'AS', 'ash spp.', -0.0114, 0.0068, + 'AW', 'Atlantic white-cedar', 0.0633, -0.2002, + 'BA', 'black ash', -0.6276, 0.2264, + 'BC', 'black cherry', 0.7312, -0.1545, + 'BE', 'boxelder', 0.0487, -0.0948, + 'BF', 'balsam fir', -0.8591, 0.2917, + 'BH', 'bitternut hickory', 0.0539, -0.1552, + 'BL', 'black willow', -0.0004, 0.0002, + 'BN', 'butternut', 0.1814, -0.3538, + 'BO', 'black oak', 0.0571, -0.3270, + 'BP', 'balsam poplar', 1.2689, -0.3614, + 'BR', 'bur oak', 0.0808, -0.1058, + 'BS', 'black spruce', -1.3679, 0.4029, + 'BT', 'bigtooth aspen', 0.2714, 0.0608, + 'BW', 'American basswood', 0.3338, -0.1117, + 'CC', 'chokecherry', 0.3558, -0.0700, + 'DW', 'flowering dogwood', 0.0592, 0.0824, + 'EC', 'eastern cottonwood', -0.1708, 0.0278, + 'EH', 'eastern hemlock', 0.1427, -0.0060, + 'EL', 'elm spp.', 0.1841, -0.3584, + 'GA', 'green ash', -0.3557, 0.2509, + 'GB', 'grey birch', -0.1300, 0.0936, + 'HH', 'eastern hophornbeam', -0.1873, 0.1366, + 'HT', 'hawthorn', 0.2525, -0.2235, + 'JP', 'jack pine', 0.1891, 0.0279, + 'MA', 'American mountain ash', 0.2257, -0.0339, + 'MM', 'mountain maple', 0.6884, -0.1776, + 'NS', 'Norway spruce', 0.0418, -0.1410, + 'OH', 'other hardwood', 0.08667083, -0.03098542, # unweighted average of all hardwood species + 'OS', 'other softwood', -0.278, 0.084175, # unweighted average of all softwood species + 'PB', 'paper birch', -0.2767, 0.1684, + 'PP', 'pitch pine', 0.7480, -0.3463, + 'PR', 'pin cherry', 0.6134, -0.1367, + 'PY', 'swamp cottonwood', 0.1014, -0.2156, + 'QA', 'quaking aspen', 0.4572, -0.0414, + 'RM', 'red maple', 0.3908, -0.0215, + 'RN', 'red pine1', 0.2174, -0.0012, + 'RO', 'red oak', 0.0622, 0.0711, + 'RP', 'red pine2', -0.0171, 0.0059, + 'RS', 'red spruce', -0.7487, 0.2653, + 'SB', 'sweet birch', -0.1131, 0.0134, + 'SC', 'Scotch pine', -0.0132, 0.0048, + 'SE', 'serviceberry', 0.8156, -0.3270, + 'SH', 'shagbark hickory', -0.0144, 0.0096, + 'SM', 'sugar maple', -0.2952, 0.1547, + 'SO', 'scarlet oak', -0.0033, 0.0012, + 'ST', 'stripe maple', -0.8613, 0.3145, + 'SV', 'silver maple', 0.0481, 0.0345, + 'SW', 'swamp white oak', -0.0011, 0.0002, + 'SY', 'sycamore', 0.0179, -0.0036, + 'TA', 'tamarack', -1.1673, 0.3719, + 'TM', 'Table-mountain pine', -0.0148, 0.0097, + 'WA', 'white ash', -0.0627, 0.0918, + 'WC', 'northern whitecedar', -1.1750, 0.3678, + 'WK', 'willow spp.', 1.4078, -0.5225, + 'WL', 'willow oak', 0.0000, -0.0148, + 'WO', 'white oak', -0.0910, 0.1999, + 'WP', 'eastern white pine', 0.0147, 0.0695, + 'WS', 'white spruce', -0.5019, 0.2241, + 'YB', 'yellow birch', -0.5763, 0.2065, + 'YP', 'yellow poplar', -0.0016, 0.0006, + '99', 'other', -0.004496875, -0.002195312 # unweighted average of all species + ) + + # s species random effects + mort.s.p1.species.random=tribble( + ~Species, ~SpeciesCommon, ~s.p1.species.logistic, ~s.p1.species.gompit, + + #Sp-|--SpeciesCommon-|--p1.species.logistic-|--p1.species.gompit-| + 'AB', 'American beech', 0.0044, -0.0123, + 'AE', 'American elm', 0.0606, -0.0238, + 'AH', 'American hornbeam', 0.0481, 0.0617, + 'AI', 'ailanthus', 0.3325,-0.1170, + 'AP', 'apple spp.', 0.0315, -0.0163, + 'AS', 'ash spp.', -0.0856, 0.0521, + 'AW', 'Atlantic white-cedar', 0.0047, 0.0049, + 'BA', 'black ash', 0.0197, -0.0160, + 'BC', 'black cherry', -0.0257, 0.0000, + 'BE', 'boxelder', -0.0095, -0.3420, + 'BF', 'balsam fir', 0.0765, -0.0290, + 'BH', 'bitternut hickory', 0.0408, -0.0090, + 'BL', 'black willow', -0.0076, 0.0040, + 'BN', 'butternut', 0.0470, -0.0046, + 'BO', 'black oak', -0.0569, 0.0250, + 'BP', 'balsam poplar', -0.0768, 0.0191, + 'BR', 'bur oak', 0.0979, -0.3485, + 'BS', 'black spruce', 0.0659, -0.0264, + 'BT', 'bigtooth aspen', -0.0562, -0.0014, + 'BW', 'American basswood', -0.0611, 0.0126, + 'CC', 'chokecherry', 0.1986, -0.0664, + 'DW', 'flowering dogwood', 0.3401, -0.1520, + 'EC', 'eastern cottonwood', 0.0849, 0.1089, + 'EH', 'eastern hemlock', -0.1919, 0.0427, + 'EL', 'elm spp.', 0.1031, -0.0087, + 'GA', 'green ash', -0.0271, -0.0103, + 'GB', 'grey birch', 0.0712, -0.0269, + 'HH', 'eastern hophornbeam', -0.0581, 0.0009, + 'HT', 'hawthorn', 0.0594, 0.0120, + 'JP', 'jack pine', -0.0273, -0.0042, + 'MA', 'American mountain ash', -0.0091, -0.0044, + 'MM', 'mountain maple', 0.1151, -0.0365, + 'NS', 'Norway spruce', -0.1011, 0.0401, + 'OH', 'other hardwood', 0.01402083, -0.01949375, # unweighted average of all hardwood species + 'OS', 'other softwood', -0.05584375, 0.0128, # unweighted average of all softwood species + 'PB', 'paper birch', -0.0202, -0.0085, + 'PP', 'pitch pine', -0.0149, 0.0012, + 'PR', 'pin cherry', 0.0604, -0.0241, + 'PY', 'swamp cottonwood', 0.0584, -0.0010, + 'QA', 'quaking aspen', -0.0242, -0.0041, + 'RM', 'red maple', -0.1478, 0.0241, + 'RN', 'red pine1', -0.1021, 0.0128, + 'RO', 'red oak', -0.0742, 0.0046, + 'RP', 'red pine2', -0.1781, 0.0639, + 'RS', 'red spruce', -0.0200, -0.0081, + 'SB', 'sweet birch', -0.0302, 0.0888, + 'SC', 'Scotch pine', -0.1566, 0.0572, + 'SE', 'serviceberry', -0.1200, 0.0458, + 'SH', 'shagbark hickory', -0.1068, 0.0652, + 'SM', 'sugar maple', -0.0824, 0.0063, + 'SO', 'scarlet oak', -0.0533, 0.0214, + 'ST', 'stripe maple', 0.1915, -0.0633, + 'SV', 'silver maple', -0.0834, 0.0118, + 'SW', 'swamp white oak', -0.0311, 0.0072, + 'SY', 'sycamore', 0.2760, -0.0597, + 'TA', 'tamarack', 0.0360, -0.0210, + 'TM', 'Table-mountain pine', -0.0982, 0.0658, + 'WA', 'white ash', -0.1029, 0.0126, + 'WC', 'northern whitecedar', -0.0367, -0.0050, + 'WK', 'willow spp.', 0.0053, 0.0010, + 'WL', 'willow oak', 0.0000, -0.1873, + 'WO', 'white oak', -0.1078, 0.0017, + 'WP', 'eastern white pine', -0.1529, 0.0233, + 'WS', 'white spruce', 0.0032, -0.0134, + 'YB', 'yellow birch', -0.0868, 0.0091, + 'YP', 'yellow poplar', -0.0287, 0.0125, + '99', 'other', -0.003445312, -0.01142031 # unweighted average of all species + ) + +####* plot level mortality probability #### + mort_plot_prob=function(BAPH, # total plot basal area (m2 per ha) + pBF.ba, # plot percent BF basal area + pIHW.ba, # plot percent intolerant hardwood basal area tree$SPtype=='HW' & tree$shade<2.0) + qmd, # plot QMD + Region='ME', # ACD region (default ME) + CSI=12, # climate site index global variable from stand$CSI (default= 12) + model.type='logistic', # model type logistic or gompit (default='logistic') + # mortality model parameter estimates + p.p0.region, # random parameter estimate + p.p1, + p.p2, + p.p3, + p.p4, + p.p5){ + + ### Data management + # validate region + if(!Region %in% c('ME', 'NB', 'NS', 'QC')) Region='ME' + + # validate model type + if(!model.type %in% c('logistic', 'gompit')) model.type='logistic' + + + ### Step 1: Calculate p - plot mortality probability ### + p.fx=p.p0.region+p.p1*BAPH+p.p2*CSI+p.p3*qmd+p.p4*pBF.ba+p.p5*pIHW.ba + + #logistic + if(model.type=='logistic'){ + p=1/(1+exp(p.fx)) + # gompit + }else if(model.type=='gompit'){ + p=1-exp(-exp(p.fx)) + } + + p + } -#SBW mortality modifier -SBW.smort.mod=function(Region,BA,BA.BF,topht,CDEF) -{ - if(Region=='ME') - { - b1=-2.6380 - b2=0.0114 - b3=-0.0076 - b4=0.0074 - } - else if(Region=='NB') +####* plot level basal area mortality ### + mort_plot_ba=function(BAPH, # total plot basal area (m2 per ha) + pBF.ba, # plot percent BF basal area + pIHW.ba, # plot percent intolerant hardwood basal area tree$SPtype=='HW' & tree$shade<2.0) + qmd, # plot QMD + Region='ME', # ACD region (default ME) + CSI=12, # climate site index global variable from stand$CSI (default= 12) + model.type='logistic', # model type logistic or gompit (default='logistic') + p, + v=0.72, # Cen Chen 5/31/2022 threshold value "optimized across regions" + # mortality model parameter estimates + m.p0, + m.p0.region, # random parameter estimate + m.p1, + m.p2, + m.p3, + m.p4, + m.p4.region ) # random parameter estimate { - b1=-3.0893 - b2=0.0071 - b3=-0.0037 - b4=0.0 - } - else - { - b1=-2.6380 - b2=0.0114 - b3=-0.0076 - b4=0.0074 - } - VOL=(topht/2)*BA - pBF=BA.BF/BA - aa=(1/(1+exp(-b1)))*(1/(1+exp(-(b2*0*BA.BF+b3*VOL+b4*0)))) - bb=(1/(1+exp(-b1)))*(1/(1+exp(-(b2*CDEF*BA.BF+b3*VOL+b4*CDEF)))) - rat=ifelse(is.na(CDEF),1,bb/aa) - return(rat=rat) -} - -#Thinning mortality modifier -BAmort.stand=function(BA,PCT,YEAR_CT,YEAR, PERCBArm, BApre, QMDratio){ - TST = ifelse(is.na(YEAR_CT),0,YEAR - YEAR_CT) # time since thinning - b30=-1.2402 - b31=-24.5202 - b32=-1.1302 - b33=1.5884 - y30=8.3385 - y31=-601.3096 - y32=0.5507 - y33=1.5798 - #BAmort=exp(b30+(b31/BA)+b32*PCT+b33*pBA.BF) - mod=ifelse(!is.na(YEAR_CT) & YEAR_CT <= YEAR,1.0+exp(y30+(y31/((100*(PERCBArm)+BApre)+0.01)))*y32^TST*TST^y33,1.0) - #BAmort=BAmort*mod - return(mod=mod) -} - - -tree.mort.prob=function(SPP,DBH) -{ - SPcodes = c('AB','AE','AH','AP','BA','BC','BE','BF','BL','BN','BO','BP','BS', - 'BT','BW','CC','EC','EH','GA','GB','HH','JP','NM','NS','OH','PB', - 'PP','PR','QA','RM','RO','RP','RS','SB','SH','SM','SP','ST','SV', - 'TA','WA','WC','WL','WO','WP','WS','YB','99') - spConst = matrix(c( - # b0 b1 b2 Djump Scale Shape=4.5 - 2.152681379 , -0.0269825907, 0.0002203177 , 41 , 20 , 4.5 , # AB - 2.948346662 , -0.1017558326, 0.0018279137 , 22.5, 40 , 2 , # AE - 4.552236589 , -0.4626664119, 0.0125996045 , 12 , 15 , 4.5 , # AH - 5.6430024532 , -0.4644532732, 0.0132654057 , 16 , 10.6, 4.1 , # AP - 1.7183600838 , 0.0393047451 , -0.0023514773, 39 , 37 , 4.25, # BA - 4.8627898851 , -0.3695674404, 0.0109822297 , 9.2 , 31 , 3.63, # BC - 4.552236589 , -0.2313332059, 0.0125996045 , 14 , 20 , 4.5 , # BE - 2.5743949775 , -0.0851930923, 0.0015971909 , 53 , 40.6, 1.51, # BF - -3.5183135273, 0.5008393656 , -0.0114432915, 10 , 10 , 2 , # BL - 9.6140856026 , -0.8619281584, 0.0215901194 , 15 , 27.5, 1.5 , # BN - 2.7402431243 , -0.0403087 , 0.0014846314 , 40 , 40 , 2 , # BO - 1.8795415329 , -0.3915484285, 0.0298003249 , 33 , 33.6, 4.75, # BP - 1.9568828063 , 0.0535388009 , -0.0010376306, 34 , 22 , 3.75, # BS - 2.1791849646 , -0.0125375225, 0.0008529794 , 40 , 30 , 3 , # BT - -1.4145296118, 0.3204863989 , -0.0029710752, 15 , 30 , 3 , # BW - 4.8627898851 , -0.3695674404, 0.0109822297 , 10 , 20 , 3.63, # CC - -0.4584998714, 0.1992627013 , -0.0028451758, 40.6, 11 , 4.28, # EC - 4.5205542708 , -0.0670350692, 0.0012041907 , 50 , 40 , 3.5 , # EH - 7.2061395918 , -0.2239701333, 0.0070370484 , 34 , 39.6, 3.41, # GA - 0.1922677751 , 0.1517490102 , -0.0039268819, 16 , 8.2 , 3.83, # GB - 2.9674489273 , -0.1009595852, 0.0071673636 , 18 , 24 , 2 , # HH - -0.4488149338, 0.1939739736 , -0.0019541699, 30 , 20 , 3 , # JP - 4.552236589 , -0.2313332059, 0.0125996045 , 24 , 40 , 4.5 , # NM - 17.4833923331, -1.809142126 , 0.0616970369 , 15 , 35 , 2 , # NS - 4.552236589 , -0.5204997134, 0.0125996045 , 12 , 10 , 4.5 , # OH - 2.5863343441 , -0.0518497247, 0.0021853588 , 26.4, 41.2, 1.88, # PB - 12.1649655944, -1.0483772747, 0.0233147008 , 25.8, 41.6, 4.41, # PP - -1.2171488097, 0.3211464783 , -0.0097154365, 10 , 40 , 2 , # PR - -0.4584998714, 0.1992627013 , -0.0028451758, 60.6, 11 , 4.28, # QA - 2.1674971386 , 0.0557266595 , -0.0010435394, 60.2, 40.6, 4.38, # RM - 3.1202275212 , -0.041290776 , 0.0022978235 , 41 , 40.4, 3.27, # RO - 1.1361278304 , 0.1436446742 , 0.0018438454 , 30 , 30 , 3 , # RP - 2.0420797297 , 0.0425701678 , -0.0004901795, 41 , 32 , 4.8 , # RS - 44.2565091524, -2.4248136198, 0.1388397603 , 22 , 35.6, 4.57, # SB - 4.552236589 , -0.2313332059, 0.0125996045 , 15 , 10 , 4.5 , # SH - 2.7069022565 , 0.0086263655 , 0.0007235392 , 54.4, 42 , 1.33, # SM - 5 , -0.3 , 0.01 , 20 , 40 , 3 , # SP - 4.5522366258 , -0.4626664068, 0.012599604 , 4.4 , 24.4, 4.51, # ST - 4.552236589 , -0.2313332059, 0.0125996045 , 24 , 40 , 4.5 , # SV - 1.4269435976 , 0.0886275939 , -0.0021232407, 30 , 33.6, 4.5 , # TA - 1.0042653571 , 0.165359309 , -0.0005814562, 21 , 40 , 4 , # WA - 3.647647507 , -0.0606735724, 0.0008507857 , 40 , 45 , 5 , # WC - -3.5183135273, 0.5008393656 , -0.0114432915, 10 , 10 , 2 , # WL - -4.8640326448, 0.6250645999 , -0.0064419714, 18 , 40 , 4 , # WO - 3.3383526175 , -0.0294498474, 0.0009561864 , 61.2, 41.2, 2.87, # WP - 0.5437824528 , 0.1052397713 , 0.0006332627 , 19 , 54 , 2 , # WS - 2.6967072576 , -0.001250889 , 0.0007521152 , 48 , 60 , 2 , # YB - 2.6967072576 , -0.001250889 , 0.0007521152 , 48 , 60 , 2 ), # 99 - ncol=6,byrow=TRUE) - sprow = match(SPP,SPcodes) - sprow[is.na(sprow)] = nrow(spConst) - # same as: ddd <- b0 + b1 * DBH + b2 * DBH^2 - ddd <- spConst[sprow,1] + spConst[sprow,2] * DBH + spConst[sprow,3] * DBH^2 - surv <- exp(ddd)/(1 + exp(ddd)) - # same as: IDj <- as.integer(DBH/Djump) - IDj <- as.integer(DBH/spConst[sprow,4]) - # same as: exp(-Scale * ((IDj * (DBH - Djump))^Shape)) - Wprob <-1.0# exp(-SPcoefs[sprow,5] * ((IDj * (DBH - SPcoefs[sprow,4]))^SPcoefs[sprow,6])) - tsurv <- surv * Wprob - return(tsurv=tsurv) -} + + ### Data management + # validate region + if(!Region %in% c('ME', 'NB', 'NS', 'QC')) Region='ME' + + # validate model type + if(!model.type %in% c('logistic', 'gompit')) model.type='logistic' + + ### Step 2: Calculate m - plot level basal area mortality ## + + k= m.p0 + m.p0.region + m.p1*CSI + m.p2*pBF.ba + m.p3*pIHW.ba + r= m.p4 + m.p4.region + m.p4*qmd # draft typo of m.p5*qmd + t= 1 # assumes cycle length is always 1 year + m= (BAPH*k)/(BAPH+(k-BAPH)*exp(-r*t) ) + m= r*m*(1-(m/k)) # assuming dt=1 + + ### Step 3: Define and apply I - indicator variable using threshold (cut point) value ## + + # v=0.72 # Cen Chen 5/31/2022 threshold value "optimized across regions" + + I= case_when(p% + dplyr::select(PLOT, BAPH, qmd, + pBF.ba, + pIHW.ba, + use.sbwmod, + topht, + avgHT.SW, + CDEF, + use.thinmod, + use.hwmod, + rdMod.dMORT_RDmod, + YEAR_CT, + QMDratio, + YEAR, + pBArm, + BApre) %>% + dplyr::mutate(model.type=model.type, + Region=Region, + v=v) %>% + dplyr::left_join(mort.modtype.fixed, # join with fixed parameter estimates + by=c('model.type')) %>% + dplyr::left_join(mort.fixed, + by=character()) %>% + dplyr::left_join(mort.region.random, # join with random parameter estimates + by='Region') %>% + dplyr::left_join(mort.modtype.region.random, + by=c('Region', 'model.type')) %>% + dplyr::mutate(p.mort=pmap_dbl(list(BAPH= BAPH, # calculate plot mortality probability (p) + pBF.ba= pBF.ba, + pIHW.ba= pIHW.ba, + qmd= qmd, + Region= Region, + CSI= CSI, + model.type= model.type, + # mortality model parameter estimates + p.p0.region= p.p0.region, + p.p1= p.p1, + p.p2= p.p2, + p.p3= p.p3, + p.p4= p.p4, + p.p5= p.p5), + mort_plot_prob), + m.mort=pmap_dbl(list(BAPH=BAPH, # calculate plot mortality basal area (m) + pBF.ba=pBF.ba, + pIHW.ba=pIHW.ba, + qmd=qmd, + Region=Region, + CSI=CSI, + model.type=model.type, + v=v, + p=p.mort, + # mortality model parameter estimates + m.p0=m.p0, + m.p0.region=m.p0.region, + m.p1=m.p1, + m.p2=m.p2, + m.p3=m.p3, + m.p4=m.p4, + m.p4.region=m.p4.region), + mort_plot_ba)) + + # calculate plot level modifier values + plot.mort=plot.mort %>% + #Spruce budworm plot mortality modifier + dplyr::mutate(smort.sbw.mod=ifelse(use.sbwmod==F, 1, + pmap_dbl(list(Region=Region, + BA=BAPH, + BA.BF=pBF.ba*BAPH, + topht=topht, + CDEF=CDEF), + smort_sbw_mod)), + # thinning plot modifier + ssurv.thin.mod=ifelse(use.thinmod==F, 1, + pmap_dbl(list(YEAR_CT= YEAR_CT, + YEAR= YEAR, + PERCBArm= pBArm, + BApre= BApre), + ssurv_thin_mod)), + # apply modifiers & Bruce's relative density modifier + m.mort= m.mort * smort.sbw.mod * (1/ssurv.thin.mod) * rdMod.dMORT_RDmod) + + # tree level survival + tree.list=tree.list %>% # + dplyr::mutate(rec.id=seq(1:n())) # add record id; # could also use fvs.tree.index + + tree.mort=tree.list %>% # + dplyr::transmute(rec.id, + Region=Region, + PLOT, + TREE, + SP, + DBH, + EXPF, + CR, + HT, + ba, + BAL, + BAL.HW, + BAL.SW, + model.type=model.type, + CSI=CSI, + YEAR, + Form) %>% + dplyr::left_join(plot.mort %>% # join with plot level mortality + dplyr::select(PLOT, + m.mort, s.p0, s.p1, s.p2, s.p3, s.p4, s.p5, s.p0.region, + BAPH, + qmd, + pBF.ba, + pIHW.ba, + CDEF, + avgHT.SW, + pBArm, + BApre, + QMDratio, + YEAR_CT, + use.sbwmod, + use.thinmod, + use.hwmod), + by='PLOT') %>% + dplyr::left_join(mort.s.p0.species.random %>% # join with random parameter estimates + transmute(Species, + s.p0.species=case_when(model.type=='logistic' ~s.p0.species.logistic, + model.type=='gompit' ~s.p0.species.gompit)), + by=c('SP'='Species')) %>% + dplyr::left_join(mort.s.p1.species.random %>% + transmute(Species, + s.p1.species=case_when(model.type=='logistic' ~s.p1.species.logistic, + model.type=='gompit' ~s.p1.species.gompit)), + by=c('SP'='Species')) %>% + dplyr::mutate(s.surv = pmap_dbl(list(DBH=DBH, # calculate tree level survival probability (s) + BAL=BAL, + qmd=qmd, + Region=Region, + CSI=CSI, + model.type=model.type, + # mortality model parameter estimates + s.p0=s.p0, + s.p0.region=s.p0.region, + s.p0.species=s.p0.species, + s.p1=s.p1, + s.p1.species=s.p1.species, + s.p2=s.p2, + s.p3=s.p3, + s.p4=s.p4, + s.p5=s.p5), + surv_tree)) + + # calculate tree level mortality modifiers + + tree.mort= tree.mort %>% + #spruce budworm tree mortality modifier + dplyr::mutate(tsurv.sbw.mod=ifelse(use.sbwmod==F, 1, + pmap_dbl(list(Region=Region, + SPP=SP, + DBH=DBH, + CR=CR, + HT=HT, + BAL.HW=BAL.HW, + BAL.SW=BAL.SW, + avgHT.SW=avgHT.SW, + CDEF=CDEF), + tsurv_sbw_mod)), + # thinning tree mortality modifier + tsurv.thin.mod=ifelse(use.thinmod==F, 1, + pmap_dbl(list(SPP = SP, + PERCBArm = pBArm, + BApre = BApre, + QMDratio = QMDratio, + YEAR_CT = YEAR_CT, + YEAR = YEAR), + tsurv_thin_mod)), + # hardwood tree mortality modifier (survival probability) + tsurv.hw.mod=ifelse(use.hwmod==F | + is.null(Form)| + is.na(Form), + 1, + pmap_dbl(list(SPP=SP, + DBH=DBH, + Form=Form, + BAL=BAL, + BA=BAPH), + tsurv_hw_mod)), + #apply modifiers + s.surv=s.surv*tsurv.sbw.mod*(1/tsurv.thin.mod)*tsurv.hw.mod, + s.surv=case_when(s.surv>1 ~1, # constrain to range of zero to one + s.surv<0 ~0, + TRUE ~s.surv))%>% + dplyr::group_by(PLOT) %>% + dplyr::arrange(s.surv, by.group=T) # s ranked lowest to highest + + # stand level mortality disaggregation using ratio approach + tree.mort=tree.mort %>% # grouped tree list + dplyr::mutate(s.mort.ba = ba * (1-s.surv), + r.mort=case_when(m.mort>0 ~m.mort/sum(s.mort.ba, na.rm=T), + TRUE ~0), + dBa=r.mort*s.mort.ba, + dEXPF=dBa/ba*EXPF, + dEXPF=case_when(dEXPF>EXPF ~EXPF, # constrain dEXPF to range of zero to EXPF + dEXPF<0 | is.na(dEXPF) ~0, + TRUE ~dEXPF)) %>% + dplyr::ungroup() + + tree.list=tree.list %>% + dplyr::left_join(tree.mort %>% + dplyr::select(rec.id, dEXPF), + by='rec.id') + + tree.list } - tmorta=(1-exp(-exp(b1+b2*CR+(b3.BF*BF+b3.BS.RS*BS.RS+b3.WS*WS)*DBH+b4*avgHT.SW+ - (b5.BF*BF+b5.BS.RS*BS.RS+b5.WS*WS)*(HT/avgHT.SW)+b6*BAL.SW+b7*BAL.HW+ - (b8.BF*BF+b8.BS.RS*BS.RS+b8.WS*WS)*0))) - tmortb=(1-exp(-exp(b1+b2*CR+(b3.BF*BF+b3.BS.RS*BS.RS+b3.WS*WS)*DBH+b4*avgHT.SW+ - (b5.BF*BF+b5.BS.RS*BS.RS+b5.WS*WS)*(HT/avgHT.SW)+b6*BAL.SW+b7*BAL.HW+ - (b8.BF*BF+b8.BS.RS*BS.RS+b8.WS*WS)*CDEF2))) - tmort.mod=ifelse(is.na(CDEF) | SPP!='BF' & SPP!='RS' & SPP!='BS' & SPP!='WS',1.0,(1-tmortb)/(1-tmorta)) - return(tmort.mod) -} - -#tree.mort.mod.SBW(Region='ME',SPP='RM',DBH=20,CR=0.5,HT=15,BAL.HW=10,BAL.SW=10,avgHT.SW=10,CDEF=200) + +#### mortality modifiers ### + # SBW mortality modifier: stand level + smort_sbw_mod=function(Region, BA, BA.BF, topht, CDEF) + { + if(Region=='ME') + { + b1=-2.6380 + b2=0.0114 + b3=-0.0076 + b4=0.0074 + } + else if(Region=='NB') + { + b1=-3.0893 + b2=0.0071 + b3=-0.0037 + b4=0.0 + } + else + { + b1=-2.6380 + b2=0.0114 + b3=-0.0076 + b4=0.0074 + } + VOL=(topht/2)*BA + pBF=BA.BF/BA + aa=(1/(1+exp(-b1)))*(1/(1+exp(-(b2*0*BA.BF+b3*VOL+b4*0)))) + bb=(1/(1+exp(-b1)))*(1/(1+exp(-(b2*CDEF*BA.BF+b3*VOL+b4*CDEF)))) + rat=ifelse(is.na(CDEF),1,bb/aa) + + # result is mortality probability multiplier value >=1 + return(rat=rat) + } -#HW mortality modifier from Castle et al. (2017) -HW.mort.mod=function(SPP,DBH,BAL,BA,Form){ - # check for valid species and form codes - if(is.na(Form) | !(gsub('[^0-9]', '', Form) %in% 1:8) | - !SPP %in% c('RO', 'SM', 'YB', 'RM', 'PB', 'QA')){ - mod=1 - }else{ - #Convert NHRI form classes - if(Form == 'F1'){new.Form = 'STM'} - else if(Form == 'F2'){new.Form = 'SWP'} - else if(Form == 'F5' | Form == 'F8'){new.Form = 'MST'} - else{new.Form = 'OTHER'} - - if(SPP=='RO'){SPP.RO=1; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} - else if(SPP=='SM'){SPP.SM=1; SPP.RO=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} - else if(SPP=='YB'){SPP.YB=1; SPP.RO=0; SPP.SM=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} - else if(SPP=='RM'){SPP.RM=1; SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.QA=0; SPP.PB=0} - #else if(SPP=='PB'){SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=1} I think this can be removed since PB is baseline species (intercept term) - else if(SPP=='QA'){SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=1; SPP.PB=0} - else{SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} #PB will take on a value of 0 - if(new.Form=='STM'){STM=1; SWP=0; MST=0} - else if(new.Form =='SWP'){STM=0; SWP=1; MST=0} - else{STM=0; SWP=0; MST=0} - - mort.a=exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ - 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + - 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082)/(1+exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ - 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + - 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082)) - - mort.b=exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ - 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + - 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082*STM+2.2518*SWP)/(1 + exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ - 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082*STM+2.2518*SWP)) + # SBW survival modifier: tree record (Cen et al. 2016) + # ? Cen Chen, Aaron Weiskittel, Mohammad Bataineh, and David A. MacLean. 2017. Even low levels of spruce budworm defoliation affect mortality and ingrowth but net growth is more driven by competition. Canadian Journal of Forest Research. 47(11): 1546-1556. https://doi.org/10.1139/cjfr-2017-0012 + # C Chen, A Weiskittel, M Bataineh, DA MacLean. 2017. Evaluating the influence of varying levels of spruce budworm defoliation on annualized individual tree growth and mortality in Maine, USA and New Brunswick, Canada + # Forest Ecology and Management 396:184-194. https://doi.org/10.1016/j.foreco.2017.03.026 . + tsurv_sbw_mod=function(Region,SPP,DBH,CR,HT,BAL.HW,BAL.SW,avgHT.SW,CDEF=NA) + { + BF=ifelse(SPP=='BF',1,0) + BS.RS=ifelse(SPP=='BS'|SPP=='RS',1,0) + WS=ifelse(SPP=='WS',1,0) + CDEF2=ifelse(is.na(CDEF),0,CDEF) + if(Region=='ME') + { + b1=-6.5208 + b2=-0.4866 + b3.BF=-0.0355 + b3.BS.RS=-0.1231 + b3.WS=-0.1755 + b4=0.0316 + b5.BF=1.5087 + b5.BS.RS=1.5087 + b5.WS=1.5087 + b6=-0.0175 + b7=0.0274 + b8.BF=0.0040 + b8.BS.RS=0.0056 + b8.WS=0.0207 + } + else if(Region=='NB') + { + b1=-6.8310 + b2=0.0 + b3.BF=-0.2285 + b3.BS.RS=-0.2285 + b3.WS=-0.2285 + b4=0.2025 + b5.BF=2.1703 + b5.BS.RS=2.0809 + b5.WS=1.5802 + b6=0.0 + b7=0.0 + b8.BF=0.0029 + b8.BS.RS=0.0101 + b8.WS=0.0021 + } + tmorta=(1-exp(-exp(b1+b2*CR+(b3.BF*BF+b3.BS.RS*BS.RS+b3.WS*WS)*DBH+b4*avgHT.SW+ + (b5.BF*BF+b5.BS.RS*BS.RS+b5.WS*WS)*(HT/avgHT.SW)+b6*BAL.SW+b7*BAL.HW+ + (b8.BF*BF+b8.BS.RS*BS.RS+b8.WS*WS)*0))) + tmortb=(1-exp(-exp(b1+b2*CR+(b3.BF*BF+b3.BS.RS*BS.RS+b3.WS*WS)*DBH+b4*avgHT.SW+ + (b5.BF*BF+b5.BS.RS*BS.RS+b5.WS*WS)*(HT/avgHT.SW)+b6*BAL.SW+b7*BAL.HW+ + (b8.BF*BF+b8.BS.RS*BS.RS+b8.WS*WS)*CDEF2))) + tmort.mod=ifelse(is.na(CDEF) | SPP!='BF' & SPP!='RS' & SPP!='BS' & SPP!='WS',1.0,(1-tmortb)/(1-tmorta)) + + # result is survival probability (range zero to one) + return(tmort.mod) + } - mod=mort.b/mort.a} - - mod -} + # HW survival modifier: tree record from Castle et al. (2017) + tsurv_hw_mod=function(SPP,DBH,BAL,BA,Form){ + + # check for valid species and form codes + if(is.na(Form) | !(gsub('[^0-9]', '', Form) %in% 1:8) | + !SPP %in% c('RO', 'SM', 'YB', 'RM', 'PB', 'QA')){ + mod=1 + }else{ + #Convert NHRI form classes + if(Form == 'F1'){new.Form = 'STM'} + else if(Form == 'F2'){new.Form = 'SWP'} + else if(Form == 'F5' | Form == 'F8'){new.Form = 'MST'} + else{new.Form = 'OTHER'} + + if(SPP=='RO'){SPP.RO=1; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} + else if(SPP=='SM'){SPP.SM=1; SPP.RO=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} + else if(SPP=='YB'){SPP.YB=1; SPP.RO=0; SPP.SM=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} + else if(SPP=='RM'){SPP.RM=1; SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.QA=0; SPP.PB=0} + #else if(SPP=='PB'){SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=1} I think this can be removed since PB is baseline species (intercept term) + else if(SPP=='QA'){SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=1; SPP.PB=0} + else{SPP.RO=0; SPP.SM=0; SPP.YB=0; SPP.RM=0; SPP.QA=0; SPP.PB=0} #PB will take on a value of 0 + if(new.Form=='STM'){STM=1; SWP=0; MST=0} + else if(new.Form =='SWP'){STM=0; SWP=1; MST=0} + else{STM=0; SWP=0; MST=0} + + mort.a=exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ + 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + + 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082)/(1+exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ + 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + + 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082)) + + mort.b=exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ + 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + + 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082*STM+2.2518*SWP)/(1 + exp(15.1991-0.1509*DBH-0.1232*BAL-1.4053*sqrt(BA)-2.7907*SPP.QA-3.9809*SPP.RM-0.7937*SPP.RO+ + 5.2531*SPP.YB+0.0791*(DBH*SPP.QA)+0.8343*(DBH*SPP.RM) + 0.8944*(DBH*SPP.RO)+0.1528*(DBH*SPP.YB)+3.3082*STM+2.2518*SWP)) + + mod=mort.b/mort.a} + # result is survival probability (range zero to one) + mod + } -#Thinning mortality modifier for trees -tmort.thin.mod = function(SPP, PERCBArm, BApre, QMDratio, YEAR_CT, YEAR){ - TST = ifelse(is.na(YEAR_CT),0,YEAR - YEAR_CT) # time since thinning - # balsam fir - if(SPP=="BF"){ - y0=1.7414 - y1=7.0805; - y2=0.6677; - y3=0.8474 - tmort.mod=1+(exp(y0+(y1/(((100*PERCBArm+BApre)*QMDratio)+0.01)))*y2^TST*TST^y3) - } - # red spruce - else if(SPP=="RS"){ - y0=10.5057; - y1=-650.8260; - y2=0.6948; - y3=0.6429 - tmort.mod=1+(exp(y0+(y1/(((100*PERCBArm)+BApre)+0.01)))*y2^TST*TST^y3)} - - SP=ifelse(SPP=='BF' | SPP=='RS',1,0) - tmort.mod = ifelse((!is.na(YEAR_CT) & YEAR_CT <= YEAR) & SP==1,tmort.mod,1) - return(tmort.mod = tmort.mod) -} + # Thinning survival modifier: stand level + ssurv_thin_mod=function(YEAR_CT, YEAR, PERCBArm, BApre){ + + # time since thinning + TST = ifelse(is.na(YEAR_CT),0,YEAR - YEAR_CT) + + # parameter estimates + b30=-1.2402 + b31=-24.5202 + b32=-1.1302 + b33=1.5884 + y30=8.3385 + y31=-601.3096 + y32=0.5507 + y33=1.5798 + + #BAmort=exp(b30+(b31/BA)+b32*PCT+b33*pBA.BF) + mod=ifelse(!is.na(YEAR_CT) & YEAR_CT <= YEAR, + 1.0+exp(y30+(y31/((100*(PERCBArm)+BApre)+0.01)))*y32^TST*TST^y33, + 1.0) + #BAmort=BAmort*mod + + # result is survival probability multiplier value >=1 + mod + } + + # Thinning survival modifier: tree record + tsurv_thin_mod = function(SPP, PERCBArm, BApre, QMDratio, YEAR_CT, YEAR){ + # time since thinning + TST = ifelse(is.na(YEAR_CT),0,YEAR - YEAR_CT) + + # balsam fir + if(SPP=="BF"){ + y0=1.7414 + y1=7.0805; + y2=0.6677; + y3=0.8474 + tmod=1+(exp(y0+(y1/(((100*PERCBArm+BApre)*QMDratio)+0.01)))*y2^TST*TST^y3) + } + + # red spruce + else if(SPP=="RS"){ + y0=10.5057; + y1=-650.8260; + y2=0.6948; + y3=0.6429 + tmod=1+(exp(y0+(y1/(((100*PERCBArm)+BApre)+0.01)))*y2^TST*TST^y3)} + + tmod = ifelse((!is.na(YEAR_CT) & YEAR_CT <= YEAR) & SPP %in% c('BF', 'RS'), + tmod, + 1) + # result is survival probability multiplier value >=1 + + tmod + } #### Ingrowth #### ##INGROWTH FUNCTION of Li et al. (2011; CJFR 41, 2077-2089) @@ -1299,7 +1814,7 @@ ING.TreeList=function(Sum.temp,INGROWTH,MinDBH) if(nrow(TreeCon)==0 || toupper(substring(INGROWTH,1,1)) == "N") return(NULL) for(i in 1:nrow(TreeCon)) { - STAND.c=ifelse(is.null(TreeCon$STAND[i]), + STAND.c=ifelse(is.null(TreeCon$STAND[i]), 1, as.character(unique(TreeCon$STAND[i]))) PLOT.c=TreeCon$PLOT[i] @@ -1367,1424 +1882,127 @@ ING.TreeList=function(Sum.temp,INGROWTH,MinDBH) InTree1 } -the.includer.func<-function(EXPF,cum.EXPF){ - if(cum.EXPF<=100) tree.inc <-EXPF - else if((cum.EXPF+EXPF)>100 & 100-cum.EXPF>0) tree.inc <- 100-cum.EXPF - else tree.inc <-0 - return(tree.inc)} - -#### Taper #### -##Li et al. (2012) taper equations -KozakTaper=function(Bark,SPP,DHT,DBH,HT,Planted){ - if(Bark=='ob' & SPP=='AB'){ - a0_tap=1.0693567631 - a1_tap=0.9975021951 - a2_tap=-0.01282775 - b1_tap=0.3921013594 - b2_tap=-1.054622304 - b3_tap=0.7758393514 - b4_tap=4.1034897617 - b5_tap=0.1185960455 - b6_tap=-1.080697381 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='BC'){ - a0_tap=0.9802172591 - a1_tap=0.9900811022 - a2_tap=0.0215023934 - b1_tap=0.6092829761 - b2_tap=-0.54627086 - b3_tap=0.5221909952 - b4_tap=1.6561496035 - b5_tap=0.040879378 - b6_tap=-0.302807393 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='BF'){ - a0_tap=0.88075316 - a1_tap=1.01488665 - a2_tap=0.01958804 - b1_tap=0.41951756 - b2_tap=-0.67232564 - b3_tap=0.54329725 - b4_tap=1.48181152 - b5_tap=0.06470371 - b6_tap=-0.34684837 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='BF'){ - a0_tap=0.7909 - a1_tap=0.9745 - a2_tap=0.1198 - b1_tap=0.2688 - b2_tap=-0.55134 - b3_tap=0.5612 - b4_tap=0.9007 - b5_tap=0.1257 - b6_tap=-0.6708 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.87045800178728 - a1_tap=0.998148536293802 - a2_tap=0.0584816955042306 - b1_tap=0.302539012401385 - b2_tap=-0.605787065734974 - b3_tap=0.588861845770261 - b4_tap=0.8826608914125 - b5_tap=0.103280103524893 - b6_tap=-0.57432603217401 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='BP' | SPP=='BA'){ - a0_tap=1.0036248405 - a1_tap=0.744246238 - a2_tap=0.2876417207 - b1_tap=0.6634046516 - b2_tap=-2.004812235 - b3_tap=0.7507983401 - b4_tap=3.9248261105 - b5_tap=0.0276793767 - b6_tap=-0.130928845 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='BS'){ - a0_tap=0.80472902 - a1_tap=1.00804553 - a2_tap=0.05601099 - b1_tap=0.35533529 - b2_tap=-0.41320046 - b3_tap=0.41527304 - b4_tap=1.11652424 - b5_tap=0.0990167 - b6_tap=-0.40992056 - b7_tap=0.11394943 - } - else if(Bark=='ob' & SPP=='BS'){ - a0_tap=0.858 - a1_tap=0.9611 - a2_tap=0.105 - b1_tap=0.2604 - b2_tap=-0.3409 - b3_tap=0.4797 - b4_tap=0.5008 - b5_tap=0.1097 - b6_tap=-0.4952 - b7_tap=0.0969 - #parms w/ FIA data - a0_tap=0.896382313496267 - a1_tap=0.979157280469517 - a2_tap=0.07070415827334 - b1_tap=0.288205614793081 - b2_tap=-0.303580327062765 - b3_tap=0.435229599780184 - b4_tap=0.287092390832665 - b5_tap=0.0861036484421037 - b6_tap=-0.407747649433411 - b7_tap=0.371113950891855 - } - else if(Bark=='ob' & SPP=='BT'){ - a0_tap=1.0200889056 - a1_tap=1.0054957243 - a2_tap=-0.011030907 - b1_tap=0.5104511725 - b2_tap=-1.326415929 - b3_tap=0.5568665797 - b4_tap=7.2108347873 - b5_tap=0.071149738 - b6_tap=-0.571844802 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='EH'){ - a0_tap=0.960235102 - a1_tap=1.00821143 - a2_tap=-0.025167937 - b1_tap=0.825260258 - b2_tap=1.962520834 - b3_tap=0.415234319 - b4_tap=-5.061571874 - b5_tap=0.009839526 - b6_tap=-0.095533007 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='EH'){ - a0_tap=0.8681 - a1_tap=0.916 - a2_tap=0.1558 - b1_tap=0.4067 - b2_tap=-0.6163 - b3_tap=0.4177 - b4_tap=3.6257 - b5_tap=0.1686 - b6_tap=-0.8829 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.846409603849866 - a1_tap=0.984317716125905 - a2_tap=0.0807523481457474 - b1_tap=0.445438700558324 - b2_tap=-0.671467572085628 - b3_tap=0.504954501484816 - b4_tap=2.48940465528 - b5_tap=0.124152912027385 - b6_tap=-0.722954836646604 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='GA'){ - a0_tap=1.0852385488 - a1_tap=1.1861877395 - a2_tap=-0.226193745 - b1_tap=0.5198788065 - b2_tap=1.4303205202 - b3_tap=-0.349453901 - b4_tap=3.1952591271 - b5_tap=0.1391694941 - b6_tap=-0.296716822 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='GB'){ - a0_tap=1.0263926931 - a1_tap=0.8835623138 - a2_tap=0.1307522645 - b1_tap=0.6113533288 - b2_tap=-0.114188076 - b3_tap=0.2883217076 - b4_tap=2.657433495 - b5_tap=0.0590046356 - b6_tap=-0.175127606 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='JP'){ - a0_tap=0.931552701 - a1_tap=1.008192708 - a2_tap=-0.004177373 - b1_tap=0.431297353 - b2_tap=-0.863672736 - b3_tap=0.511698303 - b4_tap=2.232484834 - b5_tap=0.059865263 - b6_tap=-0.331897255 - b7_tap=0.039630786 - } - else if(Bark=='ob' & SPP=='JP'){ - a0_tap=1.0214 - a1_tap=0.9817 - a2_tap=0.0147 - b1_tap=0.3753 - b2_tap=-0.7954 - b3_tap=0.499 - b4_tap=2.0407 - b5_tap=0.0768 - b6_tap=-0.3335 - b7_tap=0.0408 - #parms w/ FIA data - a0_tap=0.842483072142665 - a1_tap=0.99279768524928 - a2_tap=0.0739425827838225 - b1_tap=0.37221919371203 - b2_tap=-0.723225866494174 - b3_tap=0.453434142074953 - b4_tap=1.33754275322832 - b5_tap=0.073372838152118 - b6_tap=-0.3105255908992 - b7_tap=0.396398949039286 - } - else if(Bark=='ib' & SPP=='NS'){ - a0_tap=0.9308817 - a1_tap=0.97360573 - a2_tap=0.03522864 - b1_tap=0.65078104 - b2_tap=-0.30355787 - b3_tap=0.37832812 - b4_tap=1.18815216 - b5_tap=0.03111631 - b6_tap=-0.03172809 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='NS'){ - a0_tap=1.0513 - a1_tap=0.9487 - a2_tap=0.0374 - b1_tap=0.611 - b2_tap=-0.3001 - b3_tap=0.3731 - b4_tap=1.1255 - b5_tap=0.0318 - b6_tap=-0.0297 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.950952303433305 - a1_tap=0.99162401049595 - a2_tap=0.0357175689757522 - b1_tap=0.507484658718266 - b2_tap=-0.44046929698967 - b3_tap=0.405856745795155 - b4_tap=1.2849978191539 - b5_tap=0.0143964536822362 - b6_tap=-0.0785889411281423 - b7_tap=0.169725200257675 - } - else if(Bark=='ib' & SPP=='PB'){ - a0_tap=0.7161229027 - a1_tap=0.9811224473 - a2_tap=0.1382539493 - b1_tap=0.4782152412 - b2_tap=0.3091537448 - b3_tap=0.3266307618 - b4_tap=-0.302056097 - b5_tap=0.0858585241 - b6_tap=-0.278661048 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='PB'){ - a0_tap=0.7161229027 - a1_tap=0.9811224473 - a2_tap=0.1382539493 - b1_tap=0.4782152412 - b2_tap=0.3091537448 - b3_tap=0.3266307618 - b4_tap=-0.302056097 - b5_tap=0.0858585241 - b6_tap=-0.278661048 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='QA'){ - a0_tap=0.5586975794 - a1_tap=0.9047841359 - a2_tap=0.3075094544 - b1_tap=0.7131251715 - b2_tap=-0.588345303 - b3_tap=0.4292045831 - b4_tap=2.8516108932 - b5_tap=0.0381609362 - b6_tap=-0.13426388 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='RM'){ - a0_tap=0.745826994 - a1_tap=1.0092251371 - a2_tap=0.0890931039 - b1_tap=0.5861620841 - b2_tap=-0.865905462 - b3_tap=0.6539243149 - b4_tap=3.0603989176 - b5_tap=0.0827619274 - b6_tap=-0.64859681 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='RM'){ - a0_tap=0.745826994 - a1_tap=1.0092251371 - a2_tap=0.0890931039 - b1_tap=0.5861620841 - b2_tap=-0.865905462 - b3_tap=0.6539243149 - b4_tap=3.0603989176 - b5_tap=0.0827619274 - b6_tap=-0.64859681 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='RO'){ - a0_tap=1.1751352376 - a1_tap=1.02249704 - a2_tap=-0.069888591 - b1_tap=0.4505675893 - b2_tap=-0.902884964 - b3_tap=0.5812519636 - b4_tap=3.6267479819 - b5_tap=0.1656137742 - b6_tap=-1.114281314 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='RP'){ - a0_tap=0.9717883 - a1_tap=1.00113806 - a2_tap=-0.01597933 - b1_tap=0.51143292 - b2_tap=-0.9739954 - b3_tap=0.25844201 - b4_tap=4.75315518 - b5_tap=0.05846224 - b6_tap=-0.12372176 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='RP'){ - a0_tap=1.0962 - a1_tap=1.006 - a2_tap=-0.0352 - b1_tap=0.5 - b2_tap=-0.9959 - b3_tap=0.3007 - b4_tap=4.6358 - b5_tap=0.0473 - b6_tap=-0.05 - b7_tap=0 - #parms w/ FIA data - a0_tap=1.06470820904747 - a1_tap=0.994899036827748 - a2_tap=-0.0123828485987216 - b1_tap=0.458957297467137 - b2_tap=-1.04575412640177 - b3_tap=0.361452014890273 - b4_tap=4.00047777431758 - b5_tap=0.0543368451581955 - b6_tap=-0.128025447306836 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='RS'){ - a0_tap=0.89797987 - a1_tap=1.00579742 - a2_tap=0.01667313 - b1_tap=0.49500865 - b2_tap=-0.63375155 - b3_tap=0.3836274 - b4_tap=1.41380994 - b5_tap=0.08866994 - b6_tap=-0.29753964 - b7_tap=0.15192029 - } - else if(Bark=='ob' & SPP=='RS'){ - a0_tap=0.8758 - a1_tap=0.992 - a2_tap=0.0633 - b1_tap=0.4128 - b2_tap=-0.6877 - b3_tap=0.4413 - b4_tap=1.1818 - b5_tap=0.1131 - b6_tap=-0.4356 - b7_tap=0.1042 - #parms w/ FIA data - a0_tap=0.886886241411388 - a1_tap=0.995431239145283 - a2_tap=0.0541365481351767 - b1_tap=0.411160410244944 - b2_tap=-0.658022227353248 - b3_tap=0.418213595349517 - b4_tap=1.09113756405639 - b5_tap=0.102379812299201 - b6_tap=-0.40367256147942 - b7_tap=0.104842994095004 - } - #Sweet birch - else if(Bark=='ob' & SPP=='SB'){ - a0_tap=0.8471057131 - a1_tap=0.9875376729 - a2_tap=0.0769690406 - b1_tap=0.9322599144 - b2_tap=-0.954580316 - b3_tap=0.48553875 - b4_tap=3.0294545606 - b5_tap=0.0767610836 - b6_tap=-0.238398236 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='SM'){ - a0_tap=1.0517056747 - a1_tap=0.96129896 - a2_tap=0.0386037512 - b1_tap=0.8556437779 - b2_tap=-0.249723079 - b3_tap=0.4149367053 - b4_tap=1.2548340569 - b5_tap=0.0412998707 - b6_tap=-0.113500099 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='TL' | SPP=='TA'){ - a0_tap=0.7387 - a1_tap=0.9716 - a2_tap=0.1431 - b1_tap=0.271 - b2_tap=-0.4958 - b3_tap=0.6508 - b4_tap=-0.3887 - b5_tap=0.1324 - b6_tap=-0.7035 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.762977580507808 - a1_tap=0.979320525735404 - a2_tap=0.122788251183516 - b1_tap=0.245935863173793 - b2_tap=-0.564901857800367 - b3_tap=0.666790795105499 - b4_tap=-0.0728778930339496 - b5_tap=0.143651487515151 - b6_tap=-0.791188036888163 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='WA'){ - a0_tap=0.8550736297 - a1_tap=0.9768941226 - a2_tap=0.0770356694 - b1_tap=0.7819090026 - b2_tap=-0.791762733 - b3_tap=0.476698925 - b4_tap=3.5003928402 - b5_tap=0.0859040469 - b6_tap=-0.487974342 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='WC' | SPP=='NC'){ - a0_tap=0.86118766 - a1_tap=0.98152118 - a2_tap=0.0568203 - b1_tap=0.40717678 - b2_tap=-0.05482572 - b3_tap=0.47809459 - b4_tap=-1.32512447 - b5_tap=0.1538487 - b6_tap=-0.53687808 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='WC' | SPP=='NC'){ - a0_tap=0.902 - a1_tap=0.9676 - a2_tap=0.085 - b1_tap=0.3204 - b2_tap=-0.4336 - b3_tap=0.5212 - b4_tap=0.0157 - b5_tap=0.137 - b6_tap=-0.4585 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.876976728762079 - a1_tap=0.972187200775237 - a2_tap=0.0905032843727524 - b1_tap=0.319643790061659 - b2_tap=-0.495778605215774 - b3_tap=0.546605647382787 - b4_tap=-0.0540118375921429 - b5_tap=0.131666046721139 - b6_tap=-0.454765563250266 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='WP'){ - a0_tap=1.04881379 - a1_tap=1.00779696 - a2_tap=-0.04595353 - b1_tap=0.38085445 - b2_tap=-0.85956463 - b3_tap=0.34380669 - b4_tap=4.60836993 - b5_tap=0.111855 - b6_tap=-0.5523203 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='WP'){ - a0_tap=1.0202 - a1_tap=0.985 - a2_tap=0.0149 - b1_tap=0.3697 - b2_tap=-0.7512 - b3_tap=0.3536 - b4_tap=3.8496 - b5_tap=0.1074 - b6_tap=-0.5131 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.961977278802905 - a1_tap=0.985977453808376 - a2_tap=0.0333180987707418 - b1_tap=0.383416881614619 - b2_tap=-0.753661988626837 - b3_tap=0.392529765236197 - b4_tap=3.4224381734935 - b5_tap=0.100601541094101 - b6_tap=-0.485617012177084 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='WS'){ - a0_tap=1.0202 - a1_tap=0.985 - a2_tap=0.0149 - b1_tap=0.3697 - b2_tap=-0.7512 - b3_tap=0.3536 - b4_tap=3.8496 - b5_tap=0.1074 - b6_tap=-0.5131 - b7_tap=0 - #parms w/ FIA data - a0_tap=0.75826241 - a1_tap=0.98481863 - a2_tap=0.09956165 - b1_tap=0.36505143 - b2_tap=-0.51501314 - b3_tap=0.55913869 - b4_tap=0.75846281 - b5_tap=0.07011851 - b6_tap=-0.44928376 - b7_tap=0.07830011 - } - else if(Bark=='ob' & SPP=='WS'){ - a0_tap=0.7317 - a1_tap=0.9577 - a2_tap=0.1593 - b1_tap=0.2638 - b2_tap=-0.4246 - b3_tap=0.5505 - b4_tap=-0.1269 - b5_tap=0.1145 - b6_tap=-0.6249 - b7_tap=0.088 - #parms w/ FIA data - a0_tap=0.725059647049259 - a1_tap=0.999930744977476 - a2_tap=0.11890841412387 - b1_tap=0.286031149725587 - b2_tap=-0.417052954651359 - b3_tap=0.581226449067082 - b4_tap=-0.562751307358532 - b5_tap=0.101380520664108 - b6_tap=-0.563774194060357 - b7_tap=0.096121529684134 - } - else if(Bark=='ob' & SPP=='YB'){ - a0_tap=1.1263776728 - a1_tap=0.9485083275 - a2_tap=0.0371321602 - b1_tap=0.7662525552 - b2_tap=-0.028147685 - b3_tap=0.2334044323 - b4_tap=4.8569609081 - b5_tap=0.0753180483 - b6_tap=-0.205052535 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='OH'){ - a0_tap=0.947211744 - a1_tap=0.971353083 - a2_tap=0.063182322 - b1_tap=0.633614831 - b2_tap=-0.549156049 - b3_tap=0.439010965 - b4_tap=3.187595496 - b5_tap=0.079154063 - b6_tap=-0.41277508 - b7_tap=0 - } - else if(Bark=='ob' & SPP=='OS'){ - a0_tap=0.88047918 - a1_tap=0.988526494 - a2_tap=0.0660791 - b1_tap=0.365548416 - b2_tap=-0.607245626 - b3_tap=0.486832282 - b4_tap=1.282373726 - b5_tap=0.094120201 - b6_tap=-0.447380533 - b7_tap=0 - } - else if(Bark=='ib' & SPP=='OS'){ - a0_tap=0.896475601 - a1_tap=1.001886257 - a2_tap=0.020707494 - b1_tap=0.391516469 - b2_tap=-0.395638544 - b3_tap=-0.011787171 - b4_tap=1.335110611 - b5_tap=0.076311559 - b6_tap=-0.286988273 - b7_tap=0 - } - else{ - a0_tap=0.896475601 - a1_tap=1.001886257 - a2_tap=0.020707494 - b1_tap=0.391516469 - b2_tap=-0.395638544 - b3_tap=-0.011787171 - b4_tap=1.335110611 - b5_tap=0.076311559 - b6_tap=-0.286988273 - b7_tap=0 - } - p = 1.3/HT - z = DHT/HT - Xi = (1 - z^(1/3))/(1 - p^(1/3)) - Qi = 1 - z^(1/3) - y = (a0_tap * (DBH^a1_tap) * (HT^a2_tap)) * Xi^(b1_tap * z^4 + b2_tap * (exp(-DBH/HT)) + - b3_tap * Xi^0.1 + b4_tap * (1/DBH) + b5_tap * HT^Qi + b6_tap * Xi + b7_tap*Planted) - Diam=ifelse(Bark=='ob' & DHT==1.37,DBH,y) - return(Diam=round(Diam,4)) -} - -DOBtoDIB=function(SPP,dob){ - if(SPP=='AB'){ - pcntbark=7 - b0_bark=1 - b1_bark=1} - else if(SPP=='BC'){ - pcntbark=10 - b0_bark=1 - b1_bark=1} - else if(SPP=='BF'){ - pcntbark=0 - b0_bark=0.878 - b1_bark=1.025} - # else if(SPP=='BP' | SPP=='BA'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 - # pcntbark=18 - # b0_bark=1 - # b1_bark=1} - else if(SPP=='BP'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 - pcntbark=0 - b0_bark=0.8737 - b1_bark=1.012} - else if(SPP=='BA'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 - pcntbark=0 - b0_bark=0.8499 - b1_bark=1.041} - else if(SPP=='BS'){ - pcntbark=0 - b0_bark=0.871 - b1_bark=1.026} - else if(SPP=='BT'){ - pcntbark=15 - b0_bark=1 - b1_bark=1} - else if(SPP=='EH'){ - pcntbark=0 - b0_bark=0.8916 - b1_bark=1.0121} - else if(SPP=='GA'){ - pcntbark=13 - b0_bark=1 - b1_bark=1} - else if(SPP=='GB'){ - pcntbark=12 - b0_bark=1 - b1_bark=1} - else if(SPP=='JP'){ - pcntbark=0 - b0_bark=0.916 - b1_bark=1.01} - else if(SPP=='NS'){ - pcntbark=0 - b0_bark=0.8558 - b1_bark=1.0363} - else if(SPP=='PB'){ - pcntbark=0 - b0_bark=0.8969 - b1_bark=1.0179} - else if(SPP=='QA'){ - pcntbark=0 - b0_bark=0.8449 - b1_bark=1.0332} - else if(SPP=='RM'){ - pcntbark=0 - b0_bark=0.9214 - b1_bark=1.0117} - else if(SPP=='RO'){ - pcntbark=11 - b0_bark=1 - b1_bark=1} - else if(SPP=='RP'){ - pcntbark=0 - b0_bark=0.928 - b1_bark=0.999} - else if(SPP=='RS'){ - pcntbark=0 - b0_bark=0.864 - b1_bark=1.029} - else if(SPP=='SB'){ - pcntbark=12 - b0_bark=1 - b1_bark=1} - else if(SPP=='SM'){ - pcntbark=0 - b0_bark=0.9383 - b1_bark=1.0064} - else if(SPP=='TL' | SPP=='TA'){ - pcntbark=0 - b0_bark=1.5106 - b1_bark=0.8134} - else if(SPP=='WA'){ - pcntbark=0 - b0_bark=0.8834 - b1_bark=1.0188} - else if(SPP=='WC' | SPP=='NC'){ - pcntbark=0 - b0_bark=0.7797 - b1_bark=1.0569} - else if(SPP=='WP'){ - pcntbark=0 - b0_bark=0.926 - b1_bark=1} - else if(SPP=='WS'){ - pcntbark=0 - b0_bark=0.886 - b1_bark=1.022} - else if(SPP=='YB'){ - pcntbark=0 - b0_bark=0.8688 - b1_bark=1.0275} - else if(SPP=='OH'){ - pcntbark=0 - b0_bark=0.892283333 - b1_bark=1.01925} - else if(SPP=='OS'){ - pcntbark=0 - b0_bark=0.887333009 - b1_bark=1.019266336} - else{ - pcntbark=0 - b0_bark=0.889808171 - b1_bark=1.019266336} - dib=ifelse(pcntbark==0,b0_bark*dob^b1_bark,dob*(1-(pcntbark/100))) - return(dib=round(dib,4)) -} +#### Prepare input tree list #### +#### -smalians<-function(r1,r2,len){ - L=(r1/2)^2*pi - S=(r2/2)^2*pi - vol=((L+S)/2)*len - return(round(vol,4)) -} +## define model species +acd.species.ht.dia=ddbh.fun.spp %>% + dplyr::inner_join(dht.fun.spp, by='Spp') %>% + dplyr::select(Spp) -KozakTreeVol=function(Bark,SPP,DBH,HT,Planted,stump=NA,topHT=NA,topD=NA) -{ - sgmts = 100 - stump=ifelse(is.na(stump),as.numeric(0.0),stump) - topHT=ifelse(is.na(topHT),as.numeric(HT),topHT) - topHT=ifelse(topHT>HT,as.numeric(HT),topHT) - topD=(ifelse(is.na(topD),as.numeric(0.001),topD)) - L = (topHT - stump)/sgmts - i = 0 - treeVolume = 0 - while (i < sgmts) - { - H1 = L * i + stump - H2 = L * (i + 1) + stump - if (HT - H1 < 1e-04){ - dob1 = 0 - dib1 = 0 - } - else { - if (H1 == 0) - H1 = 0.001 - Esty1 = KozakTaper(Bark='ob',SPP=SPP,DHT=H1,DBH=DBH,HT=HT,Planted=Planted) - dob1 = as.numeric(Esty1) - dob1 = ifelse(dob1HT,as.numeric(HT),topHT) - topD=(ifelse(is.na(topD),as.numeric(0.001),topD)) - L = (topHT-stump) / sgmts - i = 0 - treeVolume = 0 - while(i% + dplyr::filter(MGMTCD!=9, # remove snags from tree list + SP %in% acd.species, # limit to species present in model species list + DBH>0) %>% # remove tree records with DBH zero + dplyr::mutate(EXPF=EXPF*dplyr::coalesce(num.plots, 1)) # each plot as "stand" - # Add AB, QA, SM, WC - tree$ba.AB=ifelse(tree$SP=='AB',tree$ba,0) - tree$ba.QA=ifelse(tree$SP=='QA',tree$ba,0) - tree$ba.SM=ifelse(tree$SP=='SM',tree$ba,0) - tree$ba.WC=ifelse(tree$SP=='WC',tree$ba,0) + tree - tree$ba.HW=ifelse(tree$SPtype=='HW',tree$ba,0) - tree$ba.SW=ifelse(tree$SPtype!='HW',tree$ba,0) - tree$CR=((tree$HT-tree$HCB)/tree$HT)*tree$EXPF - tree$HT=tree$HT*tree$EXPF - temp <- subset(tree,select=c("YEAR","STAND","PLOT",'TREE','DBH','HT','CR', - 'EXPF',"ba",'ba.WP','ba.BF','ba.RM','ba.RS','ba.BS','ba.PB','ba.YB', - 'ba.AB','ba.QA','ba.SM','ba.WC', # Add AB, QA, SM, WC - 'ba.GB','ba.WS','sdi','ba.HW','ba.SW','SG.wt')) - temp<-groupedData(ba~ba|STAND/PLOT/YEAR,data=temp) - temp <- gsummary(temp,sum,na.rm=TRUE) - temp$BA<-temp$ba - temp$BAPH<-temp$ba - temp$tph<-temp$EXPF - temp$qmd<-sqrt(temp$BAPH/(0.00007854*temp$tph)) - temp$pHW.ba=temp$ba.HW/temp$BAPH - temp$pSW.ba=temp$ba.SW/temp$BAPH - temp$pWP.ba=temp$ba.WP/temp$BAPH - temp$pBF.ba=temp$ba.BF/temp$BAPH - temp$pRM.ba=temp$ba.RM/temp$BAPH - temp$pRS.ba=temp$ba.RS/temp$BAPH - temp$pBS.ba=temp$ba.BS/temp$BAPH - temp$pWS.ba=temp$ba.WS/temp$BAPH - temp$pPB.ba=temp$ba.PB/temp$BAPH - temp$pYB.ba=temp$ba.YB/temp$BAPH - temp$pGB.ba=temp$ba.GB/temp$BAPH +} +# arguments + # tree.list: tree list from FVS. tree.list fields TREE, SP, EXPF, CR, DBH, HT, EXPF, Form, Risk + # num.plots: number of plots in a stand + # acd.species: Acadian model species. Default species contained in the diameter and height increment parameter estimate tables (acd.species$Spp) + + +#### Prepare output tree list #### +#### for FVS fvsSetTreeAttrs() +make_fvs_tree=function(tree.list, orgtree.list, num.plots, mort.model){ + + CMtoIN = fvsUnitConversion("CMtoIN") + MtoFT = fvsUnitConversion("MtoFT") + ACRtoHA = fvsUnitConversion("ACRtoHA") + + # tree records not handled by ACD + tree.org=orgtree.list %>% + dplyr::select(TREE, + dbh=DBH, + ht=HT, + expf=EXPF, # stand level TPH + dg=DG, + htg=HTG, + mort=MORT, # stand level TPH + cratio.fvs=CRATIO) %>% + dplyr::anti_join(tree.list, + by='TREE') + + + tree=orgtree.list %>% + dplyr::select(TREE, + dbh.fvs=DBH, + ht.fvs=HT, + expf.fvs=EXPF) %>% + dplyr::left_join(tree.list, # left join excludes regeneration + by='TREE') %>% + dplyr::mutate(EXPF= EXPF/dplyr::coalesce(num.plots, 1), # calculate stand level TPH + dg=(DBH-dbh.fvs)*CMtoIN, # diameter growth + htg=(HT-ht.fvs)*MtoFT, # height growth + # set the crown ratio sign to negative so that FVS doesn't change them. + cratio = round((1-(HCB/HT))*-100, 1), # missing values set to orgtree$CRATIO + # special=as.numeric(substr(Form,2,2))*10+ # will need this when we allow Acadian model to set Form and Risk + # as.numeric(substr(Risk,2,2)), + mort=(expf.fvs-EXPF)*ACRtoHA) %>% # mortality TPH stand level + dplyr::bind_rows(tree.org) %>% # append tree records not handled by ACD + dplyr::arrange(TREE) %>% + dplyr::select(DBH,SP,dg, + htg, + cratio, + #special, + mort) + + + + if (mort.model != "Acadian") { + tree=tree %>% + dplyr::select(-mort) + } + + #tibble to dataframe + tree=as.data.frame(tree) - # Add AB, QA, SM, WC - temp$pAB.ba=temp$ba.AB/temp$BAPH - temp$pQA.ba=temp$ba.QA/temp$BAPH - temp$pSM.ba=temp$ba.SM/temp$BAPH - temp$pWC.ba=temp$ba.WC/temp$BAPH - - temp$Avg.HT=temp$HT/temp$EXPF - temp$Avg.LCR=temp$CR/temp$EXPF - temp$Avg.SG=temp$SG.wt/temp$EXPF - temp$Avg.SG=ifelse(temp$Avg.SG>.68,.68,temp$Avg.SG) - temp$SDImax=-6017.3*temp$Avg.SG+4156.3 - temp$RD=temp$sdi/temp$SDImax - temp=subset(temp,select=c("YEAR","STAND","PLOT",'BA','tph', - 'qmd','sdi','Avg.HT','Avg.LCR','pWP.ba','pBF.ba','pRM.ba', - 'pRS.ba','pBS.ba','pWS.ba','pPB.ba','pYB.ba','pGB.ba','RD', - 'pAB.ba','pQA.ba','pSM.ba','pWC.ba','pHW.ba','pSW.ba')) - temp -} + tree +} +# arguments + # tree.list: tree list output from ACD. tree.list fields YEAR; DBH; HT; HCB; EXPF; CR + # num.plots: number of plots in a stand + # orgtree.list: input tree list from FVS. orgtree.list fields TREE; DBH; HT; EXPF; DG; HTG; MORT; CRATIO + # mort.model: mortality model selected, Base or Acadian +# Note assumes EXPF is plot trees per hectare + +#### for FVS fvsAddTrees() +make_fvs_regen=function(tree.list, orgtree.list, num.plots, spcodes){ + + CMtoIN = fvsUnitConversion("CMtoIN") + MtoFT = fvsUnitConversion("MtoFT") + ACRtoHA = fvsUnitConversion("ACRtoHA") + + regen=tree.list %>% + dplyr::anti_join(orgtree.list, + by='TREE') %>% + dplyr::arrange(TREE) %>% + dplyr::mutate(EXPF= EXPF/dplyr::coalesce(num.plots, 1)) %>% # calculate stand level TPH + dplyr::transmute(dbh=dplyr::coalesce(DBH*CMtoIN, 0), + species=match(SP, spcodes[,"fvs"]), + ht= dplyr::coalesce(HT*MtoFT, 0), + cratio= dplyr::coalesce(round((1-(HCB/HT))*-100, 1), 0), + plot= as.numeric(PLOT), + tpa= EXPF*ACRtoHA) + + #tibble to dataframe + regen=as.data.frame(regen) + + regen +} +# arguments + # tree.list: tree list output from ACD. tree.list fields YEAR; DBH; HT; HCB; EXPF; CR + # num.plots: number of plots in a stand + # orgtree.list: input tree list from FVS. orgtree.list fields TREE; DBH; HT; EXPF; DG; HTG; MORT; CRATIO + # spcodes: species codes from fvsGetSpeciesCodes() +# Note assumes EXPF is plot trees per hectare #### Model execution #### ###Acadian growth and yield model @@ -2808,14 +2026,14 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) verbose = if (is.null(ops$verbose)) FALSE else ops$verbose INGROWTH = if (is.null(ops$INGROWTH)) "Y" else ops$INGROWTH MinDBH = if (is.null(ops$MinDBH)) 10 else ops$MinDBH - #cyclen = if (is.null(ops$cyclen)) 1 else ops$cyclen + #cyclen = if (is.null(ops$cyclen)) 1 else ops$cyclen cyclen = 1 # 2022-09-01 set cycle length to 1 CutPoint = if (is.null(ops$CutPoint)) 0.95 else ops$CutPoint mortType = if (is.null(ops$mortType)) "discrete" else ops$mortType maxRD = if (is.null(ops$maxRD)) 1.0 else ops$maxRD - useDBH_RDmodifier = if (is.null(ops$useDBH_RDmodifier )) TRUE else ops$useDBH_RDmodifier - useHT_RDmodifier = if (is.null(ops$useHT_RDmodifier )) TRUE else ops$useHT_RDmodifier - useMORT_RDmodifier = if (is.null(ops$useMORT_RDmodifier)) TRUE else ops$useMORT_RDmodifier + useDBH_RDmodifier = if (is.null(ops$useDBH_RDmodifier )) FALSE else ops$useDBH_RDmodifier + useHT_RDmodifier = if (is.null(ops$useHT_RDmodifier )) FALSE else ops$useHT_RDmodifier + useMORT_RDmodifier = if (is.null(ops$useMORT_RDmodifier)) FALSE else ops$useMORT_RDmodifier usedHTCap = if (is.null(ops$usedHTCap)) TRUE else ops$usedHTCap SBW = if (is.null(ops$SBW)) TRUE else ops$SBW rtnVars = if (is.null(ops$rtnVars)) c("STAND","YEAR","PLOT","TREE","SP", @@ -2832,6 +2050,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) if (exists("AcadianVersionTag") && verbose) cat("AcadianVersionTag=",AcadianVersionTag,"\n") + temp = SPP.func(tree$SP) tree$SPtype=temp$SPtype tree$shade=temp$shade @@ -2843,6 +2062,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) if (is.null(tree$SBW.YR)) tree$SBW.YR =NA if (is.null(tree$SBW.DUR)) tree$SBW.DUR=NA tree$SBW=ifelse(tree$SBW.YR>0 & tree$SBW.YR<=tree$YEAR & (tree$SBW.YR+tree$SBW.DUR)>=tree$YEAR,1,0) + tree$SBW=ifelse(is.na(tree$SBW), 0, tree$SBW) #resolves SBW value of NA tree$CDEF=tree$CDEF*tree$SBW #set thinning factors @@ -2850,6 +2070,10 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) if (is.null(tree$BApre)) tree$BApre = NA if (is.null(tree$QMDratio)) tree$QMDratio = NA if (is.null(tree$YEAR_CT)) tree$YEAR_CT = NA + ops$use.thinmod=ifelse(is.na(tree$YEAR_CT[1]), F, T) # would be better to update the customRun_fvsRunAcadian ops definition + + #hardwood modifiers + if (is.null(ops$use.hwmod)) ops$use.hwmod=T #default hw modifier set to TRUE # ingrowth ops$MinDBH= if (is.null( ops$MinDBH) || is.na( ops$MinDBH) || !is.numeric(ops$MinDBH)) 3.0 else ops$MinDBH @@ -2871,6 +2095,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) if (is.null(tree$ELEV)) tree$ELEV = ELEV tree$ELEV=ifelse(is.na(tree$ELEV), ELEV, tree$ELEV) + # need to catch tree records without valid species code tree$ba=(tree$DBH^2*0.00007854)*tree$EXPF tree$ba.SW=ifelse(tree$SPtype=='SW',tree$ba,0) @@ -2965,7 +2190,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) temp$pSM.ba=ifelse(temp$BAPH==0,0,temp$ba.SM/temp$BAPH) temp$pWC.ba=ifelse(temp$BAPH==0,0,temp$ba.WC/temp$BAPH) temp$qmd.BF=ifelse(is.na(temp$qmd.BF),0,temp$qmd.BF) - temp$DBH.RANGE=temp$maxDBH-temp$minDBH + temp$DBH.RANGE=dplyr::coalesce(temp$maxDBH-temp$minDBH, 0) temp$DBH.CV=temp$sdDBH/temp$avgDBH temp$DBH.R=temp$avgDBH*(1+(((1.6064-1.0)*1.6064)/2)*temp$DBH.CV)^1.6064 temp$meanSG=ifelse(temp$meanSG>.80,.8,temp$meanSG) @@ -3045,7 +2270,11 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) rdMod.dHT_RDmod = case_when(useHT_RDmodifier==T & RD.mod>rdMod.dHTmod_start & between(1 - rdMod.pctInRangeHt, 0 , 1) ~ 1 - rdMod.pctInRangeHt, - TRUE ~1), + TRUE ~1)) + + # mortality RD modifier add to plot summary table + Sum.temp=Sum.temp %>% + dplyr::mutate( # BLC RD MORT mods - exponential decay as it rises above rdMod.MORTmod_start (default RD > 0.55) rdMod.dMORT_RDmod = case_when(useMORT_RDmodifier==T & RD.mod>rdMod.MORTmod_start ~exp(rdMod.lamda * (RD.mod - rdMod.MORTmod_start)), @@ -3056,7 +2285,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) cat("In RDmods, Num trees where tree$RD>.9 = ",sum(tree$RD>0.9),"\n") cat("in RDmods - mean(rdMod.dDBH_RDmod) = ",mean(tree$rdMod.dDBH_RDmod),"\n") cat("in RDmods - mean(rdMod.dHT_RDmod) = ",mean(tree$rdMod.dHT_RDmod),"\n") - cat("in RDmods - mean(rdMod.dMORT_RDmod) = ",mean(tree$rdMod.dMORT_RDmod),"\n") + cat("in RDmods - mean(rdMod.dMORT_RDmod) = ",mean(Sum.temp$rdMod.dMORT_RDmod),"\n") } #form and risk @@ -3076,18 +2305,6 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) tree$pHT = as.numeric(tree$pHT) #compute plot top height - # plyr::ddply sometimes throws error; replaced with dplyr 8/18/2021 - # topht = ddply(tree,.(PLOT), function (x) - # { - # cum.EXPF = cumsum(x$EXPF) - # tree.inc = mapply(the.includer.func,x$EXPF,cum.EXPF) - # wt.HT=tree.inc*x$HT - # meanHT = mean(x$HT) - # topht = plyr::summarize(x,wt.HT=sum(wt.HT),tree.inc=sum(tree.inc)) - # topht = ifelse(topht$tree.inc > 0, topht$wt.HT/topht$tree.inc, meanHT) - # }) - # names(topht)[2] = "topht" - topht=tree %>% dplyr::group_by(PLOT) %>% @@ -3105,6 +2322,9 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) tree=merge(tree,topht,by=c('PLOT')) + + + #compute average height of softwood and hardwood species tree$HT.SW=ifelse(tree$SPtype=='SW',tree$HT,NA) tree$HT.HW=ifelse(tree$SPtype=='HW',tree$HT,NA) @@ -3115,6 +2335,15 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) tree$avgHT.SW=ifelse(is.na(tree$avgHT.SW),0,tree$avgHT.SW) tree$avgHT.HW=ifelse(is.na(tree$avgHT.HW),0,tree$avgHT.HW) + # Add top ht value and avgHT values to plot summary table + Sum.temp=Sum.temp %>% + dplyr::left_join(topht %>% + select(PLOT, + topht), + by='PLOT') %>% + dplyr::left_join(avgHT, + by='PLOT') + tree$pHCB=FALSE if (is.null(tree$CR) || any(is.na(tree$CR))) { @@ -3134,10 +2363,7 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) # maybe CR is defined on input and HCB is not, at this point CR will be defined. if (is.null(tree$HCB)) tree$HCB = tree$HT*tree$CR - #diameter increment - - tree$dBA=mapply(dBA, SPP=tree$SP, DBH=tree$DBH, BalSW=tree$BAL.SW, - BalHW=tree$BAL.HW, SI=CSI)*cyclen + #diameter increment ### tree= tree %>% #mutate(Form=NA, Risk=NA) %>% dplyr::left_join(ddbh.fun.spp, @@ -3156,6 +2382,20 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) 1)) %>% dplyr::ungroup() + # create plot summary dataframe for use in the calc_plot_ba() function + plot.smry.ba.incr=Sum.temp %>% + transmute(PLOT, + RD.mod, + pHW.ba, + BAPH, + CSI=CSI) + + #CSI=.GlobalEnv$CSI + # call wrapper function for dBA_plot_fun() and set dDBH if plot dBA is less than sum of tree level BA increment + tree=calc_plot_ba(tree.list=tree, + plot.smry = plot.smry.ba.incr) + + tree$dDBH.thin.mod=mapply(dDBH.thin.mod,SPP=tree$SP, PERCBArm = tree$pBArm, BApre=tree$BApre, QMDratio=tree$QMDratio, YEAR_CT=tree$YEAR_CT, YEAR=tree$YEAR) @@ -3210,121 +2450,34 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) # cat ("mean EXPF=",mean(tree$EXPF),"\n") # cat ("na EXPF values=", sum(is.na(tree$EXPF)), "\n") - ## Mortality - tree = ddply (tree,.(PLOT, YEAR), - function (x) - { - x = x[sort(x$DBH,decreasing=TRUE,index.return=TRUE)$ix,] - Csward1<-cumsum(x$EXPF*(0.00015+0.00218*x$SG)*((x$DBH/25)^1.605)) - bag=(((x$DBH+x$dDBH)^2*0.00007854)- - (x$DBH)^2*0.00007854)*x$EXPF - x$Sbag30=sum(ifelse(Csward1<=0.3,bag,0)) - x - }) - - tree$stand.pmort=as.vector(mapply(stand.mort.prob,Region=tree$Region,BA=tree$BAPH, - BAG=tree$Sbag30/cyclen,QMD=tree$qmd,pBA.BF=tree$pBF.ba,pBA.IH=tree$pIHW.ba)[1,]) - - tree$stand.pmort.cut=as.vector(mapply(stand.mort.prob,Region=tree$Region,BA=tree$BAPH, - BAG=tree$Sbag30/cyclen, QMD=tree$qmd,pBA.BF=tree$pBF.ba,pBA.IH=tree$pIHW.ba)[2,]) - - if (verbose) cat ("mean tree$stand.pmort=",mean(tree$stand.pmort),"\n") - if (verbose) cat ("mean tree$stand.pmort.cut=",mean(tree$stand.pmort.cut),"\n") + ## Mortality ### + # add values to plot summary (Sum.temp) table + Sum.temp=Sum.temp %>% + dplyr::mutate(CDEF=tree$CDEF[1], + Region=tree$Region[1], + use.sbwmod=as.logical(tree$SBW[1]), + SBW.YR=tree$SBW.YR[1], + SBW.DUR=tree$SBW.DUR[1], + use.thinmod=ops$use.thinmod[1], + use.hwmod=ops$use.hwmod[1], + use.rdmod=useMORT_RDmodifier, + YEAR_CT= tree$YEAR_CT[1], + QMDratio= tree$QMDratio[1], + YEAR=tree$YEAR[1], + pBArm= tree$pBArm[1], + BApre= tree$BApre[1], + CSI=CSI) + + # in future updates these values should probably not be included in the tree table + + tree=calc_mortality(tree.list=tree, + plot.smry=Sum.temp, + model.type='gompit', + v=0.4) # + + # v=0.72, Cen Chen 5/31/2022 threshold value "optimized across regions" ) - tree$pmort = mapply(function(threshold, prmortgt0) - { - w = 1 - # prmortgt0 == 1 is OK here because v can be Inf. - v = (prmortgt0*w)/(1-prmortgt0) - qbeta(threshold, v, w, lower.tail = FALSE) - },threshold=tree$stand.pmort.cut,prmortgt0=tree$stand.pmort) - - tree$stand.mort.BA=mapply(stand.mort.BA,Region=tree$Region,BA=tree$BAPH, - BAG=tree$Sbag30/cyclen,QMD=tree$qmd,tree$qmd.BF,pBA.bf=tree$pBF.ba, - pBA.ih=tree$pIHW.ba) - - tree$smort.thin.mod=mapply(BAmort.stand,BA=tree$BAPH, PCT=0, YEAR_CT=tree$YEAR_CT, - YEAR=tree$YEAR, PERCBArm=tree$pBArm, BApre=tree$BApre, QMDratio=tree$QMDratio) - if (verbose) cat ("mean tree$smort.thin.mod=",mean(tree$smort.thin.mod),"\n") - - tree$smort.SBW.mod=mapply(SBW.smort.mod,Region=tree$Region,BA=tree$BAPH, - BA.BF=tree$pBF.ba*tree$BAPH,topht=tree$topht,CDEF=tree$CDEF) - if (verbose) cat ("mean tree$smort.SBW.mod=",mean(tree$smort.SBW.mod),"\n") - - - tree$stand.mort.BA = if (mortType == "discrete") - { - tree.mort.lamda = -0.05 - # BLC - change cyclen mortaltiy calculation AND add RD mort modifier - ifelse((tree$stand.pmort^(1/cyclen)) > - tree$stand.pmort.cut^(1/cyclen), - tree$stand.mort.BA*tree$smort.thin.mod*tree$smort.SBW.mod - * (cyclen * exp(tree.mort.lamda * (cyclen - 1))) * tree$rdMod.dMORT_RDmod, 0) - } else { - # Crookston's alternative continuous - w=1 - pmort = qbeta(tree$stand.pmort.cut, - (tree$stand.pmort*w)/(1-tree$stand.pmort), w, lower.tail = FALSE) - if (verbose) cat ("mean pmort (continuous)=",mean(pmort)," sd=",sd(pmort),"\n") - tree$stand.mort.BA*tree$smort.thin.mod*tree$smort.SBW.mod*pmort - } - - - #spruce budworm mortality modifier - tree$tsurv.SBW.mod=mapply(tree.mort.mod.SBW,Region=tree$Region,SPP=tree$SP, - DBH=tree$DBH,CR=tree$CR,HT=tree$HT,BAL.HW=tree$BAL.HW,BAL.SW=tree$BAL.SW, - avgHT.SW=tree$avgHT.SW,CDEF=tree$CDEF) - if (verbose) cat ("mean tree$tsurv.SBW.mod=",mean(tree$tsurv.SBW.mod),"\n") - - tree$tmort.thin.mod=mapply(tmort.thin.mod, SPP=tree$SP, PERCBArm = tree$pBArm, - BApre=tree$BApre, QMDratio=tree$QMDratio, YEAR_CT=tree$YEAR_CT, YEAR=tree$YEAR) - if (verbose) cat ("mean tree$tmort.thin.mod=",mean(tree$tmort.thin.mod),"\n") - - tree$tmort.HW.mod=if (!is.null(tree$Form)) ifelse(is.na(tree$Form),1, - mapply(HW.mort.mod,SPP=tree$SP,DBH=tree$DBH,Form=tree$Form,BAL=tree$BAL,BA=tree$BAPH)) else 1 - tree.surv.lamda = 0.0 - tree$tsurv=pmax(0,pmin(1-(1-mapply(tree.mort.prob,tree$SP,tree$DBH)*(exp(tree.surv.lamda*(cyclen-1))))* - tree$tsurv.SBW.mod*tree$tmort.thin.mod*tree$tmort.HW.mod,1.0)) # BLC - added in HW.mod to match AW 9.5/9.6 code - - # tree$mortBA=((tree$DBH+(tree$dDBH))^2*0.00007854)*tree$EXPF*(1-tree$tsurv) - # - # tree = ddply (tree,.(PLOT), - # function (x) - # { - # # sort the trees on the plot on increasing survivorship - # #x = x[sort(x$tsurv,decreasing=FALSE,index.return=TRUE)$ix,] - # x = dplyr::arrange(x, tsurv, DBH) # 12/21/2020 replaced x = sort.data.frame(x,~+tsurv+DBH) - # x$bb=sum(x$mortBA) # plot sum of tree ba mortality - # x$cc=ifelse(x$stand.mort.BA>0,x$bb/x$stand.mort.BA,0) # plot sum of tree ba mortality / stand ba mortality - # x$dd=ifelse(x$stand.mort.BA>0,x$mortBA/x$cc,0) # tree ba mortality / above ratio - # x$ba.mort=0.00007854*(x$DBH+x$dDBH)^2 # tree basal area (not per acre) - # x$dEXPF=ifelse(x$stand.mort.BA>0,x$dd/x$ba.mort,0) - # x$EXPF.ba=(((x$DBH+(x$dDBH))^2*0.00007854)*x$dEXPF) - # x$Dead=sum(x$EXPF.ba) - # x - # }) - # - # tree$dEXPF2=tree$EXPF*((1-tree$tsurv)*tree$stand.pmort) - - - tree=tree %>% # 9/10/2021 updated mortality calculation execution - dplyr::mutate(stand.mort.BA=case_when(stand.mort.BA>BAPH ~BAPH, # constrain stand BA mortality to total stand BA - TRUE ~stand.mort.BA), - tree.mortBA=((DBH+dDBH)^2*0.00007854)*EXPF*(1-tsurv)) %>% - dplyr::group_by(PLOT) %>% - dplyr::mutate(sum.tree.mortBA=sum(tree.mortBA)) %>% # plot sum of tree ba mortality - dplyr::ungroup() %>% - dplyr::mutate(cc=ifelse(stand.mort.BA>0, sum.tree.mortBA/stand.mort.BA, 0), # plot sum of tree ba mortality / stand ba mortality - dd=ifelse(stand.mort.BA>0, tree.mortBA/cc, 0), # tree ba mortality / tree-stand mortality ratio - ba.mort=(0.00007854*(DBH+dDBH)^2), # tree basal area - dEXPF=ifelse(stand.mort.BA>0, dd/ba.mort,0)) - # unused variables - # EXPF.ba=(((DBH+dDBH)^2*0.00007854)*dEXPF)) - # Dead=sum(EXPF.ba)) - # dEXPF2=EXPF*((1-tsurv)*stand.pmort) - - ##INGROWTH ingrow = NULL @@ -3396,62 +2549,1434 @@ AcadianGYOneStand <- function(tree,stand=NULL,ops=NULL) } #Update tree values - tree$YEAR <- tree$YEAR+cyclen - tree$DBH <- tree$DBH+tree$dDBH - tree$HT <- tree$HT+tree$dHT - tree$HCB <- tree$HCB + tree$dHCB - if (any(is.na(tree$EXPF))) tree$EXPF [is.na(tree$EXPF)] = 0 - if (any(is.na(tree$dEXPF))) tree$dEXPF[is.na(tree$dEXPF)] = 0 - tree$EXPF <- tree$EXPF-tree$dEXPF - tree$EXPF[tree$EXPF<.00001] = .00001 - tree$CR=(tree$HT-tree$HCB)/tree$HT - tree=dplyr::bind_rows(tree,ingrow) + tree=tree %>% + dplyr::mutate(YEAR= YEAR+1, + DBH= DBH+ dplyr::coalesce(dDBH, 0), + HT= HT+ dplyr::coalesce(dHT, 0), + HCB= HCB + dplyr::coalesce(dHCB, 0), + EXPF= dplyr::coalesce(EXPF, 0) - dplyr::coalesce(dEXPF, 0), + EXPF= ifelse(EXPF< 0.00001, 0.00001, EXPF), + CR= (HT - HCB)/ HT) %>% + dplyr::bind_rows(ingrow) + - #tree$DBH.10=ifelse(tree$DBH>=10,tree$DBH,0) - #tree$SDIadd=(tree$DBH.10/25.4)^1.605*tree$EXPF - # - # temp = SPP.func(tree$SP) - # tree$SPtype=temp$SPtype - # tree$shade=temp$shade - # tree$SG=temp$sg - # - # tree$ba=(tree$DBH^2*0.00007854)*tree$EXPF - # tree$ba.SW=ifelse(tree$SPtype=='SW',tree$ba,0) - # tree$SG.wt=tree$SG*tree$ba - # tree$DBH.SW=ifelse(tree$SPtype=='SW',tree$DBH,0) - # - # temp=ddply(tree,.(PLOT),plyr::summarize,ELEV=mean(ELEV,na.rm=T),BAPH=sum(ba,na.rm=T),tph=sum(EXPF),meanSG=sum(SG.wt)/sum(ba),ba.SW=sum(ba.SW,na.rm=T), - # SDI=sum(SDIadd,na.rm=T),avgDBH.SW=mean(DBH.SW,na.rm=T),avgDBH=mean(DBH.10,na.rm=T),sdDBH=sd(DBH.10,na.rm=T), - # SPP.DIV=length(unique(SP)),minDBH=min(DBH.10,na.rm=T),maxDBH=max(DBH.10,na.rm=T)) - # - # temp$pSW.ba=temp$ba.SW/temp$BAPH - # temp$pHW.ba=1-temp$pSW.ba - # temp$avgDBH.SW=ifelse(is.na(temp$avgDBH.SW),0,temp$avgDBH.SW) - # temp$DBH.RANGE=temp$maxDBH-temp$minDBH - # temp$DBH.CV=temp$sdDBH/temp$avgDBH - # temp$DBH.R=temp$avgDBH*(1+(((1.6064-1.0)*1.6064)/2)*temp$DBH.CV)^1.6064 - # temp$meanSG=ifelse(temp$meanSG>.80,.8,temp$meanSG) - # temp$SDImax=483.2448-1.4563*temp$pHW.ba-212.705*log(temp$meanSG)+45.351* - # sqrt(temp$DBH.RANGE)+14.811*temp$SPP.DIV-0.0848*temp$ELEV+0.0001* - # temp$ELEV^2+331.3714*(1/CSI) - # temp$SDImax2= 1347.445-1003.870*temp$meanSG #Weiskittel and Kuehne (2019) - # #temp$SDImax2=-6017.3*temp$meanSG+4156.3 - # temp$SDImax=ifelse(is.na(temp$SDImax),temp$SDImax2,temp$SDImax) - # temp$RD=temp$SDI/temp$SDImax - # temp$RD.flag=ifelse(temp$RD>=maxRD,1,0) - # temp$SDI2=temp$SDImax*maxRD*temp$RD.flag - # temp$SDIrat=temp$SDI2/temp$SDI - # - # Sum.temp=temp - # rtnVars=intersect(rtnVars,colnames(tree)) - # tree<-subset(tree,select=rtnVars) - # tree=merge(tree,Sum.temp,by="PLOT") - # tree$DBH.10=ifelse(tree$DBH>=10,tree$DBH,0) - # tree$SDIadd=(tree$DBH.10/25.4)^1.6*tree$EXPF - # tree$SDI.new=ifelse(tree$RD.flag==1,tree$SDIadd*tree$SDIrat,tree$SDIadd) - # tree$EXPF=ifelse(tree$RD.flag==1,(25.4^1.605*tree$SDI.new)/(tree$DBH^1.605),tree$EXPF) rtnVars=intersect(rtnVars,colnames(tree)) - tree<-subset(tree,select=rtnVars) + tree=subset(tree, + select=rtnVars) %>% + as.data.frame() } + + +#### Taper #### +##Li et al. (2012) taper equations +KozakTaper=function(Bark,SPP,DHT,DBH,HT,Planted){ + if(Bark=='ob' & SPP=='AB'){ + a0_tap=1.0693567631 + a1_tap=0.9975021951 + a2_tap=-0.01282775 + b1_tap=0.3921013594 + b2_tap=-1.054622304 + b3_tap=0.7758393514 + b4_tap=4.1034897617 + b5_tap=0.1185960455 + b6_tap=-1.080697381 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='BC'){ + a0_tap=0.9802172591 + a1_tap=0.9900811022 + a2_tap=0.0215023934 + b1_tap=0.6092829761 + b2_tap=-0.54627086 + b3_tap=0.5221909952 + b4_tap=1.6561496035 + b5_tap=0.040879378 + b6_tap=-0.302807393 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='BF'){ + a0_tap=0.88075316 + a1_tap=1.01488665 + a2_tap=0.01958804 + b1_tap=0.41951756 + b2_tap=-0.67232564 + b3_tap=0.54329725 + b4_tap=1.48181152 + b5_tap=0.06470371 + b6_tap=-0.34684837 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='BF'){ + a0_tap=0.7909 + a1_tap=0.9745 + a2_tap=0.1198 + b1_tap=0.2688 + b2_tap=-0.55134 + b3_tap=0.5612 + b4_tap=0.9007 + b5_tap=0.1257 + b6_tap=-0.6708 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.87045800178728 + a1_tap=0.998148536293802 + a2_tap=0.0584816955042306 + b1_tap=0.302539012401385 + b2_tap=-0.605787065734974 + b3_tap=0.588861845770261 + b4_tap=0.8826608914125 + b5_tap=0.103280103524893 + b6_tap=-0.57432603217401 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='BP' | SPP=='BA'){ + a0_tap=1.0036248405 + a1_tap=0.744246238 + a2_tap=0.2876417207 + b1_tap=0.6634046516 + b2_tap=-2.004812235 + b3_tap=0.7507983401 + b4_tap=3.9248261105 + b5_tap=0.0276793767 + b6_tap=-0.130928845 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='BS'){ + a0_tap=0.80472902 + a1_tap=1.00804553 + a2_tap=0.05601099 + b1_tap=0.35533529 + b2_tap=-0.41320046 + b3_tap=0.41527304 + b4_tap=1.11652424 + b5_tap=0.0990167 + b6_tap=-0.40992056 + b7_tap=0.11394943 + } + else if(Bark=='ob' & SPP=='BS'){ + a0_tap=0.858 + a1_tap=0.9611 + a2_tap=0.105 + b1_tap=0.2604 + b2_tap=-0.3409 + b3_tap=0.4797 + b4_tap=0.5008 + b5_tap=0.1097 + b6_tap=-0.4952 + b7_tap=0.0969 + #parms w/ FIA data + a0_tap=0.896382313496267 + a1_tap=0.979157280469517 + a2_tap=0.07070415827334 + b1_tap=0.288205614793081 + b2_tap=-0.303580327062765 + b3_tap=0.435229599780184 + b4_tap=0.287092390832665 + b5_tap=0.0861036484421037 + b6_tap=-0.407747649433411 + b7_tap=0.371113950891855 + } + else if(Bark=='ob' & SPP=='BT'){ + a0_tap=1.0200889056 + a1_tap=1.0054957243 + a2_tap=-0.011030907 + b1_tap=0.5104511725 + b2_tap=-1.326415929 + b3_tap=0.5568665797 + b4_tap=7.2108347873 + b5_tap=0.071149738 + b6_tap=-0.571844802 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='EH'){ + a0_tap=0.960235102 + a1_tap=1.00821143 + a2_tap=-0.025167937 + b1_tap=0.825260258 + b2_tap=1.962520834 + b3_tap=0.415234319 + b4_tap=-5.061571874 + b5_tap=0.009839526 + b6_tap=-0.095533007 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='EH'){ + a0_tap=0.8681 + a1_tap=0.916 + a2_tap=0.1558 + b1_tap=0.4067 + b2_tap=-0.6163 + b3_tap=0.4177 + b4_tap=3.6257 + b5_tap=0.1686 + b6_tap=-0.8829 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.846409603849866 + a1_tap=0.984317716125905 + a2_tap=0.0807523481457474 + b1_tap=0.445438700558324 + b2_tap=-0.671467572085628 + b3_tap=0.504954501484816 + b4_tap=2.48940465528 + b5_tap=0.124152912027385 + b6_tap=-0.722954836646604 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='GA'){ + a0_tap=1.0852385488 + a1_tap=1.1861877395 + a2_tap=-0.226193745 + b1_tap=0.5198788065 + b2_tap=1.4303205202 + b3_tap=-0.349453901 + b4_tap=3.1952591271 + b5_tap=0.1391694941 + b6_tap=-0.296716822 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='GB'){ + a0_tap=1.0263926931 + a1_tap=0.8835623138 + a2_tap=0.1307522645 + b1_tap=0.6113533288 + b2_tap=-0.114188076 + b3_tap=0.2883217076 + b4_tap=2.657433495 + b5_tap=0.0590046356 + b6_tap=-0.175127606 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='JP'){ + a0_tap=0.931552701 + a1_tap=1.008192708 + a2_tap=-0.004177373 + b1_tap=0.431297353 + b2_tap=-0.863672736 + b3_tap=0.511698303 + b4_tap=2.232484834 + b5_tap=0.059865263 + b6_tap=-0.331897255 + b7_tap=0.039630786 + } + else if(Bark=='ob' & SPP=='JP'){ + a0_tap=1.0214 + a1_tap=0.9817 + a2_tap=0.0147 + b1_tap=0.3753 + b2_tap=-0.7954 + b3_tap=0.499 + b4_tap=2.0407 + b5_tap=0.0768 + b6_tap=-0.3335 + b7_tap=0.0408 + #parms w/ FIA data + a0_tap=0.842483072142665 + a1_tap=0.99279768524928 + a2_tap=0.0739425827838225 + b1_tap=0.37221919371203 + b2_tap=-0.723225866494174 + b3_tap=0.453434142074953 + b4_tap=1.33754275322832 + b5_tap=0.073372838152118 + b6_tap=-0.3105255908992 + b7_tap=0.396398949039286 + } + else if(Bark=='ib' & SPP=='NS'){ + a0_tap=0.9308817 + a1_tap=0.97360573 + a2_tap=0.03522864 + b1_tap=0.65078104 + b2_tap=-0.30355787 + b3_tap=0.37832812 + b4_tap=1.18815216 + b5_tap=0.03111631 + b6_tap=-0.03172809 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='NS'){ + a0_tap=1.0513 + a1_tap=0.9487 + a2_tap=0.0374 + b1_tap=0.611 + b2_tap=-0.3001 + b3_tap=0.3731 + b4_tap=1.1255 + b5_tap=0.0318 + b6_tap=-0.0297 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.950952303433305 + a1_tap=0.99162401049595 + a2_tap=0.0357175689757522 + b1_tap=0.507484658718266 + b2_tap=-0.44046929698967 + b3_tap=0.405856745795155 + b4_tap=1.2849978191539 + b5_tap=0.0143964536822362 + b6_tap=-0.0785889411281423 + b7_tap=0.169725200257675 + } + else if(Bark=='ib' & SPP=='PB'){ + a0_tap=0.7161229027 + a1_tap=0.9811224473 + a2_tap=0.1382539493 + b1_tap=0.4782152412 + b2_tap=0.3091537448 + b3_tap=0.3266307618 + b4_tap=-0.302056097 + b5_tap=0.0858585241 + b6_tap=-0.278661048 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='PB'){ + a0_tap=0.7161229027 + a1_tap=0.9811224473 + a2_tap=0.1382539493 + b1_tap=0.4782152412 + b2_tap=0.3091537448 + b3_tap=0.3266307618 + b4_tap=-0.302056097 + b5_tap=0.0858585241 + b6_tap=-0.278661048 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='QA'){ + a0_tap=0.5586975794 + a1_tap=0.9047841359 + a2_tap=0.3075094544 + b1_tap=0.7131251715 + b2_tap=-0.588345303 + b3_tap=0.4292045831 + b4_tap=2.8516108932 + b5_tap=0.0381609362 + b6_tap=-0.13426388 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='RM'){ + a0_tap=0.745826994 + a1_tap=1.0092251371 + a2_tap=0.0890931039 + b1_tap=0.5861620841 + b2_tap=-0.865905462 + b3_tap=0.6539243149 + b4_tap=3.0603989176 + b5_tap=0.0827619274 + b6_tap=-0.64859681 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='RM'){ + a0_tap=0.745826994 + a1_tap=1.0092251371 + a2_tap=0.0890931039 + b1_tap=0.5861620841 + b2_tap=-0.865905462 + b3_tap=0.6539243149 + b4_tap=3.0603989176 + b5_tap=0.0827619274 + b6_tap=-0.64859681 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='RO'){ + a0_tap=1.1751352376 + a1_tap=1.02249704 + a2_tap=-0.069888591 + b1_tap=0.4505675893 + b2_tap=-0.902884964 + b3_tap=0.5812519636 + b4_tap=3.6267479819 + b5_tap=0.1656137742 + b6_tap=-1.114281314 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='RP'){ + a0_tap=0.9717883 + a1_tap=1.00113806 + a2_tap=-0.01597933 + b1_tap=0.51143292 + b2_tap=-0.9739954 + b3_tap=0.25844201 + b4_tap=4.75315518 + b5_tap=0.05846224 + b6_tap=-0.12372176 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='RP'){ + a0_tap=1.0962 + a1_tap=1.006 + a2_tap=-0.0352 + b1_tap=0.5 + b2_tap=-0.9959 + b3_tap=0.3007 + b4_tap=4.6358 + b5_tap=0.0473 + b6_tap=-0.05 + b7_tap=0 + #parms w/ FIA data + a0_tap=1.06470820904747 + a1_tap=0.994899036827748 + a2_tap=-0.0123828485987216 + b1_tap=0.458957297467137 + b2_tap=-1.04575412640177 + b3_tap=0.361452014890273 + b4_tap=4.00047777431758 + b5_tap=0.0543368451581955 + b6_tap=-0.128025447306836 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='RS'){ + a0_tap=0.89797987 + a1_tap=1.00579742 + a2_tap=0.01667313 + b1_tap=0.49500865 + b2_tap=-0.63375155 + b3_tap=0.3836274 + b4_tap=1.41380994 + b5_tap=0.08866994 + b6_tap=-0.29753964 + b7_tap=0.15192029 + } + else if(Bark=='ob' & SPP=='RS'){ + a0_tap=0.8758 + a1_tap=0.992 + a2_tap=0.0633 + b1_tap=0.4128 + b2_tap=-0.6877 + b3_tap=0.4413 + b4_tap=1.1818 + b5_tap=0.1131 + b6_tap=-0.4356 + b7_tap=0.1042 + #parms w/ FIA data + a0_tap=0.886886241411388 + a1_tap=0.995431239145283 + a2_tap=0.0541365481351767 + b1_tap=0.411160410244944 + b2_tap=-0.658022227353248 + b3_tap=0.418213595349517 + b4_tap=1.09113756405639 + b5_tap=0.102379812299201 + b6_tap=-0.40367256147942 + b7_tap=0.104842994095004 + } + #Sweet birch + else if(Bark=='ob' & SPP=='SB'){ + a0_tap=0.8471057131 + a1_tap=0.9875376729 + a2_tap=0.0769690406 + b1_tap=0.9322599144 + b2_tap=-0.954580316 + b3_tap=0.48553875 + b4_tap=3.0294545606 + b5_tap=0.0767610836 + b6_tap=-0.238398236 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='SM'){ + a0_tap=1.0517056747 + a1_tap=0.96129896 + a2_tap=0.0386037512 + b1_tap=0.8556437779 + b2_tap=-0.249723079 + b3_tap=0.4149367053 + b4_tap=1.2548340569 + b5_tap=0.0412998707 + b6_tap=-0.113500099 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='TL' | SPP=='TA'){ + a0_tap=0.7387 + a1_tap=0.9716 + a2_tap=0.1431 + b1_tap=0.271 + b2_tap=-0.4958 + b3_tap=0.6508 + b4_tap=-0.3887 + b5_tap=0.1324 + b6_tap=-0.7035 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.762977580507808 + a1_tap=0.979320525735404 + a2_tap=0.122788251183516 + b1_tap=0.245935863173793 + b2_tap=-0.564901857800367 + b3_tap=0.666790795105499 + b4_tap=-0.0728778930339496 + b5_tap=0.143651487515151 + b6_tap=-0.791188036888163 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='WA'){ + a0_tap=0.8550736297 + a1_tap=0.9768941226 + a2_tap=0.0770356694 + b1_tap=0.7819090026 + b2_tap=-0.791762733 + b3_tap=0.476698925 + b4_tap=3.5003928402 + b5_tap=0.0859040469 + b6_tap=-0.487974342 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='WC' | SPP=='NC'){ + a0_tap=0.86118766 + a1_tap=0.98152118 + a2_tap=0.0568203 + b1_tap=0.40717678 + b2_tap=-0.05482572 + b3_tap=0.47809459 + b4_tap=-1.32512447 + b5_tap=0.1538487 + b6_tap=-0.53687808 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='WC' | SPP=='NC'){ + a0_tap=0.902 + a1_tap=0.9676 + a2_tap=0.085 + b1_tap=0.3204 + b2_tap=-0.4336 + b3_tap=0.5212 + b4_tap=0.0157 + b5_tap=0.137 + b6_tap=-0.4585 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.876976728762079 + a1_tap=0.972187200775237 + a2_tap=0.0905032843727524 + b1_tap=0.319643790061659 + b2_tap=-0.495778605215774 + b3_tap=0.546605647382787 + b4_tap=-0.0540118375921429 + b5_tap=0.131666046721139 + b6_tap=-0.454765563250266 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='WP'){ + a0_tap=1.04881379 + a1_tap=1.00779696 + a2_tap=-0.04595353 + b1_tap=0.38085445 + b2_tap=-0.85956463 + b3_tap=0.34380669 + b4_tap=4.60836993 + b5_tap=0.111855 + b6_tap=-0.5523203 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='WP'){ + a0_tap=1.0202 + a1_tap=0.985 + a2_tap=0.0149 + b1_tap=0.3697 + b2_tap=-0.7512 + b3_tap=0.3536 + b4_tap=3.8496 + b5_tap=0.1074 + b6_tap=-0.5131 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.961977278802905 + a1_tap=0.985977453808376 + a2_tap=0.0333180987707418 + b1_tap=0.383416881614619 + b2_tap=-0.753661988626837 + b3_tap=0.392529765236197 + b4_tap=3.4224381734935 + b5_tap=0.100601541094101 + b6_tap=-0.485617012177084 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='WS'){ + a0_tap=1.0202 + a1_tap=0.985 + a2_tap=0.0149 + b1_tap=0.3697 + b2_tap=-0.7512 + b3_tap=0.3536 + b4_tap=3.8496 + b5_tap=0.1074 + b6_tap=-0.5131 + b7_tap=0 + #parms w/ FIA data + a0_tap=0.75826241 + a1_tap=0.98481863 + a2_tap=0.09956165 + b1_tap=0.36505143 + b2_tap=-0.51501314 + b3_tap=0.55913869 + b4_tap=0.75846281 + b5_tap=0.07011851 + b6_tap=-0.44928376 + b7_tap=0.07830011 + } + else if(Bark=='ob' & SPP=='WS'){ + a0_tap=0.7317 + a1_tap=0.9577 + a2_tap=0.1593 + b1_tap=0.2638 + b2_tap=-0.4246 + b3_tap=0.5505 + b4_tap=-0.1269 + b5_tap=0.1145 + b6_tap=-0.6249 + b7_tap=0.088 + #parms w/ FIA data + a0_tap=0.725059647049259 + a1_tap=0.999930744977476 + a2_tap=0.11890841412387 + b1_tap=0.286031149725587 + b2_tap=-0.417052954651359 + b3_tap=0.581226449067082 + b4_tap=-0.562751307358532 + b5_tap=0.101380520664108 + b6_tap=-0.563774194060357 + b7_tap=0.096121529684134 + } + else if(Bark=='ob' & SPP=='YB'){ + a0_tap=1.1263776728 + a1_tap=0.9485083275 + a2_tap=0.0371321602 + b1_tap=0.7662525552 + b2_tap=-0.028147685 + b3_tap=0.2334044323 + b4_tap=4.8569609081 + b5_tap=0.0753180483 + b6_tap=-0.205052535 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='OH'){ + a0_tap=0.947211744 + a1_tap=0.971353083 + a2_tap=0.063182322 + b1_tap=0.633614831 + b2_tap=-0.549156049 + b3_tap=0.439010965 + b4_tap=3.187595496 + b5_tap=0.079154063 + b6_tap=-0.41277508 + b7_tap=0 + } + else if(Bark=='ob' & SPP=='OS'){ + a0_tap=0.88047918 + a1_tap=0.988526494 + a2_tap=0.0660791 + b1_tap=0.365548416 + b2_tap=-0.607245626 + b3_tap=0.486832282 + b4_tap=1.282373726 + b5_tap=0.094120201 + b6_tap=-0.447380533 + b7_tap=0 + } + else if(Bark=='ib' & SPP=='OS'){ + a0_tap=0.896475601 + a1_tap=1.001886257 + a2_tap=0.020707494 + b1_tap=0.391516469 + b2_tap=-0.395638544 + b3_tap=-0.011787171 + b4_tap=1.335110611 + b5_tap=0.076311559 + b6_tap=-0.286988273 + b7_tap=0 + } + else{ + a0_tap=0.896475601 + a1_tap=1.001886257 + a2_tap=0.020707494 + b1_tap=0.391516469 + b2_tap=-0.395638544 + b3_tap=-0.011787171 + b4_tap=1.335110611 + b5_tap=0.076311559 + b6_tap=-0.286988273 + b7_tap=0 + } + p = 1.3/HT + z = DHT/HT + Xi = (1 - z^(1/3))/(1 - p^(1/3)) + Qi = 1 - z^(1/3) + y = (a0_tap * (DBH^a1_tap) * (HT^a2_tap)) * Xi^(b1_tap * z^4 + b2_tap * (exp(-DBH/HT)) + + b3_tap * Xi^0.1 + b4_tap * (1/DBH) + b5_tap * HT^Qi + b6_tap * Xi + b7_tap*Planted) + Diam=ifelse(Bark=='ob' & DHT==1.37,DBH,y) + return(Diam=round(Diam,4)) +} + +DOBtoDIB=function(SPP,dob){ + if(SPP=='AB'){ + pcntbark=7 + b0_bark=1 + b1_bark=1} + else if(SPP=='BC'){ + pcntbark=10 + b0_bark=1 + b1_bark=1} + else if(SPP=='BF'){ + pcntbark=0 + b0_bark=0.878 + b1_bark=1.025} + # else if(SPP=='BP' | SPP=='BA'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 + # pcntbark=18 + # b0_bark=1 + # b1_bark=1} + else if(SPP=='BP'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 + pcntbark=0 + b0_bark=0.8737 + b1_bark=1.012} + else if(SPP=='BA'){ # BLC 09/10/2018 - implement new parameters from J.Frank 09/12/2016 + pcntbark=0 + b0_bark=0.8499 + b1_bark=1.041} + else if(SPP=='BS'){ + pcntbark=0 + b0_bark=0.871 + b1_bark=1.026} + else if(SPP=='BT'){ + pcntbark=15 + b0_bark=1 + b1_bark=1} + else if(SPP=='EH'){ + pcntbark=0 + b0_bark=0.8916 + b1_bark=1.0121} + else if(SPP=='GA'){ + pcntbark=13 + b0_bark=1 + b1_bark=1} + else if(SPP=='GB'){ + pcntbark=12 + b0_bark=1 + b1_bark=1} + else if(SPP=='JP'){ + pcntbark=0 + b0_bark=0.916 + b1_bark=1.01} + else if(SPP=='NS'){ + pcntbark=0 + b0_bark=0.8558 + b1_bark=1.0363} + else if(SPP=='PB'){ + pcntbark=0 + b0_bark=0.8969 + b1_bark=1.0179} + else if(SPP=='QA'){ + pcntbark=0 + b0_bark=0.8449 + b1_bark=1.0332} + else if(SPP=='RM'){ + pcntbark=0 + b0_bark=0.9214 + b1_bark=1.0117} + else if(SPP=='RO'){ + pcntbark=11 + b0_bark=1 + b1_bark=1} + else if(SPP=='RP'){ + pcntbark=0 + b0_bark=0.928 + b1_bark=0.999} + else if(SPP=='RS'){ + pcntbark=0 + b0_bark=0.864 + b1_bark=1.029} + else if(SPP=='SB'){ + pcntbark=12 + b0_bark=1 + b1_bark=1} + else if(SPP=='SM'){ + pcntbark=0 + b0_bark=0.9383 + b1_bark=1.0064} + else if(SPP=='TL' | SPP=='TA'){ + pcntbark=0 + b0_bark=1.5106 + b1_bark=0.8134} + else if(SPP=='WA'){ + pcntbark=0 + b0_bark=0.8834 + b1_bark=1.0188} + else if(SPP=='WC' | SPP=='NC'){ + pcntbark=0 + b0_bark=0.7797 + b1_bark=1.0569} + else if(SPP=='WP'){ + pcntbark=0 + b0_bark=0.926 + b1_bark=1} + else if(SPP=='WS'){ + pcntbark=0 + b0_bark=0.886 + b1_bark=1.022} + else if(SPP=='YB'){ + pcntbark=0 + b0_bark=0.8688 + b1_bark=1.0275} + else if(SPP=='OH'){ + pcntbark=0 + b0_bark=0.892283333 + b1_bark=1.01925} + else if(SPP=='OS'){ + pcntbark=0 + b0_bark=0.887333009 + b1_bark=1.019266336} + else{ + pcntbark=0 + b0_bark=0.889808171 + b1_bark=1.019266336} + dib=ifelse(pcntbark==0,b0_bark*dob^b1_bark,dob*(1-(pcntbark/100))) + return(dib=round(dib,4)) +} + +smalians<-function(r1,r2,len){ + L=(r1/2)^2*pi + S=(r2/2)^2*pi + vol=((L+S)/2)*len + return(round(vol,4)) +} + + +KozakTreeVol=function(Bark,SPP,DBH,HT,Planted,stump=NA,topHT=NA,topD=NA) +{ + sgmts = 100 + stump=ifelse(is.na(stump),as.numeric(0.0),stump) + topHT=ifelse(is.na(topHT),as.numeric(HT),topHT) + topHT=ifelse(topHT>HT,as.numeric(HT),topHT) + topD=(ifelse(is.na(topD),as.numeric(0.001),topD)) + L = (topHT - stump)/sgmts + i = 0 + treeVolume = 0 + while (i < sgmts) + { + H1 = L * i + stump + H2 = L * (i + 1) + stump + if (HT - H1 < 1e-04){ + dob1 = 0 + dib1 = 0 + } + else { + if (H1 == 0) + H1 = 0.001 + Esty1 = KozakTaper(Bark='ob',SPP=SPP,DHT=H1,DBH=DBH,HT=HT,Planted=Planted) + dob1 = as.numeric(Esty1) + dob1 = ifelse(dob1HT,as.numeric(HT),topHT) + topD=(ifelse(is.na(topD),as.numeric(0.001),topD)) + L = (topHT-stump) / sgmts + i = 0 + treeVolume = 0 + while(i.68,.68,temp$Avg.SG) + temp$SDImax=-6017.3*temp$Avg.SG+4156.3 + temp$RD=temp$sdi/temp$SDImax + temp=subset(temp,select=c("YEAR","STAND","PLOT",'BA','tph', + 'qmd','sdi','Avg.HT','Avg.LCR','pWP.ba','pBF.ba','pRM.ba', + 'pRS.ba','pBS.ba','pWS.ba','pPB.ba','pYB.ba','pGB.ba','RD', + 'pAB.ba','pQA.ba','pSM.ba','pWC.ba','pHW.ba','pSW.ba')) + temp +} diff --git a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R index 13d6435..feafbff 100644 --- a/fvsOL/inst/extdata/customRun_fvsRunAcadian.R +++ b/fvsOL/inst/extdata/customRun_fvsRunAcadian.R @@ -76,45 +76,66 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") dplyr::ungroup() %>% dplyr::rowwise() %>% dplyr::mutate(pHT= HTPred(SPP=SP, DBH=DBH, CSI=CSI, CCF=CCF, BAL=BAL), # Predicted height - HT= case_when(HT == 0 | HT>100 ~pHT, # Use predicted height where value is missing or in excess of 100 - TRUE ~ HT), + HT= ifelse(HT == 0 | HT>100, + pHT, # Use predicted height where value is missing or in excess of 100 + HT), HCB= HCBPred(SPP=SP, DBH=DBH, HT=pHT,CCF=CCF, BAL=BAL)) %>% dplyr::ungroup() %>% dplyr::mutate(pCR= (HT-HCB)/HT, # predicted crown ratio - CR= case_when(CR == 0 ~pCR, # use predicted crown ratio where value is missing - TRUE ~ CR)) - tree + CR= ifelse(CR == 0, + pCR, # use predicted crown ratio where value is missing + CR)) + + tree + } + + # start FVS but return prior to dubbing and calibration to detect which treees + # have dubbed heights and crown ratios. + + fvsRun(7,0) + + treesBeforeDub = fvsGetTreeAttrs(c("ht","cratio")) + + # run fvs upto stop point 1 and change the dubbed values if there are any + fvsRun(1,-1) + + # fetch CSI from the Event Monitor + CSI = fvsGetEventMonitorVariables("csi") + if (is.na(CSI)) {CSI = fvsGetEventMonitorVariables("site")*FTtoM + CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI)} + + dubHtRows = treesBeforeDub$ht == 0 + dubCrRows = treesBeforeDub$cratio == 0 + + # run the Acadian dubbing logic if any of the Ht or Cratio values are missing. + + if (any(dubHtRows) || any(dubCrRows)) + { + # at this point tpa is computed. + treesAfterDub = fvsGetTreeAttrs(c("id","plot","species","tpa","dbh")) + names(treesAfterDub) = toupper(names(treesAfterDub)) + treesAfterDub$TREE= 1:nrow(treesAfterDub) + names(treesAfterDub)[match("SPECIES",names(treesAfterDub))] = "SP" + names(treesAfterDub)[match("TPA",names(treesAfterDub))] = "EXPF" + treesAfterDub$SP = spcodes[treesAfterDub$SP,1] + treesAfterDub$ba = treesAfterDub$DBH * treesAfterDub$DBH * 0.005454 * treesAfterDub$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") + treesAfterDub$DBH = treesAfterDub$DBH * INtoCM + treesAfterDub$EXPF = treesAfterDub$EXPF * HAtoACR + treesAfterDub = dplyr::arrange(treesAfterDub, PLOT, desc(DBH)) + temp = unlist(by(treesAfterDub$ba,INDICES=treesAfterDub$PLOT,FUN=cumsum)) + treesAfterDub$BAL = temp-treesAfterDub$ba + treesAfterDub = dplyr::arrange(treesAfterDub, TREE) + treesAfterDub$CSI = CSI + treesAfterDub$HT = 0 + treesAfterDub$CR = 0 + treesAfterDub = calc_acd_ht(tree=treesAfterDub) + treesAfterDub = as.data.frame(treesAfterDub) + treesAfterDub = treesAfterDub[treesAfterDub$TREE,c("CR","HT")] + # replace the FVS dubbing with the values from calc_acd_ht for both HT and CR + if (any(dubHtRows)) treesBeforeDub$ht[dubHtRows] = treesAfterDub[dubHtRows,"HT"]*MtoFT + if (any(dubCrRows)) treesBeforeDub$cratio[dubCrRows] = round(treesAfterDub[dubCrRows,"CR"]*100,2) + fvsSetTreeAttrs(treesBeforeDub[,c("ht","cratio")]) } - - # start FVS but return prior to dubbing and calibration to dub in missing - # heights and crown ratios -# This code is commented out because at stoppoint 7, -# fvsGetEventMonitorVariables("csi") does not yet return the csi. -# fvsRun(7,0) -# CSI = fvsGetEventMonitorVariables("csi") -# cat("stoppoint 7,CSI=",CSI,"\n") -# if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM -# CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) -# orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio")) -# names(orgtree) = toupper(names(orgtree)) -# orgtree$TREE= 1:nrow(orgtree) -# names(orgtree)[match("SPECIES",names(orgtree))] = "SP" -# names(orgtree)[match("TPA",names(orgtree))] = "EXPF" -# orgtree$SP = spcodes[orgtree$SP,1] -# #change CR to a proportion and take abs; note that in FVS a negative CR -# #signals that CR change has been computed by the fire or insect/disease model -# orgtree$CR = abs(orgtree$CRATIO) * .01 -# orgtree$ba = orgtree$DBH * orgtree$DBH * 0.005454 * orgtree$EXPF * fvsUnitConversion("FT2pACRtoM2pHA") -# orgtree$DBH = orgtree$DBH * INtoCM -# orgtree$HT = orgtree$HT * FTtoM -# orgtree$EXPF = orgtree$EXPF * HAtoACR -# orgtree = dplyr::arrange(orgtree, PLOT, desc(DBH)) -# temp = unlist(by(orgtree$ba,INDICES=orgtree$PLOT,FUN=cumsum)) -# orgtree$BAL = temp-orgtree$ba -# orgtree = dplyr::arrange(orgtree, TREE) -# newtree = calc_acd_ht(tree=orgtree) -# fvsSetTreeAttrs(list(ht =as.numeric(newtree$HT*MtoFT), -# cratio=round(as.numeric(newtree$CR)*100,2))) cat ("Starting repeat loop\n") @@ -143,11 +164,10 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") #fetch some stand level information stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear","elev")) stdIds = fvsGetStandIDs() - cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 - attributes(cyclen) = NULL + CSI = fvsGetEventMonitorVariables("csi") - if (is.na(CSI)) CSI = fvsGetEventMonitorVariables("site")*FTtoM - CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI) + if (is.na(CSI)) {CSI = fvsGetEventMonitorVariables("site")*FTtoM + CSI = approxfun(c(0,8,14,20),c(0,8,12,14),rule=2)(CSI)} ELEV = as.numeric(stdInfo["elev"]) * FTtoM cat ("fvsRunAcadian: CSI=",CSI," ELEV=",ELEV,"\n") @@ -168,7 +188,8 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") } #fetch the fvs trees and form the AcadianGY "tree" dataframe - orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special")) + orgtree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio","special", "mgmtcd", + "dg", "htg", "mort")) names(orgtree) = toupper(names(orgtree)) orgtree$TREE= 1:nrow(orgtree) names(orgtree)[match("SPECIES",names(orgtree))] = "SP" @@ -180,7 +201,7 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") orgtree$DBH = orgtree$DBH * INtoCM orgtree$HT = orgtree$HT * FTtoM orgtree$EXPF = orgtree$EXPF * HAtoACR - + #load the form and risk class data using FVS variable ISPECL loaded using "special" orgtree$Form = rep(" ",nrow(orgtree)) @@ -196,21 +217,25 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") SBW=SBW,THINMOD=THINMOD,verbose=TRUE, rtnVars = c("PLOT","SP","DBH","EXPF","TREE","HT","HCB","Form","Risk")) - tree=orgtree - + tree=make_acd_tree(tree.list=orgtree, + num.plots=as.numeric(room['nplots'])) + #tree$YEAR = stdInfo["year"] + + if (nrow(tree) == 0) next + for (year in stdInfo["year"]:stdInfo["cendyear"]) { tree$YEAR = year cat ("fvsRunAcadian: calling AcadianGY, year=",year,"\n") - treeout = try(AcadianGYOneStand(tree,stand=stand,ops=ops)) - if (class(treeout)=="try-error" || any(is.na(treeout$DBH)) || + treeout = try(AcadianGYOneStand(tree, stand=stand,ops=ops)) + if (inherits(treeout, "try-error") || any(is.na(treeout$DBH)) || any(is.na(treeout$HT)) || any(is.na(treeout$EXPF))) { cat("AcadianGYOneStand failed in year=",year,"\n") dmpFile=file.path(getwd(),paste0("AcadianGYOneStand.Failure.",year,".RData")) if (class(treeout)!="try-error") treeout="critical result contains NA values" cat ("dmpFile name=",dmpFile,"\n") - save(file=dmpFile,treeout,tree,stand,ops) + save(treeout,tree,stand,ops, file=dmpFile) #### tree=NULL break } @@ -220,47 +245,54 @@ fvsRunAcadian <- function(runOps,logfile="Acadian.log") if (is.null(tree)) next # put the PLOT variable back to a character string (defactor it). if (is.factor(tree$PLOT)) tree$PLOT = levels(tree$PLOT)[as.numeric(tree$PLOT)] - # restore the order of the trees - tree = tree[order(tree$TREE),] - - cat ("fvsRunAcadian: is.null(tree$dEXPF)=",is.null(tree$dEXPF),"\n") - cat ("fvsRunAcadian: cyclen=",cyclen,"sum1 EXPF=",sum(tree$EXPF), - " sum dEXPF=",if (is.null(tree$dEXPF)) NA else sum(tree$dEXPF),"\n") - - names(tree)[match("TPA",names(tree))] = "EXPF" - - tree$CR = round((1-(tree$HCB/tree$HT))*100,1) - - tofvs = data.frame( - dg=(tree$DBH[orgtree$TREE]-orgtree$DBH)*CMtoIN, - htg=(tree$HT[orgtree$TREE]-orgtree$HT)*MtoFT, - # set the crown ratio sign to negetive so that FVS - # doesn't change them. if already negetive, don't change them. - cratio=ifelse(orgtree$CRATIO < 0, orgtree$CRATIO, - -tree$CR[orgtree$TREE])) - special=as.numeric(substr(tree$Form[orgtree$TREE],2,2))*10+ - as.numeric(substr(tree$Risk[orgtree$TREE],2,2)) + + cat ("fvsRunAcadian: is.null(tree$EXPF)=",is.null(tree$EXPF),"\n") + + # tree list to hand back to FVS + tofvs=make_fvs_tree(tree.list=tree, + orgtree.list=orgtree, + num.plots=as.numeric(room['nplots']), + mort.model=mortModel) + + #fetch the height, ba and mortality multipliers, veriable "mults" where the rows are + # fvs species index values and the columns are the attributes. + # baimult basal area increment multiplier for each species + # htgmult height growth multiplier for each species + # mortmult mortality rate multiplier for each species + # mortdia1 lower diameter limit to apply the multiplier for each species + # mortdia2 upper diameter limit to apply the multiplier for each species + + mults = fvsGetSpeciesAttrs(c("baimult","htgmult","mortmult","mortdia1","mortdia2")) + for (mult in names(mults)) cat("mult=",mult,mults[,mult],"\n") + + tofvs$SP = match(tofvs$SP,fvsGetSpeciesCodes()[,1]) + tofvs$dg = tofvs$dg*mults[tofvs$SP,"baimult"] + tofvs$htg = tofvs$htg*mults[tofvs$SP,"htgmult"] + mm = ifelse(tofvs$DBH >= mults[tofvs$SP,"mortdia1"] & + tofvs$DBH <= mults[tofvs$SP,"mortdia2"], mults[tofvs$SP,"mortmult"],1) + tofvs$mort= tofvs$mort*mm + tofvs$SP=NULL + tofvs$DBH=NULL - if (mortModel == "Acadian") tofvs$mort=(orgtree$EXPF- - tree$EXPF[orgtree$TREE])*ACRtoHA fvsSetTreeAttrs(tofvs) atstop6 = FALSE # adding regeneration? - newTrees = nrow(tree) - nrow(orgtree) + + toadd= make_fvs_regen(tree.list=tree, + orgtree.list=orgtree, + num.plots=as.numeric(room['nplots']), + spcodes=spcodes) + + newTrees = nrow(toadd) + cat ("fvsRunAcadian: num newtrees=",newTrees,"\n") - if (newTrees) + if (newTrees>0) { if (newTrees < room["maxtrees"] - room["ntrees"]) { - newTrees = (nrow(orgtree)+1):nrow(tree) - toadd = data.frame(dbh =tree$DBH[newTrees]*CMtoIN, - species=match(tree$SP[newTrees],spcodes[,"fvs"]), - ht =tree$HT[newTrees]*MtoFT, - cratio =-tree$CR[newTrees], - plot =as.numeric(tree$PLOT[newTrees]), - tpa =tree$EXPF[newTrees]*ACRtoHA) + fvsRun(stopPointCode=6,stopPointYear=-1) atstop6 = TRUE fvsAddTrees(toadd) diff --git a/fvsOL/inst/extdata/customRun_fvsRunAdirondack.R b/fvsOL/inst/extdata/customRun_fvsRunAdirondack.R index f4c0b58..879389d 100644 --- a/fvsOL/inst/extdata/customRun_fvsRunAdirondack.R +++ b/fvsOL/inst/extdata/customRun_fvsRunAdirondack.R @@ -1,211 +1,211 @@ - -# Note: This is very carefully coded. - -unlink("Adirondack.log") - -fvsRunAdirondack <- function(runOps,logfile="Adirondack.log") -{ - #load the growth model R code - rFn="AdirondackGY.R" - if (file.exists(rFn)) source(rFn) else - { - rFn = system.file("extdata", rFn, package = "fvsOL") - if (! file.exists(rFn)) stop("can not find and load model code") - source(rFn) - } - - if (!is.null(logfile) && !interactive()) - { - sink() - sink(logfile,append=TRUE) - } - - cat ("*** in fvsRunAdirondack",date()," AdirondackGYVersionTag=",AdirondackGYVersionTag,"\n") - - # process the ops. - INGROWTH = if (is.null(runOps$uiAdirondackIngrowth)) "N" else - runOps$uiAdirondackIngrowth - MinDBH = as.numeric(if (is.null(runOps$uiAdirondackMinDBH)) "3.0" else - runOps$uiAdirondackMinDBH) - mortModel= if (is.null(runOps$uiAdirondackMort)) "Adirondack" else - runOps$uiAdirondackMort - volLogic = if (is.null(runOps$uiAdirondackVolume)) "Base Model" else - runOps$uiAdirondackVolume - CutPoint = if (is.null(runOps$uiAdirondackCutPoint)) 0 else - as.numeric(runOps$uiAdirondackCutPoint) - - cat ("fvsRunAdirondack: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=") - - #load some handy conversion factors - CMtoIN = fvsUnitConversion("CMtoIN") - INtoCM = fvsUnitConversion("INtoCM") - FTtoM = fvsUnitConversion("FTtoM") - MtoFT = fvsUnitConversion("MtoFT") - ACRtoHA = fvsUnitConversion("ACRtoHA") - HAtoACR = fvsUnitConversion("HAtoACR") - spcodes = fvsGetSpeciesCodes() - stdIds = fvsGetStandIDs() - - incr = list() - repeat - { - #stopPointCode 5 (after growth and mortality, before it is added) - #stopPointCode 6 (just before estab, place to add new trees) - - #BE CAREFULL: the next few lines control when to exit the loop and - #the details are very important. It is easy to break this code! - rtn = fvsRun(stopPointCode=5,stopPointYear=-1) - if (rtn != 0) break - stopPoint <- fvsGetRestartcode() - # end of current stand? - if (stopPoint == 100) break - - # if there are no trees, this code does not work. - # NB: room is used below, so if this rule changes, move this code - room=fvsGetDims() - if (room["ntrees"] == 0) next - - #fetch some stand level information - stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear")) - cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 - attributes(cyclen) = NULL - CSI = stdInfo["site"] * FTtoM - - #fetch the fvs trees and form the AdirondackGY "tree" dataframe - incr$tree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio", - "dg","htg","mort")) - names(incr$tree) = toupper(names(incr$tree)) - incr$tree$id = 1:nrow(incr$tree) - incr$tree$TREE= incr$tree$id - names(incr$tree)[match("SPECIES",names(incr$tree))] = "SP" - names(incr$tree)[match("TPA",names(incr$tree))] = "EXPF" - incr$tree$SP = spcodes[incr$tree$SP,1] - #change CR to a proportion and take abs; note that in FVS a negative CR - #signals that CR change has been computed by the fire or insect/disease model - incr$tree$CR = abs(incr$tree$CRATIO) * .01 - incr$tree$DBH = incr$tree$DBH * INtoCM - incr$tree$HT = incr$tree$HT * FTtoM - incr$tree$DG = incr$tree$DG * INtoCM - incr$tree$HTG = incr$tree$HTG * FTtoM - incr$tree$EXPF = incr$tree$EXPF * ACRtoHA - - cat ("fvsRunAdirondack: calling AdirondackGY, year=",stdInfo["year"],"\n") - - stand = list(CSI=CSI) - ops = list(verbose=TRUE,cyclen=cyclen,INGROWTH=INGROWTH, - MinDBH=MinDBH,CutPoint=CutPoint, # >0 uses threshold probability (>0-1). - mortModel=mortModel) - #compute the growth - save(incr,stand,ops,file="test.RData") - incr = AdirondackGYOneStand(incr$tree,stand,ops) - cat ("return from AdirondackGY, names(incr)=",names(incr)," nrows=", - unlist(lapply(incr,nrow)),"\n") - - tofvs = data.frame(id=incr$tree$id, - dg=incr$tree$dDBH*CMtoIN, - htg=incr$tree$dHT*MtoFT, - # set the crown ratio sign to negetive so that FVS - # doesn't change them. if already negetive, don't change them. - cratio=ifelse(incr$tree$CRATIO < 0, incr$tree$CRATIO, - -round((1-((incr$tree$HCB+incr$tree$dHCB) / - (incr$tree$HT +incr$tree$dHT)))*100,0))) - if (!is.null(incr$tree$dEXPF)) tofvs$mort=incr$tree$dEXPF*HAtoACR - - fvsSetTreeAttrs(tofvs) - - atstop6 = FALSE - - # adding regeneration? - if (!is.null(incr$ingrow) && nrow(incr$ingrow)>0) - { - toadd = data.frame(dbh =incr$ingrow$DBH*CMtoIN, - species=match(incr$ingrow$SP,spcodes[,"fvs"]), - ht =incr$ingrow$HT*MtoFT, - cratio =incr$ingrow$CR, - plot =as.numeric(incr$ingrow$PLOT), - tpa =incr$ingrow$EXPF*ACRtoHA) - - if (nrow(toadd) < room["maxtrees"] - room["ntrees"]) - { - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - fvsAddTrees(toadd) - } else cat ("fvsRunAdirondack: Not enough room for new trees. Stand=", - fvsGetStandIDs()["standid"],"; Year=",stdInfo["year"],"\n") - } - - # modifying volume? - if (volLogic == "Kozak") - { - cat ("fvsRunAdirondack: Applying Kozak volume logic\n") - - mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) - vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) - vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], - mapply(KozakTreeVol,Bark="ob",Planted=0, - DBH = vols$dbh * INtoCM, - HT = vols$ht * FTtoM, - SPP = spcodes[vols$species,1], - stump= mcstds$mcstmp[vols$species] * FTtoM, - topD = mcstds$mctopd[vols$species] * INtoCM), 0) - - if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * - (1-(((vols$defect %% 10000) %/% 100) * .01)) - vols$mcuft = vols$mcuft * M3toFT3 - vols$species=NULL - vols$ht =NULL - vols$dbh =NULL - vols$defect =NULL - if (!atstop6) - { - fvsRun(stopPointCode=6,stopPointYear=-1) - atstop6 = TRUE - } - fvsSetTreeAttrs(vols) - } - } - rtn -} - -#NOTE: I tried various ways of building these elements. Setting the initial -#value to the saved value when the elements are created seems to work well. -#What did not work was setting the initial value to some default and then -#changing it using an update call in the server code. - -uiAdirondack <- function(fvsRun) -{ -cat ("in uiAdirondack uiAdirondackVolume=", - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackVolume)) "NULL" else - fvsRun$uiCustomRunOps$uiAdirondackVolume,"\n") - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackIngrowth)) - fvsRun$uiCustomRunOps$uiAdirondackIngrowth = "No" - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackMinDBH)) - fvsRun$uiCustomRunOps$uiAdirondackMinDBH = "3.0" - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackMort)) - fvsRun$uiCustomRunOps$uiAdirondackMort = "Adirondack" - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackVolume)) - fvsRun$uiCustomRunOps$uiAdirondackVolume = "Base Model" - if (is.null(fvsRun$uiCustomRunOps$uiAdirondackCutPoint)) - fvsRun$uiCustomRunOps$uiAdirondackCutPoint = "0.0" - list( - radioButtons("uiAdirondackIngrowth", "Simulate ingrowth:", - c("Yes","No"),inline=TRUE, - selected=fvsRun$uiCustomRunOps$uiAdirondackIngrowth), - myInlineTextInput("uiAdirondackMinDBH","Minimum DBH for ingrowth", - fvsRun$uiCustomRunOps$uiAdirondackMinDBH), - radioButtons("uiAdirondackMort", "Mortality model:", - c("Adirondack","Base Model"),inline=TRUE, - selected=fvsRun$uiCustomRunOps$uiAdirondackMort), - radioButtons("uiAdirondackVolume", "Merchantable volume logic:", - c("Kozak","Base Model"),inline=TRUE, - selected=fvsRun$uiCustomRunOps$uiAdirondackVolume), - myInlineTextInput("uiAdirondackCutPoint","CutPoint", - fvsRun$uiCustomRunOps$uiAdirondackCutPoint) - ) -} - - - - - - + +# Note: This is very carefully coded. + +unlink("Adirondack.log") + +fvsRunAdirondack <- function(runOps,logfile="Adirondack.log") +{ + #load the growth model R code + rFn="AdirondackGY.R" + if (file.exists(rFn)) source(rFn) else + { + rFn = system.file("extdata", rFn, package = "fvsOL") + if (! file.exists(rFn)) stop("can not find and load model code") + source(rFn) + } + + if (!is.null(logfile) && !interactive()) + { + sink() + sink(logfile,append=TRUE) + } + + cat ("*** in fvsRunAdirondack",date()," AdirondackGYVersionTag=",AdirondackGYVersionTag,"\n") + + # process the ops. + INGROWTH = if (is.null(runOps$uiAdirondackIngrowth)) "N" else + runOps$uiAdirondackIngrowth + MinDBH = as.numeric(if (is.null(runOps$uiAdirondackMinDBH)) "3.0" else + runOps$uiAdirondackMinDBH) + mortModel= if (is.null(runOps$uiAdirondackMort)) "Adirondack" else + runOps$uiAdirondackMort + volLogic = if (is.null(runOps$uiAdirondackVolume)) "Base Model" else + runOps$uiAdirondackVolume + CutPoint = if (is.null(runOps$uiAdirondackCutPoint)) 0 else + as.numeric(runOps$uiAdirondackCutPoint) + + cat ("fvsRunAdirondack: INGROWTH=",INGROWTH," MinDBH=",MinDBH," mortModel=") + + #load some handy conversion factors + CMtoIN = fvsUnitConversion("CMtoIN") + INtoCM = fvsUnitConversion("INtoCM") + FTtoM = fvsUnitConversion("FTtoM") + MtoFT = fvsUnitConversion("MtoFT") + ACRtoHA = fvsUnitConversion("ACRtoHA") + HAtoACR = fvsUnitConversion("HAtoACR") + spcodes = fvsGetSpeciesCodes() + stdIds = fvsGetStandIDs() + + incr = list() + repeat + { + #stopPointCode 5 (after growth and mortality, before it is added) + #stopPointCode 6 (just before estab, place to add new trees) + + #BE CAREFULL: the next few lines control when to exit the loop and + #the details are very important. It is easy to break this code! + rtn = fvsRun(stopPointCode=5,stopPointYear=-1) + if (rtn != 0) break + stopPoint <- fvsGetRestartcode() + # end of current stand? + if (stopPoint == 100) break + + # if there are no trees, this code does not work. + # NB: room is used below, so if this rule changes, move this code + room=fvsGetDims() + if (room["ntrees"] == 0) next + + #fetch some stand level information + stdInfo = fvsGetEventMonitorVariables(c("site","year","cendyear")) + cyclen = stdInfo["cendyear"] - stdInfo["year"] + 1 + attributes(cyclen) = NULL + CSI = stdInfo["site"] * FTtoM + + #fetch the fvs trees and form the AdirondackGY "tree" dataframe + incr$tree = fvsGetTreeAttrs(c("plot","species","tpa","dbh","ht","cratio", + "dg","htg","mort")) + names(incr$tree) = toupper(names(incr$tree)) + incr$tree$id = 1:nrow(incr$tree) + incr$tree$TREE= incr$tree$id + names(incr$tree)[match("SPECIES",names(incr$tree))] = "SP" + names(incr$tree)[match("TPA",names(incr$tree))] = "EXPF" + incr$tree$SP = spcodes[incr$tree$SP,1] + #change CR to a proportion and take abs; note that in FVS a negative CR + #signals that CR change has been computed by the fire or insect/disease model + incr$tree$CR = abs(incr$tree$CRATIO) * .01 + incr$tree$DBH = incr$tree$DBH * INtoCM + incr$tree$HT = incr$tree$HT * FTtoM + incr$tree$DG = incr$tree$DG * INtoCM + incr$tree$HTG = incr$tree$HTG * FTtoM + incr$tree$EXPF = incr$tree$EXPF * ACRtoHA + + cat ("fvsRunAdirondack: calling AdirondackGY, year=",stdInfo["year"],"\n") + + stand = list(CSI=CSI) + ops = list(verbose=TRUE,cyclen=cyclen,INGROWTH=INGROWTH, + MinDBH=MinDBH,CutPoint=CutPoint, # >0 uses threshold probability (>0-1). + mortModel=mortModel) + #compute the growth + save(incr,stand,ops,file="test.RData") + incr = AdirondackGYOneStand(incr$tree,stand,ops) + cat ("return from AdirondackGY, names(incr)=",names(incr)," nrows=", + unlist(lapply(incr,nrow)),"\n") + + tofvs = data.frame(id=incr$tree$id, + dg=incr$tree$dDBH*CMtoIN, + htg=incr$tree$dHT*MtoFT, + # set the crown ratio sign to negetive so that FVS + # doesn't change them. if already negetive, don't change them. + cratio=ifelse(incr$tree$CRATIO < 0, incr$tree$CRATIO, + -round((1-((incr$tree$HCB+incr$tree$dHCB) / + (incr$tree$HT +incr$tree$dHT)))*100,0))) + if (!is.null(incr$tree$dEXPF)) tofvs$mort=incr$tree$dEXPF*HAtoACR + + fvsSetTreeAttrs(tofvs) + + atstop6 = FALSE + + # adding regeneration? + if (!is.null(incr$ingrow) && nrow(incr$ingrow)>0) + { + toadd = data.frame(dbh =incr$ingrow$DBH*CMtoIN, + species=match(incr$ingrow$SP,spcodes[,"fvs"]), + ht =incr$ingrow$HT*MtoFT, + cratio =incr$ingrow$CR, + plot =as.numeric(incr$ingrow$PLOT), + tpa =incr$ingrow$EXPF*ACRtoHA) + + if (nrow(toadd) < room["maxtrees"] - room["ntrees"]) + { + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + fvsAddTrees(toadd) + } else cat ("fvsRunAdirondack: Not enough room for new trees. Stand=", + fvsGetStandIDs()["standid"],"; Year=",stdInfo["year"],"\n") + } + + # modifying volume? + if (volLogic == "Kozak") + { + cat ("fvsRunAdirondack: Applying Kozak volume logic\n") + + mcstds = fvsGetSpeciesAttrs(vars=c("mcmind","mctopd","mcstmp")) + vols = fvsGetTreeAttrs(c("species","ht","dbh","mcuft","defect")) + vols$mcuft = ifelse (vols$dbh >= mcstds$mcmind[vols$species], + mapply(KozakTreeVol,Bark="ob",Planted=0, + DBH = vols$dbh * INtoCM, + HT = vols$ht * FTtoM, + SPP = spcodes[vols$species,1], + stump= mcstds$mcstmp[vols$species] * FTtoM, + topD = mcstds$mctopd[vols$species] * INtoCM), 0) + + if (any(vols$defect != 0)) vols$mcuft = vols$mcuft * + (1-(((vols$defect %% 10000) %/% 100) * .01)) + vols$mcuft = vols$mcuft * M3toFT3 + vols$species=NULL + vols$ht =NULL + vols$dbh =NULL + vols$defect =NULL + if (!atstop6) + { + fvsRun(stopPointCode=6,stopPointYear=-1) + atstop6 = TRUE + } + fvsSetTreeAttrs(vols) + } + } + rtn +} + +#NOTE: I tried various ways of building these elements. Setting the initial +#value to the saved value when the elements are created seems to work well. +#What did not work was setting the initial value to some default and then +#changing it using an update call in the server code. + +uiAdirondack <- function(fvsRun) +{ +cat ("in uiAdirondack uiAdirondackVolume=", + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackVolume)) "NULL" else + fvsRun$uiCustomRunOps$uiAdirondackVolume,"\n") + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackIngrowth)) + fvsRun$uiCustomRunOps$uiAdirondackIngrowth = "No" + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackMinDBH)) + fvsRun$uiCustomRunOps$uiAdirondackMinDBH = "3.0" + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackMort)) + fvsRun$uiCustomRunOps$uiAdirondackMort = "Adirondack" + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackVolume)) + fvsRun$uiCustomRunOps$uiAdirondackVolume = "Base Model" + if (is.null(fvsRun$uiCustomRunOps$uiAdirondackCutPoint)) + fvsRun$uiCustomRunOps$uiAdirondackCutPoint = "0.0" + list( + radioButtons("uiAdirondackIngrowth", "Simulate ingrowth:", + c("Yes","No"),inline=TRUE, + selected=fvsRun$uiCustomRunOps$uiAdirondackIngrowth), + myInlineTextInput("uiAdirondackMinDBH","Minimum DBH for ingrowth", + fvsRun$uiCustomRunOps$uiAdirondackMinDBH), + radioButtons("uiAdirondackMort", "Mortality model:", + c("Adirondack","Base Model"),inline=TRUE, + selected=fvsRun$uiCustomRunOps$uiAdirondackMort), + radioButtons("uiAdirondackVolume", "Merchantable volume logic:", + c("Kozak","Base Model"),inline=TRUE, + selected=fvsRun$uiCustomRunOps$uiAdirondackVolume), + myInlineTextInput("uiAdirondackCutPoint","CutPoint", + fvsRun$uiCustomRunOps$uiAdirondackCutPoint) + ) +} + + + + + + diff --git a/fvsOL/inst/extdata/databaseDescription.xlsx b/fvsOL/inst/extdata/databaseDescription.xlsx index 41455201096f12a9d5a5bc596b33f2db5518dfa4..d6b64d009f07ea406047cfd1c52be5706334c782 100644 GIT binary patch literal 222403 zcmeFYWmsHGw=Imj2MED6xVuZx#vM9HaCi6M?k>UI-3h@Rg1fuBOTK3Bv(J0Jd+&Sy zpXc2EvHE#t&6=yKy4M^v#;m0v4GDz_1_K5M1_nj~wl#i{vJU|UCNBsE_5lnI;_DY1 zYeyq%M_m;+TO$W;23IRf;#?>Qs%$Wj)BpSYPhNr1$tSQ6W|rZSxXi3l@lEF%EeZgJ6sV{5g@xL2Zq^_o@i`YqdsdXL2A0P8X&xC; zbQp7Ur+N8hr-$R0=Ta2N_cH5$B3e4iIvM{izQyoWlG%WciZWc#u$l@J!|+nt#mHEUfmK7prFjw^H9t|q)ccdO(dUol~H z&jgxm8c=rmP`zk>5V8HtZ1qVizcHR}DxE%^J&=}g<^VW57bV~Yn{srVn~oR;*&8Hw*oomr7{sSAj6z_M zKu*o`9gT$>CdO3!fKUS8HxuAzE~3buQ=O)uB}-NP8B; zrer8fU0e89%O|n92vUon79^oq_PoI~MZ+YSl0`X~W8~_LAPOVsl}n7P7Gog@Zt4!wTx! zIZRE9uyS^>Ia~)$TCuq_Qj0IK4LO5L3WioxwH%n5cwyzpVsk;H7XI)Ews8F>G5Eau%Z8iJo%vm0f?bDu1fL)lf%nM) zfBry%Dg6KP;|HCeMiAg&VC$gt zhX~4#y7oqv4vY-%*Z-Fn|0id|f6cu-PF5O{87=7C?+?jn2k$Zs>69g-*nzC!D>!rN z>o?BSnEck)dvRgMoJK_?2MPM4_kG;neF6jF9d@+X)J}ar>p8HJgET}~q){H~B z_sli?2IJ}zoEYP4wNIc$_}?FyBPWcsPSEb6lLQP573AS+$>?HZZ=r8vWAVP7$WQxf zvo(kvxE}5J25GRH*w68e0pSxm@$_VVTV71OcW3}Y8=P9i7g3CP-SA$m)j7FW zYo7HWicZ7Pm1;|S`1HCihvK$WDVxkz?5<~RMNq^mIox(|>}}R^xbeDqKCss}Bu*o$ zTs;-onf3atTQm{suJw7y01~?Qa1dzGLC^>+=}f|l^#(Mu^i!6JS_Oy~69Ny_q|oy% zsBb@;w=|wMaF9k+#WC{_Pc%~TiEjb9 zU&RV6PF+rtwi8-63f5o+)s%_~c9c!~FBE8ZUkxkTzi6)2Fb%xzPT^-K*0G50zZ#mY zep%HzK5@hnzp4~!B57Q%(l-#Nsl|l$?#n8rzJz*1{hYyTiwEHfzt3yQCKZXHdeq7Zxo(TUaUv%6 z_Cn~I(&_{XVvgJZ51h!9CkNAz&Y2Z=MTV^6)^y36f$KxCCD)5gsGOhn#B$S;i}Qf+ zx@%RLQ#R`NdKpI^kGYUJef&8ZGex6+x@snzFT2$aZyxO}5 zUZ#apMiAn_JI6m`^laCEtf>kb-?C|1uc6$(%jd?sSsEK}=C!&TaBkx^%W^S3U7X=3 zl7AC6NZ`Er5PNuwf~0&ic=X+GNkX@Gl^J?}Ge!!cc~NM6KptJ*x4Y)m@P?H1Ff z`bbp#vmIeuf^G-4heNTxEG)e3QJ++4B`FHRv9Bw)2Yzo6Mq1EHC0X*yOb*Y8&pEE| zV~Og)2iEd9Sk`lbx;`W-41yTGgDZ*ydWpQUW&In}t2f@pgR?IZC?UodnT6ISYUkU< z%jaRV$WHh)73g1h=Et5xn2Sca*iG%BY!N5w^HY>8@srXIll!y=d_R4q$$#LY6BHes zNvaL#Yh(E$V-@M$R`H}1hmT#57gbXr#7(Ct{-!>g=oi4g7rC^@(w{)OTP?FnL!DP0 z@KX~#+5!x5T1U0Xky;Ke1%ap+3uAR^smER=j%5#%CRsOvMcax2df3P}4U@D#rd!2Q zsPwp3=c^T6-;j}AE}%aRLiHrBbZ&b&eYtFSK`B!!si-5YCZDT?P7c!nDqN`n6EF6Z`dISQj1X+4o&Hxun>%s~mo44ugH=6;?~+H1b$;+!0z_=i#an#5$psM!gn$42G1p7K&8YJ`8K zV1QN-{z}6y;;l|W{<8sTZu!j4)HVKyg6f!xFUxL?%&H76o?Ucpz;`p}9K91N1wus3 ze4`VO1Tv_00yd{MLNR!7Mt+Ib?0WngDjB%7c;-UPBEoRxC_cjSe4?Z&aDD_#2W++w8zi~!@Gn|2r__D?bLW=Az_tHeehdw>+0X5DuHc!*3A8Y6Sr(4$LHEDB;( z_eeI<3NBD5vP28P@ZHnnr15M43Pf2X0RKF zG^cIUOMjAU6PFVkPEBUX;24;wY+=hf-Vj;(7M0x*!AeiTW0jPb8y((DHx|2Pel!Xp z){x;vy>2!?$g)oret2I+v8)s~U8&eGZ|htjN?C|z{MEu|$CtH}Dan^xq!%16)Omn7 zJeg|E6Zq}4PctpGPa2;)C0j1cc@J^S9`Pys(=eSl##dFSSQ`zFy(baJlSm_ECdG~l2D|S4})2X5R)azq+^+pz!^fV)O z0EL&jg16zXL~&kRgD~GKyJm~EQ4PIXgXz4BX4b@5Y@8ZR)+_-ooDRV4BK4ZxDDDMBI_OVH(Uz`7H*GABewD69Bc;2^5@cqyY&vPXQKb(UPp0Q z?OPNi7#I#nKEVZp0|)JO{$>dOb;t7$TL1^CC?G2FKl{_3J`%PpgeG?H`{IA-Rqid= zJy-|tyZAXC70vm%YavdN7WI!8Zt$ofam#S`N~ADH5`xogi)vFr+cQzo_SRRz5xs-2 zIY~-%_MLjL}5vVl`CC^ER#9zxUO&?9uPbnrzMlb`3aZ1ruL4wXkpLyv+K% z)5g!!3(M~xXA*a9$Gu*Scq59eOM|y7xm}KntdsHR3vBuYCrH$)##>w$>h(PrOc}AG zlN~y4UWS5C@2ba%f^O%P&x$&=@*V{uYWdNmTRPN9NKhSe$nCfwb63B^cQaMde(L7s^rcX?3 zbOCiXu8%BmQ1JW_^cAF>3+8FJc1ca5{j@kN8Sn;;dUWU^KaSM2oDe4yq>rH3b62rG~ zN%K|GXriz-Smn-=#zS&Dv82f?h76W1z z{I=h#GS7WF^c0)+)I&N|?qW07T#X7`D?jUo@QG6)(?`MYM=W_cg_ntIv@-*=2^)(b zR+Ssw5Kcckb zZrR7;3K_S0sqQ%Cjo-@VX`RvUGVfK%D`q? z+cO7;Od(P?0_Xt^KeSqbl{)h5*#W8X)OimINy%j^iJy0SA@r1&6Q(4hu46U zYfDTIzLYve{L3Eb8uVOx^iY|@8V*&7=;G}l5Q@N zZstguHj10_>C}*z+8vJvWe1~0Si*^G9K=>;q4@z;+1!R5x#yDSv(}&AoL)RE3f*o6 zo{uR1kJ)VXI+H~Q3JgpJ9hA{P9{<7I988Uj932?{`eJ*ha2fH-QRz$|#!GukK(`KS zNlY$GQl_e|*rZgZ8a*Gy+=b9T=*%Hi=5-(Ci=V%eEw%y9>Ur()Qs>E4irax;P+)B@ z1L+rQ+RR{BH+ET-bv%SmcC4XX4df&ppwzqUIob~16;A(A5nu}k7dd9PtCb#@vzw?e z3e$>(+)mw~INFuB7}Ut_hqWqEib5tbrNF$nkr|W9jHI0u7fv~L4`8bd#!+O2eX^qX z>QP8708^B*c)AQfUkcqTJ~#D)he|xmWMWwyudzgLRU(ZkDhg&CuJS>vFuk)ZpPX~) zXbM^g#bfM#L^mKj<`VJH`!$b=4L;H}(HpX=_`oaf;HEpQvijji^$o=JDa)b`HusxE zkO4&Oldp{ANpSi$a#hj~d7V-7!-c*0$_8QMwxLURf>_tg&s(`?}Uv@;ZTKL>aSN>71s>bCln_Y>p!5c(dM+^oJUT>Gf7qpZc;z z5-fFjW9}ueD~B)nQpP1^@~8zmpDR(b0$0>f0KY8vlgqjI;YYfDDUg0Qj2Uu5hR_oQ zJPD#B4Mu76-I(ISULUea?X&*UaJj0CP>y(56lYpTF(v=;R!$roFkdRpjuu_ohe;?ol|_#3cFo~ z@&5FnXbS0#IouU3g6OA-DV$6Sg@~4~0Plw>B8+hQ0KcRrZdxoY+(plkAhMtUvr8oz z?-}VIwqzGhe4rFStd=06p$G#noVN2PQ0RA*EYy2|SA|i=+#r$P20g?iAooQ`;per# z+_Qav|Af{3*$hVDo$f=2rUXNW^C7xVeC7M8MD zT@h&?CkM_&=o-z4ih|s2u3I~Ytb(-(nymR;x@JNFK*tslm&9hV+5OutDUBOuqPCZI zn`Br40IcmRym7$e;21Z~TdY*<_FA$sy8b-nJ+NWH<5AHfoVtkq?aCA|kb2cyPEPYJ(h4Q~-ATc6+r_mahV*VC7HcqW}Q zNnn83{Adv^?LZL2{|=LDpuqu-QEB@*I&>nw>A=A>r2GLSvHtIBQu2uwff@`Lm>coG z%}MP4)W=izMjVHGA}x%1Is}6#pvR@|{=AUaAZrx} z7ybQrGe%X14W-%91JHC2V>%2*&D?~V4F=_GpTw3Bj?+lF>X3`TyuwXCF*7k;ri9h9$ z4jfvhWqQ%TpQ1&9X(}c^WXhch`kcgXV0w82Y8=$p2h;E3i(mZ}5LO%_bRs6#xsVHpq0U4Ot_qkZ^!|_)Qwpaj_yv1^K^j%V2T|3tGZ!SHpA%QzbMZ44pTb>PGwDi2 z$2f++M0FbO&QlOl_>&w?TYi_f&>cJTk11<_)nvj;w^kz9>$Yo#CZ+{92^oy^qtg=w z1|1`5kKRq5MIG3QI4D8YUI+i4|1^_olfl`FD91Y<3sx2j)=0MF7H8tWNj2Pt3^5yx zR!tBPXUK-L(`V{hhe4$n@copy??N!%R|6fq@r$7*OTOVsr?$8qk5Zg=f)>_^J!uZO zKK~nNTmBz;EFpCjROLbw*X?@%H$RoUlD9=lZ2vvaRGFi079zX!(~IIm{jm+ophw~c zzOh3+>ts{<>+SrmJ#VIUQP11+t`TJ>5ee0}1o8c{J&(Ztw@!Yi~lhLMW z-spC0X;;sOaPge%rPVT+u}8kLXCN#1x7zdUzFsGfk1&DACi)S2t;7MGLPuuG>^CMe zjnIBLRNS6qnLKRd0NhETVl3oWRm#D%N_m>j=zB;A~geWYl7bjBzBkaGtN4AGAyfe6)gugSzn;k$X zP4)3BZUi^n{Ei3RnXi8ISuuhsHHd+jLVM){w6})zU$Gjm%m`pFv zeeIpVZGO7tA$yMrYI~no8`rG8H>lHn-sq(1$LJs1&MlJ+pAlZFlbr2JcVDg&SkEO= z^X%>ck}csBtw1{yq#j^e_lN&%nZ&e~G((`IX>LQPETHC79B2IdF1WIrJx;~v@*Pm8 zp?+_@pgzj<`^iNaZi2)36@|860LonNlV%GndSBLE93zyDx|5VCOgYSl&9J|m)f4O^ zSR~4*GpJ=ZMY~=m!`!p*K{5U^4*-?9l+(KZnt`%wX@R$sqIb*m)1Honw;tdcQE@HW z!pvK0W~T}8hwABHTZjKPSmZt_6O97GB6v_`!O0292ZdW}lyT$bVKLb25o_BaZ{vi}3N{Db?(a2fGh{eeZ zX_8UT)lNLvj~1&Eigl{5D4wBboQ(Z?!}s{0*FJA-g*UDZ6)=}nY-i01z!<@;ERMVl zYN}SU$Sd}juLGR)+X4f#5@eomP%*^B!sP;D-2!rsflLDPmSwKTa%epiPBEQUz5SVH zVf=o|Gv!U`gwy7bAq6qr1dy0wVUap&6&#M#IcJbVRN*KvX99eO+%hSh;rURkOGit6 zLUMB4>&b#LLGVT&r@UTK^(2#Uetvl0AHO{-kv;~_c6Lv>bi;g1u}S`9C8nCoxuVTq z-HX~B>>#+J_2;)CzT=hoX9J03R{Dm}QFG1QzFZBNqU%q9&)Yj&%J4D%Ho}Ik+PT!9 zWIH_pH7*DOolxt`>Gua!b4R>+aXz;YiNsz=Q}?+#<{fuuj4^a~Zni_I$?BqACl3+Q zwpsD`DE(PzW1YISmz|lcZIP{Tu$!}@SXGB=JXD8G#aha_q~lq(fG4n%xu1uxCJbtk z{`KEDOf6Li_E%WY`17&+Sw#(jB8p7nfQM)d;nL21h|p#`y)tF`e*Z;Dr>#Wgc(q!{{U7aC6$E91w-RLX@OHY={T7mvQppS zML`-ex+y^(-c+08iQ|6r!0Nde9i2RK>)M)$@|?UcSe6{z@U^O6x2VYO$yv8bJ$n97 z+KZE){|{l+gkYzRw`cUkTv=zOz>o9JS6-d|>s_<0Mwg$OM0fj|dn4u7)z*d4hm6}d z54Rg>r{34@3pV36zrV*w=X{Tm&mj|s^Q zhSQ8bBQ&l6B(xt-LkJ*{=IlL!{^U8Zgj7W72rS0JsEZK(D0wkMrG~wh>)23LYtCoI z3HJMo90H~!bzMjgJtJ++!Y5E5mhh`%kX`LAUkH%ehnj#9-VxiUDM5LpHcu*IzXkpM zD)h-$Nq^ERl21HmG(R&!vH>WWYoE@iuP4k?7jliwWBuX#`cYg&&*8FZT?`~}e3 z@W7GYBsr9dD~aftt7f(a+$DsS>TPn*B%U>TMk`1=5f!G_4RIN#c@ZVi&iX+}BXd|H zf;khPo1i=A&SO)75tHXQZM2V|dlF5NR*yeROLIIX$o-qhlUKxA?0zYmv0{xE->M@w|Io^7j-Ee88R zv_j-hvFo#NVf+ z?*8=z{kOpoGE2=_Xb^^U{(C;d`4692`cI7|o{JI%U9SNc(3%LWaBt^``a*ZY)i73~ zy56x3=8MJYn708xG`hdOy*?e>5obCQiPcJNi-{KD+T%!_rs~`2^A)KdM^hp_4zPLw zLDbxb`WK(Enrqx!At7dK{MF!KMHrMctEGr{ki>aWFeR=C>oZ1EU$I$#5|)5uAQF_5 zo7*KJVtuA}P>K;T!M;qj)=buGD@Ab7)L?p=TDZW^B{t?hjgq29Pn;xz;Bt_SL!Bg8 zg==-7)ZKco2>7&w*KF`Wv2WIT&&f*N717vg4<6H#x3|12-z_DnDc`F7M>~ZI8F?L{ z)Aysw3x|~AT-_ETog10uLXT&g%ujS9-#;sPWEZ#Mi(D^P3lQo?Xk%cQt1`@AKnT>BRN5$}xx8?UFp2HC zc!%Gl1jP=IAfo*(MdPT(FCLdac0B*;D|IGDTyrKI8R^OR3R4KH2~OS>PqD>f4cZDJ|!4>m+tG&1o1B2t+VwV-FP(f{dsbJdo*~<*LX#~y>$HZy1vPmF)mN0>K!Uu zv;O0AY*qa5m&pjmZQY>D?IthN;ngRr&aYW(IVd?XBK#uEfhb_A>8Qs1z~_sP+Ap#+ zd7YQL!@3l2Xr+BbB9RYYs0^y@nYl`eyCSjCNa%@$BXLCw3WlYi2ec2XzffYaH?IPq zZG7DWfF;Djr&k`IVFsKXnBM)>!lqXtZlSDZiD`^zn(aU_aQv72;mlAm94UW;CnkAi zs9cQqZRG1CF=z|QFQMe{eqw?8FxD5`IJtZ%Et3}a;A1lFhYSy3L)zd;EI?V1C* zlfoF3@Q1`?*zyZ?;k<}aGvfe02G>Q@6l)JAG?FOJky{wyGIRB%-ha3AS{qRMYNs>$ zg1rMO0qJRR9ZIWx-g^!jxhqgxV5=`yqa7lm2F2xHQjMwa0RVvAlidGA6)j$4qo zMolZOUWs&;>jz?672_MGg1TTT+fZ7DXHuubc)LQ%53Jw(ODL2IlM=p-h7@3x*{2$U zyt6+LyZ2H}*BJo(oaHfRFx1M2S0Zkuc)_nEj7;d1jQiIxU0wS?rcgd`5lL0^Jz*Nt z0}=#tDcT^4fPCIL%6ljPX`_`Pabs-YONBgi= z7gMe=)Z1HwBrOi(y-3MpH7ufx0P+~Qel0KGDn_MPbmHAt&PQ2zyv+HfVy4m;GN~47 z67teUr7*l|C+PAR@T7_fl%HfoFq`x1XALoQ{u-MdwTb9J!pSjc9Pseeji~`2-<=J# z%z-9=X&%Mj$&R}YPLV(4h_X&TP|sT4Oa)VWU6CSaZH1*$Rt-}=kFo$qB8`a(*`Cpi zv}==$vu>}5D*hHN|9eScLL{X~c>j0k;QAXnq@zLd{J?qQ6G)zi#2G{kET59iJIk3Z zov1UAsn*|~an|{I+vXwzH$;={h<=Hd@;KJxBTt9|$R*%ZJKz~04`JG3pAIZm=YG5N zn#9vHB&a~7aT;^*+`$%k{y@Td&*Z3y(7&H%g;li*uiu=Ha@3T#u)r!?<6#??cI!NC z0JH+D!BlECfb5g3IWbeU_>zqABoLFp;>ct>a3MWzmUhpXn($5ht9C2c;AY9*^4-8D zSAIF!>YdNWp!}Ro-c8O6zp!;Rj6)ZYlqkIhhv$PjNO7P~E|=yCfCqf@lQ^dPzH zm@!ih_Xl74VejN_UeXeA9dOUJCM9y;@CH42T591D6JlpW;yV(f10UJq$#pRKm0aY6 zeAoTm(Weg6il59hj~^Ko;HRR6o^)oUE9Tc;;lm<53AF6@b_1zW2z+)hR`!Q*Q2Nh5 zr~90hUgqo%SJpA4`CnKnbV;`+q5z*L5Y%^FG4t(wxJd1YvIM5Qm1`fl~<3q}kZ?nBLrIt*9lQuJVUo|gRmEL69# z>wo$8m;XgQ&;qOU55O8Ek2r0SRIYO8nY8i_bEVMR%sid}=4h$WM6qpMKUdA7@}ud4R#ZSr_2e@vgQ8o50jNWQ+e8Icbg zBT^@jchUVrIG#NHXqP)I|C8aaZJO@NO|6CT=y2pFedK04xua}k_0FhsIa4PGoaEyd zG7*6w6tKX($VIuiwHLP!K6S%8Hc$53j3I&nG?&2&^lxaxI7pviOt9D&Ou^BoATU(Q zgjIlL_^P%`i7>p5YKs2alvpotY@{>N(C|m|6Ra#;1e}ombz!(C1zbH6*|FJj$hk^| zevzSFnqo*Wlt1*q204}X(23`Vh56BDs-C$@zgg(ps!7o_XFe57qkuh%hq1;f>7ylo z6)YY6X7b*IG`ubVwj+HgN=8iqv#uD1boV|W<^ySdf4Ct5LU2IS0WTm{SUrtP%Mc^n z{R8Q&IeI8S_9`sZ{~%&()Z$lj$GKODgq^00U^oXnTQ)Ru zpa3Y-k}N#@+}+u;j2k13Z%(ilM8nEBIgSP8!^6)j_0zTMGDulj1x{td&-Ndi`)gy{81*xfkW6Nc9LNEkiA<)X#~}XU<$#gGKs@% zKr!wxE*+|P!%#OmADTC*epoBIA(SslM3QpVftaSbfstX-h8#hwJFIJ0YiWm2LW-RH z+$Z-2nIjInxfhG|9MvY?3;Pp)vak(C;muES8mA#(i&U`e-DQHP-$|b@wU;US`}`Wp z2Cnh*d{HQ30WRf~fUIsZ#SIMg(Nm4|lWmgF2b$EciaK^rh2-?MQnYIkBwN5GLn8Ub zqN$UfggcE~Efx@z$VC6>&&R(0Atv4?U$6*UqNAG(B3IN_vlb|!7H08Ye8{%uUh%}U z7C_2(9I#N2*8VGqL~uT&;^t?MH+g6f1_PNn$FDdR-xuTS@n~X6{`2o%O8(@8M(h3s zJ9?|y=pyndQ=kbAcQV_Zl=fEG@maJMO!`UPpea4xn1GDg9SO~8O?knhN!y#mF^G!% z!{-0naFK%*Vk2b`pcMXlJ&XGvF7i)ph3?E?TX{>vPHkCRY!&c#ZN&hSi8@BP?579p z38>sFYOxq$W&AVMH*2v+IPBX%{bp&I0=__`go_ur`q4RhARR4nyIaVZK`8nCR9Q*jy(Gi8I8Y-A0naijnyLW#Hw zl-mHM^&SP;9%>IYM_Nr2j}T)&jpFrsPXjqNsq-$W-1+6P5SkY7-Z(_-Xu>cEsgY#W zA~sEggJ(3802o+g7YKQG!1kYY!?+A{BNc-$#1dX(O{emCW}*kFj>{k}!WGW8Y}W+h zB3F%ZTQ8#khU%Nh>dQ}iNz%z*b<__S2`kYT7LZ*75IME9|NQpcbGjN7vG0p8akje|3VH za+0rlIXSxRjaGqSOj#Rja^E>ey;Ps0BdUOiVqLmb)wKcwtY3t$6jb2GV`6E*>AP?w z&&C-flknSD?+2!a;isX9dRN$WMoU-EVUT8~Evyp~a+L#;b5ObDpHz{%-*V_y&&;nb>~7jx=xD zYKkFhy|nf-4o!3~Jz5gGu6EPY_2xQ;RetoRPqS9#!1S%-LMPv=X8VeI4)A88Xu#Xm zrKuDfb$(M;nSQ+U`FOg@COJ#6P`@jaBC9?>6O7KnhBt%b~U^QqHR|8&+_H*ix5_!v7C$qnfh>M zKKsXTeDdRfAOJZQYeF|Mz(`=#iS1f6z)Af%07K{}ron1G08y7>eHyMRuCZb4oX80H z_Yi3wK(#J~Hm(fA2r)Ahdc~R~yQ!Qc=EqpIvnlHFcIb#@HzJEuc5v#`Lea&Jr*|{u z3{=Rcnz^8!1ZVu*Ulf%Z2i#qhi!v;=1_l+uan$^Ypfo7SS;O$-Zzj^alp&q#$DNF+ zbJ8MO@ffiKq72&+@}HgkBol#!I=rX4L1oZ=Kk__gMmR{N3o%cO7SJvf9 zf&3DDjGz+BM1*8&aKAh>p-v6jp`ZLts$u;zR46OG@>CvAZgvu;hZ0FDY}N|vkZG-S z8mPWtDuLM?a1tNp0w%CX8O2hV^n^5&;J6h?A(I&TNljCvhRgO^Q=sZyZIvy`_JgG88n57||`@ zIYJ7{b)2u#AIUO@?c~FE8go-_Eg66EZb8`bPxUc+Rj!8#DNvW< z3R>Ot6sGt~eIgp1T@M?w4so8f#pF!vF-vF>C9=<#+>a04ik|jz0{d$m58n!MyqO5* zfI_Wo0-`pMDE0~D@qajY#LV=+Qk$6b%}-ZCBxP)hGyL_y zTQ}zjcr{BItNmHkPLF}0>R5Z>@L!Owdz^o22EvQNH`YRF#teVt4Wh+@Z$>eBeU`l2mn@lvnsegIUvr9V4rUgX81_1YqSqg{zgyO>x%DonU;~E1>pg1l{ z?tHB=`vMU$_(FPYG2lkcXE0dU14u^V&|717s7$SZA-VW?zpH5H4)A1SNVt4wHy0v8 zFp-I!BUl}r6n5a__|Gj$E~37yCYwftx+sE}4S5sW*`F_;yF%iCN&T?)zsUj3OSxfE`CPhfuLY~4$RO=V(rcE!1Lf94-$NFI(VADpyU&?c*nCFoY5q&F zM)8TKv(;zXf(JRKB3&zgd(&4m;5x^x+_1ls4@^zYtS~o4V+SA7p6Gmn|8o)Mcpp(R zl8y&G$3@|>!2TS8|Hoad`d$g^?CkY&Ce;0R zuO=+`vhY-IbpK}W5nj;u4rjP(0(}8C$CW_8QxQu4X+MLn-Z-+)7j1o~y+xtRbWP5G z{#D2?PZb8$RM5o!CN@$@DxjK*+ke(nR{yT4lnX`+Vb|Gj@Okc83~tUF`gpZ#Sr1H~ zzT?oJ#dbc-oCPhPADNZY@>$3F*RJW_reR}`_qTU1*T=g9_cyXNk9bGZkJn8;10%Pd zZfV6=%9de0Z+zjNsj7rw#!o5U4nKZ+^9K~J*yy4@pFSevq9ItAic(enM@^Nfuhl~Z1I$6phU}f$lxrc4)0o>9L5oTvf@&%tR4KVC^_#AAT*!H6Fgzt264~fE zIy90BoqQ9CU56kb$^ZcoRsk2Jh<&U0cab7c7jAS~f8LKE%A;1T?oZ?^{*EHUmXjc% ztDF>OyE2hJEaqezJ^MF+k_S|qfpt>t0^v@1?$`RbNOm+8X-Zu1T2PclCR+cF@Gi|h z%gF+pqBeUls6!b#J^tz8xNos}u-)6H>7(*dkM`Hqh(CVL5g3F1T@K}&wXTIASEq?|dBU-wY50UE#U;?ol(F&RSP!Kc?9mr0VO6T)* zFoxEGIF_*vS)Tlz6w6WV^gnP>P?0huFlm&Edy)w-M=)k z(pVZ~(LT9zX%G-5c(oS9SC}|}LMvfRK6`%yc+e?2KXd_833(%>_-p0kCSMKQ>6AJ^ z6l9B;8@nM*EBbawAT};!wMO(d%|Hs#nXdBvhLq3bpDGGaq+oMP+s?B3;X#xtZcn_$ zOdf<$?`xV$tIUH+f-nw(vo_|t*5?PqtdMJb2VGL5aSB<-QNuX((UoKnc1p1rbCsNf z@QD{*u`#K<;C|QnF?!DDzah7|V*7G!3WAhY5V!evkiz^Ax%sEiLb?trv346%N1X$o7a&%;fXNF99M3!E*Ecz$0NY>a|rZn;cf@_BzXrcWvGtL z6S`_G>^r$Z{jcQ4g9t=!Jdm@Xejb)YbowYu*_S3NMk4#-6R@v0{z2mx4ak&gdR-3; zt&^;ycY$>krm%^}+&59P_bspqh@4>JWYD&D)y@%gZ5Br}Xxc!}Y}-A03O80hk5}hU z2iAHji5v=5C1C;Srbx5MKZO}jA7m&yRQuxzXKO0wxM__GddbvCUvUd^EvJ^Pci9x| zr~{y$PmpMSJ>is}%XFxipHArt(K)}9n?+h;v_=rQk<1$S)Q-~`WUg+$l1FJYuln&# z%ym|H47U~?8~8M2v8+}McMUJMO)gQ?!DxQ(d#P$6jJ`7gvMF?6WgNYOuj zKBL(#5rSXlLk5dwnr!Rab3*kWlc2#$qW^JWRXF8BM+)M0V7MlH8d5(0EI9sOo`Lez zu6JY+_38T!JF}&fQ1OddVJP@5XcJc!RW@u;HolWltT~CBSJZJK9@&KH#xQw=(w$S_ z$3$|^rTxmej_zBf4iT+-MgRK1KJ!lx)6&^#il6YaM>i(z?Jw`;7BVlTiZyKqK7P+X zTp0t?kKCn4j2NY_XKbmSKePzT&~&$S`yVcs*8<&}yqC}Cipq+MNRz{1XyUXSiAmSj z*p6{dljLQtWEq%sJzGZhNr2;hE6R`|C6Qpt9ca(LXH9LHzH&~8oK7M zIr5DiKdcj`4UEZOqBO)#H1!AlAX6^HRtyQLSxz+UUcIlBWA?}x9(&owyK^oO^QYQ` zD6&khZ%77$WHPPH_(GWc< z5b@qiEMn_UrTw;&b+5EtZl@ABolxRf^=_{B#g$#yYC?utZUzOBeO6G9ghO?C{QesK;4?`Ud&nMRr81;&EDM#Lxk^g)Ib$P_? zUpnIt(}U0NMYW&6GY8{{FN}H^quPS-`SO=aev+Y>4`G6nY(w{hJD`3u$ZwV~A8uAQq+A;blL)QtkjFH!`Vu%x88hUWu6(TacMQO9VJ zKg7by@2jq|$PkbbQ^L5rq@Y2=yOZKLdM2w-PW%Frs^a3Rqg}2EC(idQ7bI|I*<9mn z6H9kUp{+$p*^JNEIS3>8KH zWjDL5{9blZ`Mu<3miC?oEwf24%g~=-nH0+wO9@>0FkuC;>U{2+5%^!^f`tE>jK>=r z3_=40Pmli>#>4VAJgvUJYZ3VVu0_l_WQq_3m0_Yau2VrNuwnIXiTSfe4RgZ}(6;1! zjX8#hn)5KXH~!bfSnB2F$tH2&{V+&?vQraO8poLq(c!5ZskHM+IxP-vwi<#U zRT%a9{@mE3psCP!)LqC_#@F0pnGX)BB9**fo!(+Ys-T`6`|U{f8*of=v4dO;EpU@O zCV;b;at8!Zr8IJjN|QefBTq@v;Pr(&OWZ8}Lw##%a~4gs1h3iiTQ-0d%gleAE>uh_ zhraRp#hkMy+(YSi{-9FW_8$P1c3 zdl93ENRcTEdOsu1pI`-!Z>$u8-uCCi3k!<2Qu4KbT}R8)>8l#RJ5RKlaXcHMoXGF? zN69?EO8ex@t^E6l_w5lByO@+8^KL{d1$CgZogjIUf@oFHHSb-uq`^XofCwTIqJLoj}Q__CvLOS!7{ygC%` zc}I7zdMvP_YkdFURJG*Z%p^)16|~+*3S#OQ79*&rcUx?( z^g4>kuBcF}|5a^-lxPe?(~by+u5Xgg))57AgQ2iOZCt0c8Y8}_&eV_(`M$66_<<(mU(ge0 z_IFqsBPJDl-D5N`5)>6WlI+kEBWRE2&FBo8w%;!E)Wx?1W&E8bm{nkBEk1=68*0(- z^d$#ccyu&-%MuoxlX8gDu0hw(w0`6d`-B@fC%L*4i8Cx}%&PjSEf0$(RF^sO0tIO{ z^r&Nqn0mOOJVg#cKlsKjacO$PZ8{GShI^r6M3p+9AZ@~s&f_detD@5p%?q{mnbch< z7!$k4g*hY^?ov^dLO7LYI@IYTMyA(jOESlh~s;RTWk1*w-X zZ2mb}Yoln~%e`&|@}!6|Z64tz1B2jt5ef%M`V*fiB=+1d`c%1bl__>@tr1@k*iyo| z06##}ToptjpaU(VWotq@{2|L4eeV(hL}vrmaNxGuGRhsI^4W#8bo@m@wHaGDOU(qZ}N3(JNQv9J+dOu799=v zHG8RrVPN43NM&rW8j78%vP8AFF;!l3`u|b)mH}0*TiCXAOLuokNQrcJcXxwycXzqy z?vj!gB&1V1M5IePrNM75^_;!W_rB-6zxN+w&b8*6Yl`D}?lH!FjaVadPianWamwn|| zU&Sms7$%)F63^^F6z%DostWYo&;6m_qN@jySUsI?U(D`?CL5|89`<`(O4|O&X^`;! z@nrYu7CQTczhl~ab0$xi@ilHM)r*iaLpinR=r@FL`~IWTb1<3xi^;Lppn}Z?2k&d? zA-AJ^=x-?Q!=t@P?};9es7<6`GxT1Oq0LK4|D+85`9+{lKcUoGPL=J<>freb2wyJ6 zp?b!qTmeogArKW04Gm6AWP@Y4v?2e53qBbhEmD$LJ9~^RvqM;#M+neM$({I+e%F}f z!x=6wPh137@Qkzno@Yzxjt^$V5)UZZgG0ulE3cpu)xIGto+*zJHl512^)Z~&y7x?a z|2?`i``gxKXRx!6?O+Y*y+lre;9>iEFuTV-99*T_@S=Zc*w&cdH_wNauf4~ey^FPU zJ`GQI2UYCu&uq@#%C69DiVFCRgv)w>Pw_4;0x!0WO#?0 z6!dkJMR8+S^%E+IgFnnUWdX+R+e9&cs>=kUw_=lJM%{?GQX(IO5J6gra)?ZlC_QR4 z=}LLQFln;0YeZ5>lZc#B!j+D>Z^`sppo0Zq5O6r{9iJB?NX=Ts^Rm&8iBM@#qhHcv z3SXLA?FwZEmIj-td^mq=lmlE_4tlD!#f3~>NL84PUT-$S2dHdeh3=bu=>H2}?sN4c~}1@_z#Iwv|O4M3uP>3s$Fb1d)bov;Hq z6cEis8d2%g$S&5nJZ#?EaP$uG%%@gORS%sBYdti2{8dn|^;o5B_S+LQC(i@U^oHs9h*AQTWV(&&D}WOG3h)lAtksrYv&APdkP9VfAl zUJX_qvuj?Cw4H+}OazC5eyOuV^JSafXxROgnPjKNSB}(<2?@qMcj{Esty3DB%#hCC zc764qOds&TpA zGuU8tE;PWAv9`IQ*>O*|)#i={sS#pOfBqgTH6)N+40=3~W&wo?o?T`7XB3%GGphSS z(Oz%Ho8|5pXUK@YmU(N=&@!kB%TM-3fy8+9kA|?>dPadAya}%0zq4aZCCm9`*)zfr z-Mc4l1v~4HaSu^ko&y!Df0eAN(z_Kl!TMnBhHU$ikDB$Z{7zR}Dpr4D^Srf+fEHGELy`gwLB-Dbhl zo?F^`j_?@^MC6QR%0#SS4tl@545L~K@H+yF97@r$#o~oZ z$mC@P)oHlP;lq*-9Utmh6&| z=r)#yn#9{CD(pcn>${7l**)%c7EC^)H&AK4WAy2^;7`a)FBNQ=rRNcO7xCu(o|4S_ zeb#8LdfE|%Mf99zOjAb_n1knK?@xe(paE0!va?8q?WmVw)b1n-#(TzCbyQ7*BML|8 zIV+f^h_WvPvU_%V>GsxRd1k8I%kCR_mT3p_&0_*goDe^v7RkuwhAru z`}R9sC)UD)eT15j{6eS`UOsnhK74dh2Ca1>uV54?g3%q)nZ+CEPbWw#yP+u$tW;Gh z2o2UKTW*}5&U)=?KhMu+^FoIX;Cyhe`Mmk1K9kXga`_zAf&tv7X~k9d2BpmWMrxRw zdW&2`jpGC5)(%d14MX>hN<+>@+yPm*>^`uO61P?4=(q2tw`u<9{;AOhq7Db>(hM{y z)_Q8UZY;1xI1r%1H~((5Cbv$II}&=WnewYkvlV{GsqEJKcE*!H)tyGa_9u-Ts6V_5 zXz)KNzZ8%j{yrwNYTV0fjA{v(#D+ZzUz{3FlR`yCkq!m=p7-{jh3_`3CE>E?y>9cL zRv|RwI)JRzNSZUL^X)nF#mRG#fp9-%5(?LZF`&BL7^R>Vpx=7H@O5B0o+7QD^N^ta zxsSroeFt52BHuCZeE{sF?4G%*Gb2FcjaCzlkRQAtbQaNNqD z2)fi&5YGm-bhCPS={b*n>Qm4}aTx|)ibKT9hsw-?;~ZqLjgpO}Ck8qjBu z8c`cCanM{fk!vH+r0qtYD+^;9yD)OPa*Jb$V_MYa!t_J)W{fe7<+^ z;S6L}y4(irVMf=lA*IQs$k>Z_GZ3!8*N4x9sOiiQYL=&^H5dd(QhjFr2{}h4bYyiz zVXJXDvZd0b3&TY43Hx2-c;GEEb>e5B0yH8P$$XVWAq%-Q_jzG!HDpu#Lu04UtRnm-#Xrz+YgTx4r3nCO-k|;W zt>_=e?SBwymV^}O%$oKY{uJ?mBxyI^;y8_U6Obf*FAcOP3jd2p*`-%KL$g zX-OfPj-7+;iQ#NVCkk*dMV5_9sb#QR!^d8wjfzvOxfu}|clOkFS`^G1G%^Qff;gbgTr6J)8mm3kN&ITeO47|ez} zn&7+w)YdDBCJN7zXI!fH z21DEy#N3m7rkP5f@?wLDz8EwbF$;eC<+a15QZ7nyE`;tEaGH~Y|KMXB1n$WCf8d`y_}cKVB=}Qauiz{Me5gpqjM5YtqzJg%DPvUoe``X?NCMDQIS2 zl;A$EbqiPpKOf!tDrax0_V2{ThR^SB9t-ANi3VE_b~|gBcWbwt(Nw5rBm*)J=ZbKK zotkkasCsuf@>cT(TNbwCr8-NFBL>s*?6bqq%qkAaUlrEC;+}7*JQu;HsOyrux@taf4R*$eX0o^wE%{f1*UIYk5R5h%}7jMtLZZG>i*c9U##J z2lKul3ws}k%tj|grfvuSwI+75fEfm66ocW0w7g`JgaJ5=)h>SYK^)DMo~)b`SwWQi z`(~;TTREBh`RC3|VO}nDXnjOPnJTgn4p&22GVM?K?i|)d;zz%5G)k-yXEu1nex^(Z zAE=c8u+780p8ES(itj2yN-*qFIta%_@NHOF-$b1VAgv!XnxPS4 ztU(UxDfwfCc+4-q6lajel>8)6FivA*NZ!&W^kbkTwzP+f?OOF=a>`&vMdHG+SCv4Q zz3YqfW7s6JNyU5kN%Nj60{so7th*Tk4M-53Ni{&`5!fRA>3RFdZ0#<|S|JpHXk`6A zqS61wyNNltPK2)EioS0Ebg6m1A&SuIb27_<(K-6)aTppR#)5`^7Rdj!Lwav{<*J13 zjX5BrZ<#LfQlfB&C+!DKuV6rxH)d>=soOY%ehe~cSij;$0;z@1o91S$9&)l-uHF(C zd6~%V5~VSTHgwJ^EO3gfY!PhsOVPf2ihlqZ=u{T;eA70J){ay$zwkRY>5z^tO8qL_M z+OHJZIt5vh#>Ja^RW|C_yk89k1yCk^S(ms#LqURcVJ|yl>!&-^9tq2Iz<+aWmb>2N zbbU#tBG|{jA2HLOaN;R|B;dt)kzsmZsc#)JW|6Z#XH&29B6T8t%yKI`N%nn+Af%bt z+jSUuTtk7WKH9KsAV+pI=kYs7Cgb}9w))fEORd!`@9H1(WnF<^ZdA52-y@d#bJF3$ zEU7==dQ5F)Wao>59d_g^7)Hy(=>kmtQ8Ty`J={wriOiWph|*PqlQTl*DeRLH>2$h~5}Wl9%tB zP?>|Rud~CBAv%aroW=CX)dlfFUQU)6Mef(5!8eOoo0iO|{;zM8rGiPrumCicC@U(3 zm8#PFPmn6`NJC^{!O$b4D8e%-5InP``9|u(Fh8NJ5s&i0he0jn_$|+ZxnQ76Lc6W$ zq5Y~5sM-;ysTK|^@m~bPf5pPW(h`Q1{w^R-rrh&84vmrlFNa|V0*&xA=X^b}E#z%5 z$M9obC8CBf^qXkfNbF*?*fg5Naz|Kgkn5z3Bd*va@UijiLu5oO@??gIG_B#<2+lmB#ZFO3AwcA+k^hLhXnJM;{74WXvt;DP(UDs?8Pc~`&?M%1=nVHIcplUjIz zrG~z>d&b(-Emn#YO&|)L(ST|rQ=@oG{^p_m$3!6;1nj~BAPV7Q{`Wo69~7l+Xw0M5GB-89( zOz)4X@Umg41+zvSDKf6AgxBjYO5gf7Ngi_|ViaG>n|@P#L7;9dZQnRof)q$}mFbYs z1&>P(5V4MKPkJV;t@i<1e{uS_bL5>q=!EZPiv$z5;gC^|5D88no?Xypx=IV|mSMsD@sK-d z#IWQD+rAfoIPfT4vFbRO&J%vos@6(V)lp%H%pf*=)dc0$Ww!o~s7#oR_GKIfUya{f zM1qJtBOJBS{5>_Jf?|&|D{C@58NQjbeuxm>ThMYAJgk`{DJp+vPn?#={#g1a%2nO6 zIi=L+q5dpYcO7UE9Zncy^xAzcN{*yZ_G9d1@jt8+X@*@>S5PyaqeViQ0bFi)x?@7& zLZqE{pEsRM0@OQW{?=>BP{WjU@f7jkXtGWsea@(6fxx);UtF1#$~@Z82vYQ z6mDzEgz1U?fBYpmdo z0I~Z=0X!8VcR7=Mz2piy5UMh<6wyd3!BSBi9Am1pyV)Z1rO%*`3et6@Maj!ee;r;l z@o)zRq~d&|pccBYQyl6<7O5n=I^JLt%s$8XGpssHXGC3cAR6VGGp;ltbBuq3i#6{` zi+OUbR1>Bzx9kU}=X|VLZ9rVp{~vMfw;L__KN4s8@R4HK=^5!c^6u=5 z69+oc94h}xoD~FSe!#VebxzC`*gbk(%S;kqFHx&USddAC$?_@kl^k~A;?B)(!Vjwc zA+4`ijT$HuXHkR?@4+qrC2vcHaVAI+Q)fNxC5ui6t$u3GTpKSa#*%4}&ds})PHWDx zuq7&6LFC}RG$3&Ah#od!+X1Azv*eeHOl=~cTP zcV7GV?Vjn+MekB1yukp{oEpu_GRZ?0+^5%NXhsn=Fj5z6gN&f+PG1_Qv@K_U1b+cCF=e$LnKfmHP!XCgGJ&w;3mbmNRu}7jXtJfgdTJGbJ*jd=kqpIi8F^bF=JWMGHI2kfxq=JL^Mq@s_@fZUlRE-HW4SUWz# z&J4a%EWcY#HVs}~2jD*YF)Xx?&nh|?$jvI^OnoWSMLL$-(sa9$DY#bpUmmD8sbb z6P`lD?WI=9u+vLYv&`7M3upg;+!ccbTI+MBcgDWHw|iw?*$Uw!q=*^rM^-U>iwqHs zRWp6Q>{){g3PbImYxJ|?UP&oS-6WPOt&8#pjV$L3$9`R|joh%T#Ouo0)dY5545vkj z(1M6>;8T^M-(X{XTZdJFf0ZbV0fV46PZ&&-f{tNRnZM?b%6mg9rCJ_DOr@l~z*kth zOacFuflNyps~GLUU7ig6kgRg{!wXM-tFJV{`PIR}DA~x-B9rBrLWSWHN7mGEUco!x zV#us2p@S!1M~l?B%x`L8(qR>+a8a}+P=F8PDI*$-Az&e5NbMZUUAVuG0*(gekF5u) zVFeS}LWTu5f{;Ga(w)FdW1y+F%LGj>$+o1-=RvsbiP0M zC*(OWjOxW+H1pMy!2rGuG(LMVd?}X*E9*;nA%9Hk(xgEz3Ybl9V{rm^+!{6@LiFmj_r@>>936((4qcCI^RxAtGZ1DY`=Z% z_{{>U{|pJPv+@R!k*m8>Za`Sx?2O%*IRz-Od9M#3E~iHJ;fc4Kw_yO*z}2p58W${W z$)#wS<#P<;R`Ki676%-#pj`hZE@bs4ieR^mLi&a6heED-Vuy9<>bSz^{+aS7yuH@g zPsL^+6FyliY@q2P3~0IlfO1deiwb8z(**#O%U|UxY@p3FX<5VKT+)AKtm77_g+%}D zrI2#5)>)%<6HqJgBb8Fnc4a-4ULRL5?|D+ErcR&ISYU>Ap0@3@|H<4cOUIj3bKiv^ zdfs=6yN>E8R#KZJR%)ri(^Ie6V_}(2nnv$l$S~!=r-vEY$Kol%rloK%@FYAcemdNs z%}k`~Ky+48kaYRp!)D#H5^(qBM1I2AtMyL5R!m7!bmn-v4!1b^$l zXh4Ht;&RixZr&5L$(hzR2&^c%l>2Slk^n`Cm0~Nykx+KxC^1dX!+&3RP5R*r2S8l5 zKb2J`CT%r0GNMBlWg9Zn2^P|#q<#Q)a^O+{f2P^X;j^(Kpjx1)U|eNqnWG`<#un%e zooyr}M1=Mle|vc#5HSeijB2wB|MpX$r#*}zg0%3CU}jLwz1N!SmY$rC-QYb1@&(IZ zEBb#Jo9LoIM8Azq(7$1Ezl=>>k-v>i(Qkq88^OLoY7^kamsdL&anNi0^Zdc*!r3qs zKsMZ-x@HJ0bN26?@%Tmd?_3@@`#qg)KRoK*0mdfG%!rxgg|5MiZC8J=u?ah-_lYCM zH&^{Q#s(w($vMOS(Hp+*x3OvOkFlv-M^rL!|0)NJYezHgzUcKBLFa%f)HhrWb z$`9npFSR}bMx|M!O2WuQdop2Vl)~xy(Msa%=#c^uFv{V&9&A(!b*~SBK1%($JF+%w z{~U}|(BhQ+Tr5D0wqGm;f!IL+O{bATY^M)+q)b>fesO;wvE-r(r&R_ki4Vcnse$}s zGLg2BXN$xDP>50k)(32ZdPx@s_?kwOte}UE$rzXtDpR_10ArIl%Dl5D3cNIN!ZU4v z5QKF%*2IvU@mF5P=cS9aD<=Zeb z^Ol~USo|my^U*MXP%B@)*m1$>JJh|K+kw|j2 z*8GSZ#RYL}ZzJG2mdz1Q+;_zzN4x^nE2iN~GUOd5na!G)K_RH}yhVfYkzU*_^;z%$ z%uJS@?i|DmdvZO=<5a)MNJ)OBwkm1SB_Fe<)n06;C@6w1Q#hD1Eng_tjb>B*@*R1{ zVaxTa80^U#`qSM{M%PXJC{etspo_X306z@DWH78qUl_1Zfno*xyl2vqHGyATH%*zT zz52nAE-xAs*{W?JV~J6?Mpc0Ak~Z1|wllS*@#aXUPiKVE9e|qH*rkua7jUXz2ktou z&0G;Jk`fbiQmE4}R2-YEWP5NtTo3d9riDF-;+owfF+Gh%{)py$E4E5fX zF|q%-hPJ9DMyV?eIU)m2y`rv#1?VgAOf&8&6l_jT43|{?oYZ@oQ2v2MZm%($VfL|I z@#kL+y8oDEY9r9Jr5ISIEdIwb^~Xr%02H**238H7SA#A)goKr%KD@LYJEHbj{IwO@bQ_zgXM}?0YS2mZ+f(a_c#uU4+HwVT7lwkCID*6iB zrXGuRELr%xkW~&!*fWGjr1aQ$sD3NCnrazoKK*&2mOS$J1#Aa5Ma)Z*Y%-e`2T8SP z95g}$7Z+#1o}0=4hOlC&G`usxQ?A@Y%~AX`?w-y5XDMh+O`1t|6YBMMj@4#CBnyZF z-03$zJ&aGel@7y}poo;F?y1(ddZJ;q9u%~^gBG1C>?UG}9#JOp(8cW1976}+U*2Mho7LZau4_}u+HS`RFcpoiy_< zt|gqG+sWfw72mRA3&Uz4;ouKH-%`3F)!MM9NXA9$r_In0|^y84H_;bQ*XvEMP_@K2{qHCu_&?dE1{_JMH;X;SxriY4- z+%dGGyiRwk?qqdY(s(G@2XC)crI%YaJ#SF$4F`!0gA*ym5=cYDPVK5z04>=aN3H@#W}Pg=6lc2^tH?nl%cW+onI zDt@|ZYBof;{4A)jh%hX>xY%6SOgPzmHFua$c^&c5A;4pBX8mSXHAb z^4`!M2KhOI$>f6SMC?JMxD`DUVxn$^a3Dcmg;AFsA|8=ipV6ip3PrIk8kwaIR{n={ z|FGiV$4<>pYxyR~HZbVZh>&KC@Jg;3IQk{9_W?84KC|12H|G!MA4uclvJ?}99}7MC z`3YE17BH~PBKDuvr-+wW6Us7te5xIQbK@l0dT)yk>O6T?KcH-_LlouIa#K4l>1C=P zAC*e4jX|tD&u1&oNb6=uhtmO*a@|^h;Jwccq`!F!4-07++T>h5vaMSsPsLTH>P@my ze_jD_J>+EKX|MhCGD0~<@Y0+c8|9=8J;2Ne=_z?e!J{v1FNcL4&y>g0Qt9^&;^|tF z4ecb=TwC=ku;Fawq-`)hj4bfU0=fht)l_#)V~v!;N{9(f-W9&gH*brDxj4BY_IeH z7pNq&d=puD>VQu)xtdzg>Fe;c4o(|hFx9kJj()iDu$phhM^t4c+1Zgpflj$AeDg-r zG@f$Sk|adn;D~^L<|y0Zpy-u#Y9?Z2G*7iV@FYAmrvtau+hPYRILgz%r)Am}KggamWrlPK$(+b_`$%VJZhq#|j|e(yCY5 z8E#R@rEb%~{HgVdL&a`}H21M=ZG)MFHid;NbgsY$jtGz^&5MGsP(IoOtgrn#6S9R> zvhyR^X$9b02G(im$mph(NHp^WYQdM+Bjs{e2+3meJV~r27u3M_@HMG1Me4vWqEfNd zL6x!w5J@&(Qv@4pKLq&ZGcu@>hXsmaUF|q(6Vj&}6|g?En~^$YNPGUe_HkvYW|seA zSZ1HFmYkB2lwV?F0_5||T`oaIUxQFnIwdE(UP%rTM4d;2T=TnhJdidfG< zHR?8b@N@}z=h)a1eR18nGYrz!Zq(816CAJyYyBGqnQLiZT$3MqcsQq?3TAn($7!jC zjtWwOH)f`Ri_WchJ-}BO5s?;;fDIlFk3Qf#Dyuf7Bz_404s z?=KulRNQHnkAE`DWrt^WA$kM?1SBr$m#-T@NOpG;TJGVk?t3P*?=XHw4Xi?&9EMwA zVB#rUFhBK=hFuTG7%;!k4^XO}mU5V=o&sFLuOxJz`tciK4kV5IEccsKbkhJHYmsbEYkJTM?xwh$V zG)N`ojFE(VzMjR$qYFZ&Y-ZOORu($M$|HA-B!P4aEnW-&mNq`<4fu>zT|weB5u!Aj zQ0NBkOhx^O<0WXS=Q)vUvx?aV5{9hfn4JlK%ceJGoPbxhe(=gBVK*4AhGmVAc|{Oe z;6|!b+S7J)WJw#jmFv^Kf%-U$=-;-t_vmqGH?BCiY2MOx*pjs{bJBlcYW}YOcK2zU zC;+el_mj>XqN1)o9mntXo^79N&E-|qHfM>N2-4ovombkRcfB4=SZy9y$l6|VZ{X7_ zh!>F%;SZ|{b%%CdA9zs|oQ14QLD{Vwj>|?gl&=KEMz>gmi19#QV4u8m~opeIUj9{r%_U?*$P&h}HQu z@MiPnAwnw_=jbx7RCunQF^|IJhp3SF>YC7qKd3aeDC2YQFWwrJKwSuvkHH1G3czE@ zmDbFwNItN?A;OF>+#TJ!9o_rkMG9v}6ri{#Id*Z=4_>!>X-_`yVfn>+X3eaK+`1w= zv+{dG?mXcv|?N{i|=gpTmA z!>`jg3rDLjYJ$tcq1krJy0{PNvMf*h#{!?FtnYqQtG2xKF6~v>bO2K)Hi0C*S z2%mtF{h8fcC_Jkd4cOjx3I)R!Si{IJ&$!YuDBz5upiUWGKWB?9jL}hq^SvC4*RLOo zCK75dpSeb5;&~C4R6}Vm#N5Y9fdfhwTLZca()IC2W3?49scG`Z68{+96Qda`R~Kk;Af;uNUS$u zg8q_2!@|0a0*-Z(u2g(sjNbKg?6e6UwuPnc6no7O1ac!rNKJ<7_e}f}xMv9|AIn*s zpT!?-;^?!NO>(kFn}rL!bjfuxuOaP|FjczR-&QY9|xVM(y_=LIchh3`w~d}Ggv z!CxxS^d3)^x^%F7G#MilyX2KT%eh(xm%-I*@cbr?zHDeh3`3w#ZkmBZ4a`@w!*m1!h!Xk_VI1 z!o#xk*>JO4r>}Cfinn~*hAe#--kWP4n6>JlPWz^sSK1{`lrHwptYx{pRR|`F?9IiG z*nNS38X&G{QY-5@ujMSF9AeyJ<;e*1wSM2y`6)EM++VEGB>i-XSl5R~Wi~s~A`u`A+f4pVN4nV?S6kX<=0Z$hDf$N7N2>a8vE2IG0&6 zjXQElhd9~A-hhCV8wLcVGLp}^QY_UdNpsw^tE%X#BwGP8F{iKTP27a}1CZyWPuGx0 z;dSS?0;Cac31=vG#|a2P)QdO)h(=WLyOA+NptxH7O^9r}T9b zj8~VqG0?~d$rd%u-MuR*IJ=I7yEGyK^W}#-P}YeignbG_grEwMDYcn|V+8d)qIU;e ze%~yh#7r*$hIaQmMWZhfR+<^6T!tRMXn!4mV-mnc-c6-&T-t{K9?!%FZGsxLNtR1P zb+)_=n{kO2xyvj?K;NGlgQ`0;WM;O>ir)iC!G#HwE`Xefb86wO$X8}n;)Kp0oIjsx4Qtz>G5KFY2lV- zZr{U7VK>3>iHHU0s``H>F0HB=Q8w|Tht`05)%O&Zy zCIgkm0F;xPx8;1%Z>C_e$-^9=ASD0=84czM+Tw;JMH9&VR*+4Af=p$w#3u46>3yD~ zHoNA|i2XonCG?9Y*y0QD1kb=2CqO0IrSh}q&5#r*G}D2Rf)F;Q1pw^I5g?yOc606H zi%Ct833b~k2TohuV$~zMGsDtin<_CzCTgIO=>ia31u=_XjB~H@jW5e94pCeq1N#W? zN-$BLEg}|9PuH-4sZhXuRc)W|ql5hTo|%Euu#4;=#+w_CsV{L#IrV+wBMaN_vL%RHOTXJ_C5} zk(5bx>U(c6F0W16`1Sg2{Ew(t5Rj5`&McR5!<{6Nh&jF{l7%XCZlrm!?D90;;-yAy zs4AuRN@I1*%9XQzzQGFlXfv5E(h$_?Ix6$vgJ|x-ieEF#FZG&t^h9K&l{cSRcgKrY zt0Vxx^L3_Bvm~dbOcw;THrW{$Pf{r)AlX`?bGMaynkwd;X5mZ4Ada#N&PUccCW+-8 zvX6d`m*2rQ(iv0Q!GA{QlXMy_+cj#);|n0o)skG1$r;3RL?i2)wy=?shB)}Sk&_x? zD?sBEQf^=UB7=2AuB<WHsmf_N&w=Ej7%0PJ-PEEXiQ!tfuCl5Dw;mU9s|rdkFxvRDhA-st%VcBt3`AYz_&3)Vr!5ZC36QP z;Q--&U;L4fXQ>Xzf@YY{ZYuzJQI(==YUO!qTkJMPAPs7PzX@b1frHBtbW1>Xby|~O zV6m)}s(vOTls<>F@1025ZtzW`6zyt91T`4eaZ{>P7HB zRU)j(?{2Gvg#o8XaU#iP?R;QhhiSw!43#h(7{v|b)d%(`Z9XEg-43>r z)MahvihCJQW2ot$^z!Rk=#$7XR!g1I78yMMyzOVGavI5`tBB{V;ar|&+#UM z>}wj-!MZ$U3K=ZP9L;2iNwK>ihCW)DF%Eo>4+n;f8>%Q5O4*_GbdFI6K6$iTU!ec; zxv(OK@JTm9Ve?00i4weLbvwkbBmquG{`N&_T67if_xnIhk&cjH#$X4&6sP-FDbQsy zHj8+qL*3=K&5vHJsPOzr_V-;#AxT1Yn)ax_+N}`E{XqV`0XB}$vaK^p&nZuu$3O7{B02hu6- zD<=#Koa)b0-fUsIZ8H+ls&2lJaq!&25rLi}RB!XdtPQyRu7%gOh@dx$DKBC; z279nSE=^oqym`1%!u?owe?yJ+akO^naeFZB;M(EBFnXC(Gmiz;@MmsK%jgd;v6MVt zy7-7uv2!mIuNUu1zW@tZ9Kh~qQzE%?80>ul3Gu_cMj)UYlAVkSe0LMSm@vKa!wb_7 zbF`cV(GUB(u8{x3m-bMCOXX6)cd9C3WKQ8|A{>Mc^&znMQzV3$90ZI?Ddz}9u&D-t z+4sI+$R!*K;FJ(FN^(UAJX@)~U!KUCmOU&aEe_iE15V2wo+I2u;7_nB$*iq7Fc_t4 z?C3{zRSl%fi9+$%9wYjrudQppRJ{21QVgDD4aM51z{bOY%T9j zKAA#;Xh}eg{?%tfIdKF^)cS37j9|kUIVo(Xg^GT_v_W#-UyEf?^M)qhu%X zG-(Y>QyU8cJ8sVGT|W`&6i%uipFX&b8tYA&E1+0z+F1~kV8n+C6bMmo0Vg75HtY*^ z8TBlx;yRqhQd~WGXp%X&iAfTYDvI@=Eao6U7z*chr(Kd zLLpPQlUSJxK~)|b7E&qrwwrzfZz>H=?Qk$ggK2>WmJ7V8+-$`%=~3m^yJ~MfhbF4A zbxpr(dtf<9%B5S;vU7H`-t^}Yu4O+)6arHZE;-=q@-dV!H%#w z&491@&5pKMhVVr7jh6hZn?6uZ-%E$e>GXd-i0pf8g1Q>=hDq}sW)UkWl zjErKowkZl+km?j11h5aVVwL^<_{Mm>Irsq5!QN{ zSQr2JT;J3JG?l?smPHRTKNcnEEsV1PJyZ8IyVk|cKka(nb4>TgyiAca%rUL7KKa=f zyr_@t0esN|KISqmi#YK2dj$zUdEB&0`z!Pl_S^B z>1TnH`;c=3u3l(XI_$!YEWGnQSuza5$b9eKWYts|&{~H(Y3+vCPcBUV~Qt==Z8X#WnEDX?Rvr2!-P0gV&ObI2X#LUmw7) zQtrm?4)9jkymDYeP)M1rXA?*a=>*1+kOoHtPQC@x@fZXY2GsuyxzVKJ> zl&9zLgIedVd60iZuLC5`5_R?(a_U8AQ^2IjvFmvuj*BRlV*T3@U?_Ib{DEDEUQMpj z`*gS>#bM#+?$Eg=>Ora8hW>Zl@>NL}x7~}vhRZ%(#aM>))?X|cCt-_8gDP8=Z4QOqvyWgeD6T~In#bq+qUZi5w;YpBRuZ;3WQ%KU9G0jzAJD!+R3I8i zjD~ROY4{>LJqE@{A@5Eb)Mw50@nfK8U?8y%d@T(}GMoI*CD`HvT67afBB6zlPS@E4 zCp@D_OH(sf`gOy%6}*-nkO6=F;^t;g$SXuFA8t(VHKmFI}^G@3uX)@(c<{ z3Y0{kMCwBAA!Kgjv=e|)Bml5CY2-W5NC~s^6S~s1jT_21)4VT z9ivj9E_nA_>T&&%dKqqilX@7xrJk$4yM?}rOcVi}6cP_klMVYk?RlszJiS7^zU4f% z(ye}GZtuO2&KgFZR%Ho*?OmW!Y2z4_EOefA1Zxsn4R_FYu+};HVrLIg8i7Be2ldR{ z1H;=SzA5YZuYpl!{NZRRMY+F}9xZcHRr`cf+hh>cv^jr_oFumDXte?}$*BS)%_)5NsXs?--* zlECUOR+c{rEk(BjoqVK5*5BkvJpt&9Nfx{ErZJY801r+%i)xB@^DYvXE}m=5O$1l{ zX3yWLe{;x0n?QR<%GE;4s3D;zf)w)7SoXPX2OnEC_O07k~;!IWwDkK1e zMFQX28u15&r4Tib@^289Wah^88WuaylerG=$sCnvGergHHxFJjHofz}vX+mq3Gf>T zyIDv^F9Eriyai0zYW-Cb1mqq!D!$+^xhI-534pME%e^R|C-axP29SHC0KTFA#VM)t zogA4;S0X}AFWd3`4K52V*j?ki{^c&jzERksf%()1dt%x;dCjpEe&TfrH17>M8Ra`j z!RZIE-1{NzH?By3b+u3MIIrWkS%q%cE=&k^*Z8Q`Hm%%UTB6Bd zg4zx1UEP8#g?Xr7#;NeF+`qdf4f{3=?#Vn!Yv&U{7zN}WMW9*Yup1PlvAE3LD|F~)MQji3=fEInG%6cj7YAui-UWRij{^4)NLElYf?*s`?g>!qgvXg$NM z1=HngYu6V@ZN-qZ-5B&40>IjnXnbX9P5>AST0Kb-ISel&EL2zmFk zX6nYHCz+&JG+KxF(T4qDTj1gDXv@U!OJ~mWC0iUfwXI?R63ilQNrAYh-#|RMa@&ru z`kn2Rx*Ipp0jGccsMx*W%E{3Zo1$*hKH9 z^F<_ap}(CN!&ttB7E@Nt(a{p#nPomvefAv2^ci>CvwVlt%#17RS257}4(>{YeZxoS ziQM9bTHVG=c+cXQpW*QzcWYBUD;ngN%Fbp`-bmixW{Siny32)F`(F6W3C0rr*#;s8 zZAb8|^&&c?qXQ&&8xf|qE~U}j@rSy-03GYf3_u0W-k zJ0SPGs5R*{EHQ0p2<^C0vUl}0q(@+*+bj**wpnYp5X-_Fq`8vf3PULiMj7%$+m17E z3#j&JTFoOyqnn~$#g~9^6bGv?h`%&>@~PAkmyc^xuV^`!9GfON4GfDBzm5Bv)*zG1 z4*d3F$4Um|0%CL{&C1`@nvSwD9A}WmpX)T!mQ<~Ozlmr(xLBMs40~;^cJHh}FH~_w zjl`D;qRQQp<)5cH|L{6A@|cuztBJWX5Mv*>Jq6Wq#pHYElqB=(x?z5M1qzT#T!J<= z{oKP)JN)*8*kY~fI@K94-m1PkT7DnL$QO^MxVQ$wVop#+*q=g)d5*<_$F4rXa*=i& z52XG+6_9@{9jV$d$zjrFzJ=XYoQvg6ecDu&TLI0z#-Uz&YM(j~mj{>3@`hpQJ-8Fi zu$4B%dfJC{>JK+%f6d$)7I2DSm)3xw9;X_MQ34(0G!m$6cQy_S^uDR=T(btgsF%1o z>5e!+i`>`HQ~?j#Sm`%>E~A#*7jvn#gNC=N?P6 zMvapEXb6k#>P#ABH0)y75iX{a#~7>aX{k!&uMl3`ulas62fl_}PrK{&xI#|(&@56tHD%#SR-S;i~{gc=oXzs(xk*=7)Q)KhucCaZaace;h~INJ|5*~d!6Ao zYHLT!xB*0zdm685)LruWJPc0O&kiz%)idgC0__kG-Z9&+YwMvKx>162;UwT~Ep4#h z9-FK8T}W0lcot~I_t{HgClCvwBfUiv`&z$YSa~fOHbzV)SqJ#vzYQ(@_P#qAW$9gf0gj4tN)bnzMBR2D!RM4@n%wh5}|YH53u zWIyY5L6fg{Z9!eGn_dHZ7Ougbg>PpGmM65FgHydk~ zyhRJ8vl&Im`&)=}{p*ecmys#>FXR9gObWn)LFVu-rf%vVe1Fz*MW_bnLx1`zLMV^` zV6iYhpfliA=m4=omaG@N5}BV3m7fc0~O$a{VC%4 zs?Y&>`Tzy&hep3a%c4RUmyD4U%rtwLyRS8@vIWVj-{i388Y8RIA~CRq695p6lk!NXsN(<;YzYQ|h;6uef{og1 z5esML2Pq$VlBmVam2u{YX`YlZlIabZNfBB<5diO!nHqdFFT9^i5iZoX1ZfVoh`)D> z-z45kaE78zo7tC@p$DsYB7=GA76UipS;r)zwHZd=(!Cy4yqB&=pg&c-EI`Hkej}|K zPA~?%%O=BBDzN$%|2csw?Uk=Rn^>9|M9w~_hY^>B9N4PKfeABK2+H)k0)cd|Wp(Yd zjITYSrvgx^;<$EnjN8gmwJM!%&|&Mv-}jvT8c3`1T(l=~Ng7c1R4&2*>CiYEVXj!m zih+z_=itL5N-{{5l|R9~4ONc)rpw3*t%pX1STGrxD`?|P`4)ldtv(9 z1^IJN;MbCk0HUh=6bY8`K)+?Yo#>A`!06H-W1|admGl`9vMJMMNlV=`Fi)Av@Ry7? zfdvMbIdUJ>YR&xmpvL7cV8w3hmyA~gmhor+8SjWnyil?jP1*V8IJ_{%9S|_(LEuM= z&b&bYCHfW90^ny*tfLD{eHv%MR_bc$IDiRTUx0IT=ziS+Xm-!3;u6maF-s)@oHBso zd=xOh9DxdmI~D|ANHYpNOJipdLDp8e(6orw8OtvIC-!M2HQN=)!U7V$|y6N)h(B8+57jZ=f;W$V<= zQU9WDLpSnQ$&yNOWoe}@z9NRtHZp*X!IDeLucoftyqs4z51M=X&Go~gVe#1q3!X+u zbl#VF1M?kSv(>?}mZHd~Pem-Q|wj{v@8TPmoz~a@&;mx)&yx0&iwa>r_(K?Yka&2^eLAM?6Rjsz9%#gwV>PGmTRsh6ixo$^b#Hg`#7 z%lHy$BSU@K!(5c=zfTzlea~zgf7b2teP7@zKk;tNe58}tuK^rv>XN6+c)q_tnycaP z(Lq7OO<8CsXYKi71MbILW`=Kx<|L-vRAFl<@>a`V4zZqQ42UA7p1aeR^+I!_z@X5J z+6A+xS>_7kLDMf}BR~~+*t$UT%Jk4tH;Vz-m-NwS?$ew%>6%oa8~5SU&ITxq@hi;?(m zl;p5P)!F|76O#$$v?cLlGR5h=X1zGQJAUHSB((S@2EbFkAO?^x`?@hfjLw&ODOl=dq-flXbuo~=+vu}k=(-YdPz?9O|><-@PvPNl&Do~_Vh<@E>>^u!oeqHoP2q+{Tv7)m9 zFb-wnX3_|en>UQ1D8NCb@CvpBVjqf1i66Nb*}HChf0RmMa+n4hsA9T7C_xOQax*2^ z1Yo=|vZ%UfM)GP73?2y)KO7=mfuNjdcqj`$&PlC((Hus3>>^efipa~Xmpo>8g%UqB ztomh>B%Mv!@V=c2s=8|N$cPA_MNWQdQgT>mlB?k*e3{U*(p9?3fAj)YLVz{Agld4M zWwdnFI#V7gU$rN0;w{pyyFRuuXhGi53cQD_;f`*OM^%)P?1xiCBPjRN+iz2HNdMa0 zQFp>KWttZ~q;*d1^g{RvQ}Pr;*mxLA@#MfZkEx;muB>Rkq&(?&r#cx!XVD?Gil}e) zqr))MDTyjx!zeN8AR@)HW_&9nw*_m_zVCQYj@sk&YBf~2r5dIlq61C5gv-Dija1vC zEdB!9wQspm`Tp&2o8p^*Gp;4tAZ3PW=B_h?aFwqRfs?euKf)Xa2I_A%MXIK0}TEgCw$i0%Kx!EH(1PpW?b@8S^ypLm$Z+Ns zCrON?(Oc^>y)xil))h|Y96By=p{_{`=#8Xq-5$OG%Xp*H`pNE+{p#uA zfXLqd7V*Hpsi;did{PZ2c0duc;CQq6%{3bv&J5VInW~C6@`3-AmT2D`K9gW!Bs@y! z$@z%tf~l~2W{{}ftW;~r-G~L23QJQjckF0au@9*tC#TGE3odsYV%)9U6eY4mf*zk& z=%I@T^um@=1r>aO&lKL&$-8m5`F4^|b{JQuC^x-ukr=qvXC7ani#vk)kSfvgL@-&o zz%cAGO#XXiPVI>x{b&t>QQakcUQOS-z?V%4z&kT`k*2vxap?THKx2IFjS%>j!854o?n+GmLs zQ057@8BNH}x(Mj3Ckm&9o)rD%nvgC;)xcAZ`za-%G2Sghy9_CgtnP7Wtc~J?801weOhX&ha zn32z(f1_V&A~9?#0MdfA>YQ`vozWDOKP=W$76EBN^|3v~d_Y>zrecO9VN3GFr5{yd zZh)UHO6Q4E(YMah0vL|@-H))ss6eR3flweCxry1Mc~2UX;DO=}xh-eyD~Mtz4M$IZ z{Z$Xmuk%bGj<#z13}1xGJ516Ta-{lb-IhPY8Q8UbD9zssN}ebCp!w9b{-gTowS!;p z94G%)BG7v&<%?2<#7}z-WSQIVCbVQ8`5zrjKffuhzv(I2$Ziv%))0dF<2;iVolplb z?*So-*-seUBwQx_+DP+&^UM!qVN)*nVK4dl?<&A1^Dn5DU2n_)m5!y^WJSLOLzsOV zFqw;L#9=->=FzeodT`;xQ-#rx*erg|U=M1pednb0?qdR0iBuQkK03N$s4-EWrp)9| zU*RxRDEkS>wp$pg;t%K{ACzyN!b03h5l+|&g@wwElKzPCP=7-0*ySes51mIFrHA(~oVtW<(uZOd;@+f!dpEbdm z#j)ZEREmf?lu01c+a%kHs8(|TFPJD&vBCrupdlhUiBnKuB7qR_8Y=*6bK>fjo4wO7r6@5m2#sM8kXXmr%DT-(gUTVP8F;ev7N_n< zm+Cx~88h)S9fJNeOjhw?xCQ2gig+tFVIedL>JI?~#gR$cg_`f=ONQ}?c$oLMyp%yH z%$(<48txmc>JCXdy>nC#NnoX_Zfc_wj6Eds7{zMn; z%dZe0b^}zEvJjRv4vKn#bHZdVOcJqhBtiTvF+AC?@il9Ul~hM>BUv1W1mxsganqt1 z%94o{vh!|Ak`n<1Z;9sC7{%E-1U^15p7`5pSYVAbv*yJ~(#yieVL|+SZ9@h+hHVYG zJ@9X5@7=7LO1G=LrTu*zn`?Kz6>#d<#m759!9owncs8{$v~K-Ix;qgvGwdbN_rMvY zX41<#@G#IGfk$5=P28wg(!k^6TfN@X_;qqw<~01{BkmNh(N4lEWf8qE+Q1p;cx_CJ zCJV!raq0|yL=)8cIum;$)P9MnxZQGgRgqeNN$1Z~opj#oO+AWGWS4MmiEG1MAI3jk$m z$?Zu{V`cG5JWXm^Rybfk+Gqg|X#Ey$sepr|k{lzp_Z+x8v)5rOweiRP@)yIY_BzpZ zmzPx*0k_nz=ucl)X)_n}6bji2Qol|9=qpIDV(Dd;`blJ(6zzSK#}b zz~|*}vTzB+=drkFx210O)SSaFngcnWIxEu*S%p({-K!25S#Mj3Vi=7@cpmA_rC()|8D}HZi*UJ^nVuk zIR1sq{;R+T#S{hzd@lKK3f0R=s)&vJaU$amtm7-efn-wjWr-|MXsN3iKKt3j_v-cA z5v&u=BgqCIV+yjig(>fmDx(GwZHcqZtqK@ezcJWuN!I2!?@-Ts>k*2< z{1(U~t8D~&Uw}L^j&diV6|Hk$jUn|G9e`bOb!9PU(TmG`)?P@zZf>N}Xz5t9Kc z&7`a6f<(}vU(il`1$*o=FHg|26#NylJ~^(v@-ccapI$Onh9|+ukoEjNBTmu^P?*VAGeEWp^=2W(@wP&RRC>8#t z5TR;V`uo@LKfH%OKBs2MqZpZNYZ^H|*?iT0O}9~NuLNxxU@$O!DDvMad^VvO0vX?x z(~VtVgFLTjU6ztHqcQY=gjo@Y^KeD<***wAS6}0^PV#CuK;)ORF8dfNOIo;-J1t@Zl-V{>p=IWD$u=|b~);(z!x}E zD*=f__#8or5E+LkIx3)BSpua&d7Mnt9S#!7Gy*D7{j@k15Dfn>iBC0M5%B4)8``P5 zRjf@czG)OEGy!XTlfN~-H?PvV-$ww00r6yRP6)$-hmf^!$`(t1YJ8J`#%IiUDXy7N z@%-p&q3~tqH3Ht{rPu2{8;sca`voi$G)iT9Y%XyBWZ38^71Z)KrSKDcs?ZOz7Eq4+;dOR?Pb<$4&gW>Z`K>o7t?~%v!svW1w z=i~Z|$S2>!ICjtCvvWKw7^fmX$rf0G?SxAHaVGv1lN`nR*$S(bJbRH0Zvd zfYmCtvN&b~ji5C6PR%oZfWPg()%eclek*PT-?sn{A4=8x3%@}i&?Ve?Evv4J+A;~; z)EO2lp7%W|x+D=C{sm}a&3n6U%)h!izZMMw{hQxuatBEgj?McWr8Zd}^}JfPElhg( zy#iQ)WCv9p>AgpFa^C3E2)i;!58FMji`qEb(M8OxzT)wtvNQtOWJv_=&%$b1G|MNv zEP>X}VZ4;biwA<@bBDc*$sNB_%ie=i%RGOne4|wLQ`}mK;-e8mb*ZZS&*zN*6W?UG z%LiR=@cWPlQSHc5t3(w!0WbL8_3M#C3Sjv2R-`yMUcdMxqP62SoM?~u*uN?BcHiMa z@SgM^c;M+W1>H>o3jv{z^KUap96dUZ+s!$v9g9|Cm3J&^$&a@ zvNm7ir``!L$rQRBhqzyS};lV28`@O{0?yKx5=ZDRqsxyD)It-&3V$X?{kCSVkCm%tv1yuI=)X z{+Z!hxF|~Fh&WQcJolu% z+^qun=*|jDKt8&MhkcB<)%yA$I_w&!T;2Av;Hd-4uYCwwC}Wp5P5$ z05FRIFwDw65N-KDJ{jYn}&thVF9MD+{5W4U`ZnXG;J2;*7C=gn;_ryQb;NSt7dasMNr81a~sOfvF~oa)wq4;EG*3)MNeP- z=}2)FaP^l7E=3vK)+t^EAi9$1G>eGo;3(21stig*6Jls2HVO_7WRV8qiK6|ykH=@* zB0rf$wGn*XGHHIq9D4fP>a+{ZlvU2?rF@-kcc1+_eLCHaw`=*JQDrOC$^1;H0i<)U z+&Xf1e1GJoxwSd1e30^{L~(szEX(tw(c)fB?n zFILGi@>Em)@O2Bt)+zm=r-G7W2g#UJE^%gzC^Yc3>YMSFQRyw#-SaFe%o_?!Pb8Vy z^%ObsyLf!g92lr`0%`;*%ry{&!7FipMG?dhXl=xw(D+Eit1@ItRZd8ne&VA1AgU(I zrzNe5kchX?o@ZeqQcc<@eu=?jnHHGZFV)H7&=oNeD+geyuCNpB0{N!J$(!u)pf)kh zF;i=y!UA36rR^?vp)fsVXdu)1l@Zdd5fWu{KpODBh9(M^KBiBDX`@v_;57p7kj1{q z)%ZQ=Ao%@CPcSDs=AkM{HzCCwYfEu^IRj_|NQmKs>r#z)flp5 z-Lf`-5M7%62a8Kc4PbH6GKCM)%SzdY-%dX>{V7uBw3&<0_9S{Zd|i|m5;vFv113Pp zz%mxWr9kbL*&p_rJo473>zzxuB>>c@3_o5{(q*kV(>7zw2q^pY`-m7730t<*TsJm6@DE@OQS5 zmcP~0#WtaaJe$XQ>g7J$_~~@o3vb@^&w48J?GEFw_4NMfi@IX_3;8V1ltJ~K274b( zo$FJoVDEjPo^pfhDMbiMkTL2z#DWXIorRg62jissYnC@Y3QDy?u($aWs25VXkib_{ z_owD3N-jV>eQ%7Zii6mJ4Aj#Ypq|D()>HZ@Oek!sf+V?~%5a!vSZX3vJIn`oc5L1r z5LxUbZ-}+8e_&la$Sz;UV8QEYY_(9=t89b+-f zl~!!bV+FF0!ZuJVjej@}@Q&2Q21GS5k%FEseYgss)w z9G3ivhh2EuK_#L6dtTuR6Us$4VKxOy94%b-esr#TFp+=0RMq8FfTcO;nj{fu4Z_LsgF zmP8C%Ouf2~%Ra-L{p`<}O# ze$}$|0y8gsJ3c-)z>&K*RHA2Sup%0|rIvm5)D_p{W&9*nZ?TKs`9pqe#=Hn(>J#tb zk@bXXA`}#AfGU=z%}w@56~pZI-A7;RkfMG0lbWO*e+p636C41q$%}qdZ|7*h+-G3J z6;_luIz>;{6az_%3*Zgms4<8W!j^%6nG;`M9w`d5ed$+>z$XjJ20f|g! ztf=yTl_LOlY!558copU*1S}S&7)~s~hwbM|1W7DNI3R!=JCEDr%Ac%pN1Ug)E_nSd zZ6Z3vAl3QSqSI!)ID4&)UQIJn?{?i>NZ{GX8tWXIljhm-y5o%}vEb4@x5-I)^6kU* zfh~9Byq*|8o0RXm@wHli)AR}AMJmN($JXkbh!$3R zYh4xJ5(A$0}Wy-O_Nn;4}rP!%T z00*%gXMcq4`QY+D6W z{a7eUd=&lFLJA)RUs$hYnUQr5Z=VB7KcC zoo3bDI#pe0>Q2YYG_P+=|9@or~TioVdPaBvEi@hNmG5du)37Q@tg;OZRR}ZSd8GHJ!9@W|Q40!=QY>Ezv=MtPNm$K(9tsi7sWxPtv=!qynf1p9Q<91~7*x z0~p%Wofk4i+gGU@KL?9?=__~v;6=qgXIgE(@qBcQi0r#Ij@snBgp`30Bs4v?Dc3}~ z%@ek;KaksVvg#g=MHh5wOY26Me;~IFhg)LC9J7PuE+3yHm3gmU`6OQj4BR%u^`5@| zGqL0!Q$Zot8)t}s3Yz&JD(LSZg1<3hjSybs#H!UP|K9K$$yNKa)xMLTEIV527Oqu$ zGbzypLE>}jareQMrxXcnOR40L3qYq-e*133J!SQ1nJXV3;GyxFB~?lUj{`ik&0Cj< zd@hgINB|GbGGleJnTERWhYGOYUkoLXL;~AVES>wfB&!z`RdB+3>_o8>o*yEV0*1{9 zQHPqDyBzTY-cSr2;Ltj`wg&oF0lm+~w|`F{Y;8ilI41@aP_Oyv`Dz>3J;BdF0X1HU zTnP_hf4G&W25D0~k*LEdq`cQM#b#XF(+_M|N@uMw0t9E77|a6)L1 zfLvjd0zzXSKR&7!l0>)gK$gOA?G}1s>h;4q8F{cFrezW?ZIP=thRwB0oea8Rxm+Z0|>OlxKDwI>q)5J;0i*WJ7Q)a#CHqta0cro(-(;M$Fu z2_9K24kBKJ?kkRTAfHO@{nKv${f+gS0I4Z`nO--3*l?$efLGbkDgf)4AbM*%`3W);Ut( zWr{iVw7^u0Lb9His5yJ+9i z@soFSgtOCCM#tuxyO5m723N_#m#9+4pP$x9JCB^ogFoGR&&qX9NRz)4jTZfe&5K^L z^N zVOV@)15X~PO}J8(Tz~IFL_8D*bGs0iSP|S16hDUmRr(9j$vpKweI=0qu8YwY8A&9O zG~&k_y4QXB&kR{hjNuG8BT;s9N27(CMar8whs7%nTTS=WRKWiHPqW;*`}_-HowJsRe4P$$A-s`mEq& ziHU(qp-CB9p@{6TJv3jaKfXe(||%k|u6gAe}ny!)0@}@gVSKqTA_i zj6K)fMQ!h{r6|6 zzfACnI<^_C*uh7%2SOShX!>NFBIIiI3|h1{WfyJ-cvuzsk=Df^uJg{LSz%22$wVAK zwA9|W9ZLY1DE7%?U?=WlV5dnL_CZk>kax#PS z>vc$igQvl{*wKy0MJm5@u@&BG-NYDU4JaoD#fRfw25K+&D5+87`KVgcx>?4?s^Cd zU7Rbw4YX{bxSX`^vLY!B*wai54z}0KTtl+m={HuJ$DBdrIcW=1UZylFlU-2nTSRl z_F)R(m4LUs6yP26pL0w%{lM3S=iyi;#~wL5ra>KYWh{J-o|+rtOH6*c5-onZ;S3i! z_IPsokP?TAQcX#D@{_R<8*=&vrVEvH96DYyZSQ0vn110Q|H(u_M~brN*ovWwS@={U zX`kMo+p&sdc`$e~u*%=l*PqP?;Nbd6RQb_awwPn~KXP!@YWTAN4sOV3ahzbgTd+E5 ziV1PC)9(DVufpiNn$vM4@w&YOl<%-TcR+!3$VrwcqC}=)zF$B zwgZn-qdUshEY=AGY1eR>lYwE}3zDw>^4KC7mr-yDb+(i2$m0%pX*3%pP(w zPOibEw>FZYn@M1*HqMiZ#QEP;ZG!IbYS1)5)n-$c<7%Qb22-_Ve^Irg_Q)i^fT`NU zGg%hDsoDpCs~F0V+3FWnd+xO8bMSjBfT|6+iosOvqhsxVQMGpfs45O>wGfdJnH^{T!ixLMVqMc)Z^aR{YEVgonU*33Y zVhd#$-pPzB0{dNu<9sDZZ|oMzl6>%gW~Lfn>>eog5@8Xjo!#i1osS5_mH>6TGS~m7 zpZg~sOIw-E~%w%7e=nqMEAPDIKBw=fabP}rq=na>`J zibY&tUfGz*Q%3cn7b*J^~Y5MBZSz`L_aB0U|e@ z!eEY&Ue)_i0dUcAG#f7A3}3~?qU&)#qARo?XJts-&}_26yfi!g(-!cLDK13S!slVvTT zo*$DeamvVAt}0iFahNMubxJ!M5J|Yvm2RI%)15P;Omq65(DpaPUpfbxFDWD6XQ-om zm;RMJ{(;z3ZWt1s@iU^wF_1jYnEkbV(s8=GyTn8lT51SdlAO zo$`}eB=Y&a5ffgc6UWY`f6AUsKZdT`@AGG2NldkQ157snE4$VgGQ^WdO*lO@iVV)e z+ez}tuAIwqU-<6LjYdyr$$b7()aG+9gG`_0qnMF%dx02RpNE4bg``sF)8)Orw!5=Q z)z+Uy%}cu8UfPGJ2M;$qY9XXfuip)R`}m-}`f{4(*@)iv&96shQzQfTw{8o|T;`%f zeX(LC(YeUNgNG4w&*1b3oWcf>o)HX6uhS6_*0p)QwGoG=tJwzc14}C&;N1ss;R*bGgP;B5hWTHFp zT*tQeEG95?%*L#Q^v`if838*LY4Z)XMAr(twcIThQTIbA@Pn}vL%l>Y;{5MY1BY%J zGE?L4UgW7f&B8Gx7)eaJQU9>KH__l=t`JPeOelptv{Df}tx;4m|0MDK!G`O*)Oaf1 zJYl#hJSf5u?DJN?f%Mqbfn9SKCc zy1>i%b8$bEdarB?kC&>KSqjE=M`@Eiv`EG!Ki-xX(C>OG(z0va$XV=R!Lon3^(wlQ zS3dF3GO_;AB@twkKwDYdl3kTb@ALA@1Ndhj(k35hKWgZlxv85%mqc(u06*OV$y!JV zpE4d;>6yT#^k_RIT$z9Y$g#Dl8=k{Q9Qerz_)kJ9HAqV|A-# z%*sTPbo$I{IJS+{H`hi2!^-+h7K{|CBQlPLa01MNKIx>1OKHJugb=yUsVyrGkRqSh zq*BqS5?igxzptahB{|2x}FOZpWM2nQ5Ay; zO6WsPRo5N&Qg@+- zji9)kWjR6Y8e_L(4`LC`UxzbvN15mN8FL+T8Z$88f4z2Z))t^_OI?pp>=!|O1LJ4v z6qamXbN3@&?p?y=b^l!V!UDWcV*D~a#(p_g3B-;RnHTMDlnUS015&@_SEk0m`lsg^ zs0``}?bS+4wz_jg;%=#e;!`}J&)19GPOb)?-!!BlTXmmFIBBtoiFCzMz?jh`FhIig z5J(?Bh@+FeaQE2$3?lk&!8`H;9@r^5l*t)XJK9#ni#@mkJH@MD5-4Zif{BeL4YFH} zYB6hmUT3a8e`3QAOp#{F-@mi72=H9oOAXiGWbEkDE5LiZ{v{JIG4;0sY-kQy6YL)6 zXPuMBZP)~NlLQwRH+aZcCW@!43zhy1ez^D*gA7{CzNMd%cjxwNZZ}bJ(G?A$@2L6 zNrMPh5LFO=kQ|Z@!k4qNUKj;nq6PB5-_RFAF#dKm8~=9Nf*%Tn zq#;O3fNjXHf;JY#?uw;OB~hN=Jxa=#15Lw=BDQ?>*bQovq)x@tI&3iK1cBAHiGU?7 zOwgD&CAMt09H{T~TdSUPnD7Jwq@&OdT!Q(T`h%?DL$NsT=+7e=HiG)!#4L`}nbq#Z zZF(lh055>NGgcC>D}BKmKuJ|>7i^3@hu>nzk6aqba2Nzz?YEuElXN~>*|!DseCB`j zB&WBAze>l-&m49)eYHQOC0}Z$+Wm|vJcG%ME@^YLa(|04*+DYtq31`_utTtl=2$gk z*ILf_E2eglG8zah^HKZ=fnK_=`s1uJ?D)Fn6C9GyAuAkdpcUU5CR$aS;Yk?J!YH}J zbF`#*#1GD_!c@=n*~2YQ^XG@6=+v-Y5l+KYPd0I&(n3f!<359s#K7l*taF7VS{I6c z_y_Kqv#2lWIf0YKa)m6i~afAcehqhn#ZFWA8qRtj?o z1s>hJ9KzUEVSYDGy&hggh`g}0q4Ni~_(^&2eZh?jnMBx>A`x3Qv^aBh6PIjq2oh4T zuV8*&WeyxHn_y-#l$zM^liiAax;)tOKE!e-U%V7T#G>gitXd#h!NF;-DqwA|&SPZq zrnUA4BU!;!_b2keGK#f%iasv0{)?m6x52MuixZyKYZ265Q@t*Yoqr?KrYj|q`3Y;k zD*2(mc#RC652`>zXKk?B_3nlm6`Z~NX-;H$A-_{4oHVg+KLf`cc@j9%4Um5V`E+aM+g1X}LAN zAfGoAERKJs{zBcxl@;yUa;Q<*DMjSTMt+jkkQ5^h)C>cp5e~}iDin(nNp&x*agr8_ zG{dwPx&F3H5Nebf>k4ZZ5^xJWH%$FUwSPgpZG-NR7N=v9XqN^o)D2wLt#s}|bMYsB zjG>E(!7bR2BuTdJ9q_%;N(gx6p}tN2*#7-#2vpF(5XY<1BkHV~9!QTb*mFTZ53{u{ zPKIyiN4DZzWC97Fwe(A{M1d7`@tV$o27RlTCPCJD`)0D#FyRVe60~ zG(God@SiE6k~3k=Yogw6#ms$Yvyan6P~yI6HHO@g)dcFDzc`L)by&^X;( zIU_86qgh<>mpB4h?LHSf!pKbjqAWZK70jBG#hF_-8R8E$;?kb*uX?0QNnp$ku|c5y zfy>vITl7w61DK2_0t?8L#W_{9l5vT0_9UF-ilys3CmCTp`W}fy3b~uCA5pjM8Iz7i zI#yn&OF63G^BZ|^5-a5HvW8bsC%iM*d+=m-vL0klz*lnN3F_#ji;u@2S7Ie8&*v{i zsoeA(>!nX50gvqw?0=y_d;~HPm%%1g$h~F_FEBnlt@b#@_l>^gSz}yUPcc@=y#O+#s5W`W+=wz=_3TKCIVTJb*FSqrW`vpf9fDu9 zIp$eY%#?k$s-&m4BdMgOk&-tZ4a;cKM>Dzs?ES%=Sw)6`WvWP#dwTtCA?yT^x$2?R zo=DnJndg!)rI9G%aH?HOesnYe@yd$kG5*jmh~Z^SjFl2|pn`G5+3*uJVxKqUh$u(} zsNiFK$%DsX#U>9An_HCWCaH(TasXfsABS>EL}5{MLJisJ>~pL03bTD2BitfK4{bL838`HinP?93Axp`c?Ut*MtxRA z$jV0!cc+7fhnZ32V@2Yt$KQ!WOp+e?1yr|5yVi#p9Z_4AEd{VV4 zUmBGM^e08n4%lf0l2L;Q2C?!=O6+Bajy`rOxuUfJ;&CV;vwvnte9fOw0RmZ%TJA-5n56}-Q$ zxqp#{^|7*G@WI0%9)s;p{tCJ+ck(hRF|w-S434k^i>tZku1U@rT_XDDz@jY#*NH5@ zv{|+GMf-h7N<>b=s}I^dEnYJ!gvQR_h-|q&e6pJ?NXjp$iAkWsK9qIC#8a?s@a50UmC-YBXPJc5Zq3G1)gaX zyGdR_;Y-JNnxk^GLjr@adm`|3YOVpz)aaxcqC9!DzL( zy(Cr^HC}3lX-m~v(T?=u^dwTb-8&x?to726`!OJsH{q>$p@#&WB&uDOR2n9W`CYmQR zeuc1cxr6lL+bJf2`OsEwT(Bq!Z@ki?w{e62MfX#=t0D$PHA=Ma(N%CAFH{>f&EY-k zRG@(`$Z9Ug%rY|lh$oq1FM#jHNdz!dNxPL0borC|feLEq)knDjZ|UIsCZri9w#iDd zUG_AFf=eP9pu0+uAO?u}FZ}}BkXd7;l6UpVNVk+OD%L936O@VqAy-u;Fbt7F(g^mr zwTTqK=&Or)$>&Pyg3vvsNSIu#-Ef$gqT6RfD&cmhkgL1|>^)0?c4c`8xqQ%wh^sC9 z1p;Qq^b$NFzSY$e;#fVU;S}0i5;q6XPr8*zKttt8j;N3;Ed(aaXJdh^Nh0F)n#YOr zhsD_i&gu&+$yzT=TD3$JEDAV37#n+dTicIcat4h&k#&2no`S7ZIZjbrhe4?5N!7qQ z4VUFFB2bH+OXYy|&1rutk;{2KEU^#wV&AXOcu_fZ)XtG3Y_0DN@xzOvsCCyoni^;~ z5)Bzv`}173sA2IfmL#M3)GnsIMOC{n>2_m zuhL6g#~w4)JACvOfZh01r%W=QSuC|>K!0S(lM~5VG{`iS)sZ8xG~l6vZ*3a01`Jio z^(o|w89m%0Q&UW19562!%>i38~pG-ZZ;mB!4%v^?>#Zw}i!K5Tf(Uf65sgnSD zMnRj4k+85xTu6x@^||v~F36CmQg_z^`Z>Ql)W7u!!!+vl^Z&ew`ZgyNHL(LletO#V zFc0`BRCKshbhFY*4EZf#n0+csFSIQzUX2mDp=r|CinR6|SWt|y$v zRZv8bp9(tITiU;l{b;U)ohynGGsRiNCsXNV?20W%H=7C!C88XJ#O6p&FqN}$G03ME zo2ySLRvHO)ZY~ytcbLstltN)B2BkHTtDg^ChLa#===+j>8;i!=uOEFg=>bhhjx{D-9)bE>kbDmBQjbhwT>-B5uDm(#CyO2KVHzrB z$EPw3S_@bXUdUoLt-b)tj$p%E({Z%>H9{80V6)#Xee zlmC$)s>@jK1ax?D@xE%Ns%R_Ceh$vCiURXPfp!F1%~<(-DjIx}r=8{ZW-MIwK?JOO zPZClFrQYE2;90`NqVT3!3X?}lBV7W?!;=9qw^{OeWYlwx-&Y4n-Z68K)xN8dL4{g_ zoEBTb6o6TS0If2-`Gy?k{jATxR?gpo=u-kcc6$`ikPu2qIktr4XX!;t(R3d7c5eFv z?iS+m;LpG8byDTQK7$~zZ|k{~P%_?Mk{hW)7XYjb2o%Z>Y<3p#$3oZy$6`HK4ct2x z54T3{9eCS1ALy523KRR!oZZrTii?YwvW`~8UgLgUp1ME(+W2jp^c3ikeU(0PzH{4o zYSXf$3$@vyYU9SMZ4_5k^RcF)wHCoAt>-H#t;M1Nu;$&bWaLzm=Hyfcq|)8e z-QC?GAV{cm3)0dcr6MIMrM_$9-1p2p&vW1J=lSAztc!iYF$Z(bTK{#Pzq4b(QYzLu zqY5*q0UfM?S^9ulD+%4@5FiB~?KRO1nos0LjFn@rNbnC8oJ>2e3nOQV~jpwX8FW0W9W z?;B}Rp6Vl-6A|vMCs05UTb31QSX(7&T33{n)QyOH+hR0AHcd@ZT9FS@63xnDS&_0L zG4AtNWHDG&JXrhgsEvIRpV|LBkc!m8r%ltOZS1YRW!@7AeS)V$5qYVyyZQRSc~S}a zVaxhln%72bg7$_OvXH82kU8NFL!{8E15?|p(PXC(8G^%gGZLXtyyw6(yG_xl()ntX zz;&aO=~Kv=qbOz!{^!x7-lDiR#yK+)5|Ng%&hyb^_Yh=Kl$O4PE|XXCQTiH5o;_6z zLDgHs_gqMmcPYy95X0KS&2&@f^J%go#FIepi$x8zEFUrK@^+QRDJeoSi3wrMBBsIw zUCAUP7;5=~C@Cb!nhssZt7yV#Aj*tb$%Jbi(jW6hsoRvk@_YO}(+WCMXbneMA!3+Q zgqg0Z-zN<9bJiBfkxx7C2Dnz{T zV3v-EJ`&lYTT6%ht)+ude=sX(wjEDc1U;JSGpGiGb*M0e0KJ~4(0SjipQQH)t^Zk# z;bfOmCCD`RXQ`MOLiF$iDn$xOBaJEepf|CY7L%zhR-?DL6p82bdV7Wc7<0L$C;Y>gwFno4J{AXiX{xH z4|8TWss*jFJ`9@pIecyYV3_|C(d?-7cc$T4k#x$lhoTAJ4Tq&ZK(GwS#Aq2=BSoj+vYqawIR8CUqlFGgehxu;peX#lNy?Ji>3 z-S=+AoCa^0q^bY1E2+u&|n z>V2n=m@#=1rJU-_h#DeOY)wLAVtArhONgjHWPLT8_ai0z%u?`0G$Suia)U)E2vY2Q zubj06>$MEQHCvbqk$Hqz2`)Omf-=TK1&nj2hDzcqwjdWE*rq+m@R8M~>v1tWVXTN@ zNA{Xw8;wv7ix>!7M4-k7S*w726zRKI__4lJ+Dy%{EZ&*s!)qbRT_xj=(K-erA;Ong zhD~0Wct1^T-2_iU$Z0eCe3C)&iBt0qV{Z+kqR{G~d>Q|V3`Tcbu7S z@)pJ6rpR2DS5RDn?}i^m%Kk(n;ihe?jhyc2!F=r0%biVC@O0z-4Wz$DALn6T7t{&+ zJ6r##ahrw+mB`(PuYq`bg$$6QELkX+Sc>TLvnn~OdD=!^uy`enYYx;lN=qr*Z;sQ#k{34)D)QU@&Wl8i1!`OXPh1m&QD#eEi7DJ zIB);K_eUB{CI0qWA@z!yZ7rA^PFj7a%8t;DbG9nq>d%IcUp^@JlTwRbO#;7+*vV+j zk48_SDr7MX^HO^ZSe9ba*?7d=@T0@yxnxXG@nP5~*HYBQWC|`7_Ott?vU6)gLB&Tc zyW_r5I)RxNJK@W~0~rj~RDmer3qC_LP=2)&tbM~Qjv|L{)?upk z%AG&Z3442)Wfx)qonXJF(yB{IBhZ+5uvJLHoF`##Xg6OL*b&cXNkNIVjCXI^g-jwK zSy9oxX*Lz(xpG*R!%}{-u<4C-`~EKu%-Bf0@kWU*Ru*q#MZPw0t?=whNzXg*Y{}yI zEgQxSE5!>my+xdLdT*Rwua1_^BjgzUFqJIhHmt!_HD1;-!ef zr-lFkgnkqEi8bqtV|DX2AbSg6>Q^ zu1JP*(J@?8gqT1*p{q%Zf204;nA z(jAw05?~o6A5dQ$AcA2{@v~HV!|*R$*c4qu;OE7CgMJK${wY)DxpsCmP1MYbCUlL( z)sEL1gg#7iA3LGEi@Eyob4~9)-+LT>ByzsLz01_*s#N{tl4=~|he#^RlTfjGC$v zcAmg73AyrtwmvF3(mZOCQav8MjtNA;;7BU#oEjy0Qa*MNkAB@LM1klEH6hBfA4S%t z6Nm2gJqrfRg*%vyY%SixDl^#py4nx9t0MQR?P(PC!PqGARLB@&Y9yFuXjc_R#$h4d{NC&d@6xn!uelj+IOc*+ zi^{fMzpRQ938i!%+vd{CK^6}8DXE$0s>uBZ!FE=-;p+MW9t!Ek zWZ!2LcQoQFi1Xp}5m?7*u-h7A4im7Ajjl>gGmPzk(LZKK8FpH#Z3T3x;J@h79~m#>_#)T{Kycxgq&H_N6dT{kjL-73CGWyQJgjW? zRZ5fF%*tNC+H{miWOgJeyqNlXuT`xp9>04~(znj$q4p1CHV|dsShVBsm&t%c0PFPJQms#dF) z(5ogti6J6l7s318J!IlrxuAOVA(sX=h7MSYcn@5{E5TYb&pcM1+swk5v6naw-jPi- z>z^*04Xb0Qxt5emkwrnULZAD_2D*n*ZpYBCNro`imY1 zU^DTrVMsF8+aVITp?T&TcsXtnm0O{7%Cr*?C$j-+&pAwl#z8ILSXnpIxTS!b>)Q#< z?4f5L7z}EUXMH=2XzpciJWyrm!v0Ah6E???m29TyoR81rkKWPZa8SHvP<>a9;n&xF z=I#qLk~Kr`+OrSk5>nN}I-BgKL~K8v6-CXtGEwqizUx4g04yj1zP1*Oy zt@C`?d?o_(r4?}x>`5=~@@?>)@F+j{f;*sq_6rj9>kDn)kH}ohBLqdp`{S0PyG>tZ z6(9SvgxFz(;$HWdlEqK$(K6ATK4RF@s0f*VsJc2veRhd^ed9!2?j_fF^efd-Z}Tsc z=M-Hj`(7H{o2Y&STXXVcnOCJj5@u~_-b&RXN=s{Zm!b6pxa-6g@}j)&>RZ=V=gxS> z(!KUN#XF*31Ul(H%Rlkr?NnuF_4gFzEN@w}SxGzdCDl9A#1J@-?(Z=8*3}nCRMwc; z`2uoR=kcS#4kLRSB19+jDJgXoDXlv*t{%!Z6w7uq!UAlbCU*Cq@tHtSZM)@g>AU1` z36D(q!~!UYW5h-7#nGU~LlE)5K$SZ9YPRpp{h}s=m5NWFvz_kRNgJb2BR+@gbq-+)tt5D$Gfg#hM)Okq6Zi%J9~|4G z(wtVTAEaul_zc|_ntL;nXg8U6fK5dZ>Nb?Hx{x$d7#(AznD@PAl}dz!-ALRb`wE*@ z&6`O@^f^c3(6^eqvqgS32Qt5k2G=y=B-JlR4IHwDrP`c5>O- zDfNu5Do%5Z>smW)b{RiR@7D-iMhZFw6yG~%Te-VM{paN7AEQoFX>qZI;JoWf{-1YE z|En{UZjC?`MNfdPMpyO^HwK`i^u$4y*d{;%wIR7nNrA|K@LnXZ@5%Uu)sdq%kN5fj z`bru!5-rN}oh!qlU8KM7W3^Av#<*8RsqNbgB2Lj%u+mWM#l2^}ZQ#JWh|mAt4QU{a z-$;Xe7nYa$Ag2MqiP3geLbW~dDSgbeyfqcp8fwr{fSj5OI!d+l={KCakC{FLn$aTO z$MN;sgG(~^Yx|z2uXh^oG+VWv7b!Gs*eu!J7sS63XB4)Woa{>N5hQ;X@&j-axnSHx z%qPoFJM4c^t(lL!FWLR+&_gdQa3c#Y$qJ@g6qP_{sCS@+L&(^BE(s2;Jz1S1i6rbV$*xH6T0w@t31s;1WpDRPj-jwOM~=E{6`hGNEcm8D-WYv!fr*npV&b}6BvtYT z=nUnf2iU|Q>b+|P9sq7) zB;Y1y4Ni+DG3*e=9(H`~mFIXB8;oC1exs>fPSk=4GW=!=VUIG>XmCFOc~V0}m@~9}LAi`ie^IO&5aEZhP;O_G;f>Fj|1e}| z!weaCw}y-)+_V63kC&kNnp@mTLF|Z60=SKL_nltntUd~O=*Z0heS$Ez)DO!RHC_ zy0)~`wc4oj8Hh2!bOA@+D(%&UAdsMA%S}@`LxBO;t4*eCT@wWN8e0TBk_?eEs0_z$ zRH}P`ku_#b!WtaXfX?X3j?G*u@{F!Hj%#F&XyoBLH=7rhq`h@qLnPH-Vr(4KrmYLK zQCPWolq`&BM>BNk-jT#f1jjT)y+=h5P_GL16Zri^Z$36xaX?Sj;$9cGgnE@|Pvi(R z)hU$AeDRk)wNLWx2PnyekO;*7coQu6ApVtY5( zLu{gjvW?-iW|+%@c`)$P&!sx#?f4WjUPs)=VKKS5Q<|Z99y=oc&}bcxMS!Cz zWwKV9bR(l;5M!G5t$Zd}Ena@a!w{TVGD~3lV5Z6?8b1gQBzv_8f-ojm68iW3IG6tO_3$I^W zUJyN)cyx%|7@nIKKi;zGCi@W%A0%ogj)xcjar<5)H)Q<4v9Fkvi0gK>@g2hv67R8q zWmAeqt?k6`m$=GTlJZ;2y>`{P{) z*Yn4;;rvc%^)_FK4brGy5b4Lsvb|FnVYJzK?Loh!NTc3EW@!GP*a7=WEa2V<*;{A3 z5L;&oBt*z6mrjIb_9pe(93Tq}OqCTh+j_>SEq@&BzxFr@o)Xn^vd6Dm6-3#V|iez@q`?m2qu=8 z0B`f+ogvfo6T3^C_4^77nXZPvj5DBE`~gG4)kH+$G$?cMC0?1E z7Afo!0a03?xBUFk{ka|CNJjywSj05e2S*97U^9)^S({ue&ZJYc2@m)k^dy{ zKCH|UPhB&h8*Y0N$CQK0Fm9?39aS)0PYuQ8+C57mDku6g23tidMFL{5YKU-C#Vw$~ zF_}hbxUVo)OjspuJ#{};r!k)DtN{DAGR#K?{hA|}+ezlKQuF6=4KSpVv@1H$fn9hHO|79bwT zVQD3VL*NT;pFWxTzWLYf)4gA{kK&qVW-qRf`Bd|%vf91hs8KJrxBnzP9KUtiWpq|n z3)*nZg&!V%Uh;e^rjl~Kv2^9yIzac>Jk^}i-Hrc;MNWsmnBp#W_T03oi*aF|bkco< zP+!2gB78+XY8iE&IG()~trO=a%061|3wO+}K5waxaA{pid_1WX`n;Ro1n76md>7IP zf_+0^jb=2QVre}qVouqVi8S!wwXWSqxeLXKn2=<3n~>5S-k%P#+-eG``pK6ig9x4T7+DbW?H(ySyn7#`WJ4TcAE-EiEqnpT2Or8N2 z5eTNX2Uj9LU2vEx}7K z?nb$BEg!;@UIz$wX-q(Ok z3Hv`qGfjHj<-LknWHf$?a4KL+!-tlo_?3P{cSBOaCBK{X?jsdZI8Pt9#@wyESK=t{ zcsJnD71lwlWssC(4+4ZI4KPJmkOJ?Lvu3@kh(ov4fVmQRyHDc*`D^{Jkvjc3#-qeT?uQb3q);?DfYfeEYyU5s znSYGD8@-Haw+8a=L-wDy?f(u3{z-}@_&gLAQE%WD+Ma4q>plO7e2|vdiDJPrP}lE! zT&`n6tLfc96i|)zD<)#*xJ|eGwkYIz@)*7jxs=^n*isi#km@l$=L_ zz^#kNO>AZ*YvUrx0C}> z(`kay*avqFHBv7eggO{;AuS=vo@no!fZ};_e;4=q5ZzWXEZjsbQ8|%C2LQaa}pJl)0wq3;igfawhEgn0(FJRY`K-?A8dXci& zdJ3ws@~VyS(^diHK<7=_(ubfoYekJJktZ~-F_NM0za1@jG+&SQw>PN6yT5%L_4V5j z76QWkNPvxD)M7^sAyQob`A0agpqNi#bC2V@qdCs|)L}x%D}LSK27kUHWYp!taIiU7 zr0VkmJg@R^0;tQmu!Wa~@nxGD5rd39Ef{x7d!aoSnC&E|^KzdC6>cd0Lhk(AHC5RY zF^VB%I`7FfuG<|ut}t-7G3<1)9WKMQXXKhvWBTLwT`F{U zYwpO)pZm6B`tYIJ+_%E&>TN$zbbRA|c_iki^{{j0;LSbXYnS$#ciY11OPneXsmmFN zy<&8*-9%?}E-bJf2T&NdXe|^o*=-;69Z5N}H z_y*d9Ac5}oQJz+|o*yqpN4@?#SpsnWKnzGXELXFsEWkhKH>YO<;n-XzavgNWljQb`A1<-IV|n6rsHk6@d2_p?ATBSH{l^zdp5?3u{DU|W_XbRj2W%bFtvUJur$Q z$!weQR6JR3^1?Vgcg+dYN20$3%9$nz)(IRbqABWvgDrHq^j7oCG*jX;J*2?0E5$pe zx?Z_qZenyx~f?bJl7<(c}}a_Z4&Aer8sGb85AzMHKcc-kxjE@KZ%GE+QH3AQsbz` z%{(%wP51gGnoMO(hQ^J<%OF$wq71^)LIs~oXMsv+YGM&dG$E!79{9mkDC1DF4W^&P+jHH;2>Ut?3MT-(BBLu1U zi3~ThQu3t49MLvWx(bi2wGt^esnfIgbX3CRBG*wd#$uI@mcM}d|1t8MUjc1({Qt=F z?_god-?G~-sQRF8eo{`OMYCEbelCu?8+~BNT|luK$TOC(LYpFx=e>1cJkAiKdJ+uF zZZ{*v1>r(gd32)OwLa!c=oVu_%xw&(}+?7&@= z-WUUa;8#y@7d4e+;5kEX1~Yvj*EbQsV0P9}F5*zTt!4rmw!g znZCSkOR8B0|Di$Sws+n^_I z%9Ee?QjJ*>yADa=q^c_#`q=l9g6aM6^$otSL*2n7b?KIe9Qn^#v?jQna9FUgS<~?I zPt4)4bm&}2>fN(wIffTs>KYPO9W)kUmr>#&iiG7CP3J26z;|599`aoOMLMjv(3Hjm z74JE3$*?v8T2DlYBMjqB^=9S!7l7*8Jf%HxG>=zJ9Y%z_;?*6d_2(<_M%{xEXlNAA z*Kp@Wao|KH%MQ{V)ozZyvCM1XnG*Nula&(86_(5@f}=Lc3Ve->31VPf{HfXA9>HO}s+TlIpyUL;;U+m01KZam+v zs(xO&Yz^@GY5bPLwzB&2^QBE(KGiF?GtX$)&if|IVO*las58K@qq16}QS31l@DUh) zes{*Kxt{#$%qc*TEJjjDgR@d5!1&WG*emGYV6W)z5&-rxl0;tzms;tVg30tgMM|3KCa~1LOdyR}8t69BlnTb8 z?**8|3WC5Isj8-fPopNIVkp6i{Ujl|yqeZ4!Vf4wNCmLJ#kh%wdMQU*T1Y4-j-;^4qUev2i2Z=ApD%;U%=QDcm@lPgs2p|J zkRPsCY?%+tdj43~Rx;hviU=Vlys?AyYb%rZRS*#Mfwk$VkXI>GPr)DrwnjqKhi+OT zK4zWBUHQ5_&_ykFC30^~W#{<- z6@WxlnvrOXl9k%+b1zu%g3agPwTZq2z% z@IS8F9z7Z2{llE=x`8ZKBkr$91p?q%F1v7r{76-``_3^~)ompM4=Ei?Z&_ja-q9-M z!tB?wjoqfWC7@TmC@^7H7*j_FhS)eyYH@#Vy{e9JmTll_S)?d%J0y9Hq}7PfC&$;5 z=M6okf0y4>>E_!hA-awR!%f2?JxbMSjcBkzv;ua{i( z16iHu9)Jvf(UGL!Y#Dl2?^IRKJFLxp$Cq;i{s+duQ@FHNT0I%Wu;If!aszhQjAV9d zYK&XAaQ3$RKp=NGKVzh@-o4mb!R@aYXqOao9^swML3t&Fso z5L0#v<4)qeCV}&p^pVqh*h(2FfskEV6M0lx@yOtreLE^TDm)V=83hikER?`!_aQ;w zdcb@{LGg-lqa*rnb}tpxUYI)5bOe zO1%A&Y_&XxeKO6LdmcV*D)^?;U+1u;8EEvrV@_{%_N%%))pgm24>t#Wz5Uwq^QhB3 zzJ6V53P1X^ZY43c>54gXHR66|Phvh~tlUh~6U`YvLx zHjA>gvQ+mzvFbO8gz^dg9Gbwaj?WOX4=PezWd#Mz^}=ylT*G-9V#>#P@(e77z4gNA zaon;ZJ&wYvr8@?7Y~#@NpA`Cz^E7%A%B|%YgxllFJ_*rZ`KWu*qwUsT_c&obcmtM8$M>eFwu(fspg-*s zAKHf#RXjIE0XyC8akeI!Vy)mb5~p3WVRt0VXk4(>t(7(|L?_MVXzEkYU<1*)CD`Kr z{Q!TA?c!>!2uyY;`7;?LOjg*oIDj#&Nat$&BjCFJ(*TMU=G^x`0#Q8uFQWK=W#-I> z@Iq^fVvGJqks6pRU?V3fv`Ixjhr9Rl(|4eWuDT4~1OrOOr5VVyazz^=$+P195&_TT zT>#Te2dqaDJ`U+utB$8mW3t13g$tNw+5-KdE^g8h+o9^C$nC^LFcfhe@c;v zFv`6dwnT8K_~MuJWosnLzWyS&euwBo(>r?k%+d>oc}hq`Q(I^;$(xV)R}BH4&8OmC z{MDuAudR%2gGc?-H}>5-j9& zghhJ_kibXUQTKcqXxnvWve@uZ@Fn=$Y{3v{BB4wRz6BhgYSvx!)QIbD0l=fBCX^X@ z`hC8z>S(#4Z}3O;VsRvP$6PKC3`e_2ts1`a?ff|N?aCJ8c-maAlhcd37O!(pXU?zp zvRBim-<_=7oYr?FTRpb)$*4Q*{C>hSCNEF)&?5IRY&d-RDkb}k?a8QLV{40qdl^UA z*r5HqvXym7LL}{jLY}a5#HuWemrk~KJ2m^q%Y`}_kE^@lr44}|V)+v)q3W^(i6bGA z-vfJAIGzeQDR><_=?Rt6o{%d-!aWh8?q8B=(qcdot6ptGz5+>{C@(Ns=(+${*v*C* zTUy)kV*Kzg0`lFHtrBy+_%;1)Lggk4Fhb*QuUx*VL!v&TB-SnaPtf%6jS9%Da&z z{92&{90LD)F=&{K%bGA*4HJt{(=JCQHF)4{?PLxgjMf5<=r@^>N>5$eC&(b~O@oVh zT_!#3;N83Tb@0w<#5HoIpIA%TeDpC_25EvcFoY0$$>Jz4xE_G~Pn@`ZRSu~@1xNbv z|BUM9|3A99{yuSi^GA?t48Hb!Mby1VY9q{;@ZLw|j!UZ>EC0@P_FJxOst~$#jOU;> zL%UmKzz-u;XTX&;mNlF`!l!QS{vI7q{YkV`uxuT0WnIhqVw?S>B22N;XArACQ!ZD+ zF4P{sWh|S^(fvugkR*gzE~7cQ9;p7skff>(X)`{`j^S|c&g7d?;?r!o(|_aG_L-E2 zsQ``*{Wp#+??W!Yu}QC8Lt!{JBW~YhbJETLom;MKGuCrut1ekZ6MN#{1v)s1<&pLKu8f^FYcP7W21lh8gOMlrPYa7 z>e`gdRpWD}J7sK56DIfPfPP6hcSne1)*OR>L{#{T#~Tw2mpN-ehok)trw^GggD2Ah zT#)U$uW0qwGQCS@21+FY^>9e4{yuS)_}j#F_5U|;c;V33B7*j7vD0hAdlRan8@UCfRsgr zj6ZNU=cHAhIg^_4X!_>Qi(@c!g>4pP0~kh7CPY-Tf}|NXI4)vYWV(XF6}*0kxrfyI zeva!ibJy{4EryJ@wos;pdx=x4eV#V;^tr5At$X_L;k(@(ugDj5i|yV*gLjRMRSw@> zZtuAJzj?e?Se`ARnWzH^qY|!*K zsQaOGptK4aCEAupz$jzYk4rFcWoEeAN0-3yC$#O3m!`bXP{2E73}Qw?^6&)EM}#Np z;X#PUZ|O+N!R472I{LwPM*w|<59L@#MBBQ~i?=osMCeWl3i8Lu=5+JPC+GROg zsEly^%ST31VI%@d5(Ww{ZK~^@qp3dFJM@YY!4@(QrlQR0u<3caxste9>b>;38)M<9ITV?iJ*tsg#$s7;B^4w z)oD)(R+f&y7m*s>COrtS&70+Fu;xtJrI4+uB;@>jF zI%kfg$+ahWtAa`x&I0__v3MFO2YCo5k9x@EjFd z1M?8;=vamBdVCG#s42}EmeQexrXqg1C^L5OPFe8ICer3bYGi@23Po;B!tBH#Q*e=m ztJ70YYIocz`A?M3KJE)iH6Wi8|3yCkSFVa}jo`B+jZ6s9BGFe}+vcxFi$d595u1Nh z8_uJlM3T2dJ-aetHnZ`Y^?&DJ2}Ay!gS}}WvmhaTu#_ZFwT&e198672Eiw9C$w6hT zO;*xcCGhFf*EzVowlF`!pkb>PGkaxdr}uqjaMb>Bzme97L^YzMs9%hB?mL&Z4%$FI z;gaI&B2|&sefBSc&0j_%85hKa6wln}Vl$E`X+9L;oqs7LQB0F?Feu$=5A491%z$CJ z`@gBETHO3pVPMYCmD3RbRR{cQuOuM6(!h_f1pElr%6xzL5&V*hPDi6S>$h_2heBP9Jyr0&=jN-QPcb6}&1=xp@z`+#;a5{s(T&p)!oiJ(Vw2gK`R3xvVgp zrP8BGV{@s0%|umu>7%rK+rR%Y6HR$;d{F!OynUW!EY+})#UT9w2pwa=JdS8hAXy5pXY5hocw1}T$BMelEEFm6P49+ z^Lt!0*fDIEhnA8~5{XRjAcRH9uxyzI zK+GoHsbAG9Ew22yZf?*S^x)8>zL|lFkva45eo8X+Ge}$7_I{lg-jXiSzf`Gh(a`ZI z|Kau5LXPP2Y`@8r{+kW}w+wjf|6_TTIl8l|<2{bVPvbPVM|tdSH@f`WUKz%T@(;JQ zZMBHcC93_dH*2ys9WR7%!i6Ovq1xywgjJefq-j?Cc~Gj)cOF_Cx#*}`nEzV7wE1?D zU{6qiEP>7s$lR1txv~>F;I4`MOQCjsKQd2+loY(pONezjh{CpmC@e4_;FJcTst|rH z3`U$9_=eZKn;O5lfwIW0*TLk5D_y6yEmTG0Ppjr7LI9<0OHM$!}W06oodPYbF|AJwoW{ zyQM(z-2Mo;(Rd8GkRIU+F{2MSGh=Zxv0H8!3-4R!l@#mEOcLcaz#(WrrYIipXr^ei zFA7`gaQd?pn3mmbN#{f=c2v3eaFxrH%A&>tJ{0$1e)9RcRqql;zl^+B1DU9IL?`@@ zf8fA#e$_S-c3RuQ{ExN){(m=i-Dad%&nVf}!g)d6%-_&!{lBlJVCc1w-`7&3-^LD) z#*f#bNZuBUj>>kTUSA->i&3bvjrjQ)-8j|X57SUeJ<3c+VciH| z4{MAU7AByK54sVWzm@44;A6yllV`zzm+>X2$8N6bLHmf}3iA-xmzE^Xo6seN!S)u&&v!0JIRRFu@B7L0EcDR4}Cx zMgjm{Qg6b{zHRT0m?eZoGpc<~4Vf=v@w+>O0?-}(5#M{{twNh!cE$_%$)b%2KCDi2 zlIhei`j|?sa01?C-w92=tWD0=#mzyri0>1?yMz&iIb_|u&BB5L3T5sL(*WKjys1pm zYihh3`8aVZZ`Y)_XXa|}lZEf>tb$5}<0Hwhr1imha7UvZVf1=8_%}1HwO91y3 zL1V^sf<8)d@t|W|J@m>c)624ZvKjkuG366qoYtJ0pYbZk;|<+m1$3AF@i5(RnW$+Q z4EBCU!RhT2w;Rv=e1#)Qh98ce*E@2&F;+!A>3Z+lDV_~YmT7BRXikvdkEeDk>E-d9 zvEaIq!V00gYfDS`S{;QZRXp?gOrC$kU5RW>MHT8#`T1u47$ur0N*UD3Q=>T2qCq3k z1uE-7%+w#@+rXbRN>fI-k}OMjCA!|A31L0R>pf$uWF1YoL56lc8oYu9X&tnABpCLQ zDwDIPcTxxTJe#2`=8BZ74wOwU=sU`u>P^gs{mlX=#xo|iKhAk)>1;P6ia&f1igUg6 zas8@v=~f!Y>Fd|x6pKaia)bL^+zO2;a@unVq;g#>AL50cbK3_kwz-|0W* zHoI((n(_)v1Q&__vugairRpzcqd{Rjx*prv|Fw4mnRtqx!VP3QnR_Na9hYK10f}5E z`cY_urUyfrR7B#J*19Jx97ljet{9i-R#UB4Evm5*T>l4&d~85KS_m=ZeOjwi9VcqT z8@#9m$?rwMsRrcz6gPZN&3qtw{PdM+GNu`L{ZGQ5czG*Uj~l27k6}Rr?YWVal_NA`x(H}?OZ12*u0fzwOhILpZUO3~bzd&i`*^)@Y_XoOl z%uX`F%ve@OeEsG9FTB5N47qKBmILfC=Bi%M^GAWn9|S$KXtkFD3=_p)fML@31J|SF z*)H~Ks*`{vmCMKXVH6SNIroO9`G%c2za)iRd=ROXn>>|3U7o!YC?su7La!k*#*F%w zASnhn0zy9)1XZ)iTEPjl9V8B!40TyqKa$*;kl^9_M*ZjS`d`hY&CHr<1W;ra@5HAh zRS8cfOCpx}+WZt~QM)Aqo&z)KJkDd!kC;F9o&1c_b}yaZ<_yfG2aN3+?=D*YaPfLH zUA;6R5I=WXn_fYoT~MWKU$np+`6LBJ4hs+kg=ic}$MmlbEe0&$&p11D1K z+oSG6kiksZk&v#oG|FRw<-NDKj=aunI0eE%tcivIW z6bWEKe}Vgwx48);b!Tm4UIy2X=#ECkK~3S$89RjP}pF zLV-la5y`v!^f7;D^AZ0S z9THYILld%olE}1O%~!kd0l!{RJR#8^TukC`CqfcOji$CbTvPE_eD;hz$>L%a{AeM%CE3tP2VrsOm9< z9e;;ZgUD0$nR8^g^TFVY+CIL zr1cV$e!f6Oe{yYdE0~W`d!4AgVgf}mxJ}f!^;1fBtaC1dIHV#RYNx9>vwk83zDCEb z7YiBqg++P>{z6YFub4LFin+3?k0wMVkIQuT{aMI$*c6upKJvw%H-$BSp*}S;{~SUi zL?C+mg&$MLy4_k+#vY{9OK?NBv*l@`7f6r83&ov;yw97&>UQ^?-x`mDyOP6$?LtAn zmLG4#?RKW$?!F#0y!v=;f7!f}7vQVk8L;%?bcK4e?%j{M&U81!59KnH5?CD)Y7aP$ zg&%r-*`N2=$!0h97b6eI!G7_1r~Zu;Z>TbsEIJmyD{TVS;V5n8+iNTq|2Cy#jMRK2 z33TCa#R(|jl#5s!WdaZ(aKD>TkD&@Qq5_Co4_RET!D>0d-beWYg+kGJDfk7aE%vOq z>>$`zAD}W>m8Gx>zM}p-RDmaQ+4CS(-hi^#)tQjO1)NsL__ap5v1NfW8hq{S))g+> zDgT&JtsuXrt>gtvHTZFFv~6-mj!HH%s!`<;JS4P6dS_y9mv_F59I5tmKTM2sjIdN% zZ;iQKHLu7jj@o(zj0u|_t(0ZFM&RO z>BJMOI<@dFf|8PJ*AbK8KI}ThYcP}tr)ty26@UDZTvXagV<);*9Fpe?IiPODaYj&_ z7UEe&@h~J}K}ogu6c`zgnHgnwvI^f+KGn!YObKWiN_@%<@5I(M0MpraOKW2-d?e)k<0ePTA+a>Oh}-|F%Fz#UB?>uV_e}A3*q`r={Dw} zVUyuJ8s=jkxTX|k!^#N58zRghmJ(6Jl-p0uctlbp(8Jp!DuF0kAOJ8`*Qvv-lL0ScH*ueC3N?a@ma79wa(M02AP#snvvFT>fP?lB zoh`a+S~FuDxfx+bFH*<4Q2XF!f7dz1{0ZeQ%ZIP3DW05c9foiGc-L%Co{`g10B8Gy zWudvdA$qH*{m)8#CcBkt0f6bzSl0Y1s%|LVY*NS+nufCbh2-x%YEm@Hn4psD0pNI8 zV4p6@ox2w>`(vnbpS;w8rEDK64I6yo(spfKlc=oh;9A!8)@qSbJn2x;^a#@|5 zvIVHEuTh7#3NEiMczGZ(`3iHNJJAT@Bk?%FZj&_ijVcV7H%yw=fiEE34N9dO5_KX2 zCO54Rxz7Z#(j?)1s)$(9|b-qFRo8&>1|3=ENUL0xHN9#qC|M^ZlOy^?uZ}9EKVRVyBr32$fZw zj~@YeY(ws}_P^j-><|4iRpUy-=~|oB5s&mzK4}P)+Uz0aKE++rE1xa6;zTymHIbwc zQ2m+CEzU!eM>1_qHmxu6Rv(p~N<=allw9(&X~jQ+2!H*_W0pGxsIQ$OCGhqUoMyra^zJ7@a2lAx6b|>wF+d5Pg^jy@LgTvAH)hj=;===+#zArKPvtMWoJ^$^= zk*jB?BdG$Iyx+q4RXst{E+6l-ys--nOGn+2#02FRiZdY@AlJ>Di%Ar9te~TYv7pRe z6uUTd*98W=b4Q#qL$N9KBu=6_wbPR1(gu@8d*lbS*4pwk%nGdi_Ns_K-aZ8D zctI1wY0?cYuXgA06ws%XG9e;_c$hl%C@MIDCEJAePzEdDUMHlFEc2S<4XVqE3=Fp0 zC2SKK$;WA2w5q<*_QfBTnsvh)u8pau=@`mZIAF_^W5PeD+VFAQJ}wH zObZ}Zd_gis%YerEJLo&jwi7gg^_@n_{Z0b?Y_d-+t44nRHa;w+@NJj_ zW@pLT!1&tUZxbW3B%}OT%V2&2TH)R;ur9+|fiD2>0PHp|?EZDL5?en>3M)LV1%;=g z_xzA?A%Y>nPvGxM9B#1Ysk~LoJ9}ok^Y!*-sarvPIH6ErV>d3^{McmVTI@_I4V&?DodT5%qWaP zqVV1y#}cS5#pu&TkDJ6f-~HZdF6|zE-Pe9#Tr2T{^XbLuldoSdiN)vJvjS>c=BOV7 zp2I695Z)hk^S`?K-dJ;Tj9>9d>*?+ZpM2uD#XJ8V#GLrFbKtLJm^H2NZ%rF)J0WDb-^lYWz@#rO$rGOuSfK1Nhgg@U@nOFXQ7-7XVt;aNK&k$B=J_8Ydr0_;}{ z1PU|Qnx(G9jZ~O+THv`=fjoteM%D-!>u96-l@ z0`TH8FD>u=eCsO|Mf{ehv~5p`!W&MmrnqrqrLIq+!@*KmZZV;bu69rF|FQShQB`&A z9=1qGcXy|BBS>#T5H_JG-JJqTOV_5mq`Q%jmhNtmZcrKlsc&uceICy_?|aVo?=!yd zFUFWG_FiiZ#=Yj6^Zs2|u#&=B;MCRI0be!t2K_-wO2>xIFiww^t7JX}%N_BL&DLmd}+gf7!tDhLM2g0V+;?!6)Rp_uU5Ng_N1uO%jYQB8|^#h z;3_ZbmW$=x>eTqo`m56T04ven7tA@%^Vqh0V9c#oJ~vb2tru#f>w22+af_cdp@*Jr zDfN975=>7|B|9B@@{=|90wg!kqTyXjdGjF0R=PRvxT`@_yt0iK@X)MD-IV;xLlX-1 z&|tgC#SWiv$RAxEymYzfy(r_1gfmGq2-!XD<$*_%#KuU?RA$y>!~)TN5(%XgcX0f{ z@j1I*B$R=rN1)@EiG~zvqTw5XnrLF`6Y|ZYH{LMn6T|ThiGL1{>>66lWn{ajd zd3oqa?A2gCUEFhWA=#)y=9xAOM0H48y^333mEY!UuGpQN9o!r_3Oo&)+*GxhdE3~5 zd+Z`#ubuGSmG^do=l16rTTRNs)ZW7W?jibjy4d(p%FHIeeR#D7j7^J@A7ku+rztAk zo(oyJ-k#VN8R>qnw;8BZEBtU%RVwrXaTuvm#o%i+l<9{)HYK(lm7#u;%*TB^d(Po| z2aAT?5J03hdgd-d0N=BLuWTousmU|Muc%$%CLV`6V5tli;hS8uK4T^&crMn(wOtH@g?oUO5#B9521DB|eU^CgP-EB(vQ29(bV1BX_;t~@TNy!Nwh1|2+R%?d zPKoI-dDgPT`-%G~Azqvz--(b0ei&AIj#`fOvUVju;nx-4?t%jHH#(07vN#{|cv!9E zE5P2(FY4I^Vi0F%xhfcnGl6_9P(_T1Pbqyf5zQeX@^}pwL3OEPgaq>Aimzj-d^6FA zP(@$wa)x2#5>gd$@?^6TN3|&j({`5=FiDq2W#Jl1^9F=w;S-@Y%No!g(GMnq!#T5w zC8c+8YT8C2v>ggqD-7 zsE5ZS)^M<(+YXk8Cd_&a0^EaKBI~eUf3D^jYGMR%PJ->h<{*NRl8sGc2vHbGO*^F4 z41^%bJx*w?51i+(gN3tykKx6cOr|Jiks5+{144fMF-XGQ&uOA&_=zz&3OG+55b#ZB z`|qi`Ayr>ncg7&70VX+|%+NDZGXTzL6r%Gjto1vD2=bg{eHt5|SHBw~4x@&q2C0( z_Q8VrM3HQ4=y`@_5fPyR2WqJ$f$KO;c+vzPk+S^#RrX+GkT#bIkB19oRzX!PTPD%e z*tRR}{hblXCcnvmX0HG>PrOU+}{`-QvTK?=zX9C zNh>B^F@qpPycTzP1NZkUnvh`1keJ&7dLIrUf1TTRBB#0Ee-E6nc}WJ593)hpo4Fg3 zoKcP?_lya8$qnT2z=fQ;asu}&8TwD~^}$fDo*4*xEo&SS!kJCq4Y5Ea$Sn_$OKLk= z70l+X|)SX*-}# z=(C5mjRh1+@T8F5U9=D@0Qv+z_)_(bH-J7tba1IP8PUo1TZ#l zvgDjGo~tx3)WGH$p#;?w_=~tQf})L;Qb6VnW%^5jjG3rpJX)OBf%#mXw|UXH3M|?3 zBoC4tlWprn=~SU@V~xO4I#>ewa&wQd`TcSOETw02104&dPr&OJyx+WFgQ7^<+YVt- z^IZt;mM;f^w%ZZY_%aIhQm8&5{AF<;G)ij#L}}kVr}}&!rRC}gWz=-PjfH66TaXvE z7JgZfr=b>Pv}uesz=CX}onDGw4Dt>V^<2x;wwK1kVz zDA~3a-N>-<#racn?2*Ob_0aL7K1P*(D2tG(FhvPGr2Vh(+k8%!*IImg49{7~)5rp8 z?pwyL+QCZO)9ovlHJDd5JKOTJ9+(0=7~Zpzd3Qsyu7GkK%ikVTX`GR)9)BSp4!iM% z-x2(&QnB0fT@pEWhP#Jvy+5Hd+_z&abMM7FwQqwG4SR7hf&p zCtOC@v^HM5xm_NQ1nw<))#(0cyi@gPX}Y>t+i`8w5*;b(ps1f0{lFgDmmWHBbrbXF6d2oiY5%ba}Eto3*!(miw_wR~xvB~mGb zc|9fz{a7vvNkifx8yjIo4@@jIsTkcZM~35T85eG!lM>X#%uo~rQUt=bB`if1M;|P; ztcjn({4iS^_?UL~nM}#kaufKwjB0cp$H}o%?~$CEvvvGW+L3}jeX^4xmCD^^DU-|< z^4XTdA2cD{8e*qhTa_T8^ncIDw3z^w++Ud;_LKsYXj&e@1-DU&`;eNcxvTRR}ga_e${0#o0!;vy+ z80rWfYj#FMUS zMFSqxlootES!CEzQB*(Vh$z^xLxfLB#|c^(=G@U&}J`2g3&EtcJff8!Ns7G`4tmd zV^Xyl9-~;p-h#QqAZjAHS4&hJz@3OQa{N82JW3NC6$Kt$+C?GamIS>Cgyte zf1Q{#Fi18Sxra(VplrAYJ76-W6 zZp5IJsMw>R-4sDd5FPZ^&0J}_{_xxPMUDXtO;XA(yz!Bc*SxOeNPV*X0tIE}y#<|- z;EyYCvLFyBC2Ai5<{>fnxv>N)5uS@2a3}oMVzRww>J`!1M!943=8PZAP3XZ&~&Ux17EXCbT$_W4*TnLm#ve5 z)0G2tMS{_OLS$9s#knk|wq0<)5y=sev3C#tJ{Af1epEM*O1C&25uPM4OS%6aQR<)_ zT=qDE{*T;(`hFcMDSlv+z7$SyV~rIZ<+#RMG!zLTpFU9W`n#h2W1ic-uNDPdfnA(R z%>Vdq&G$P*s2QudQ=v6=BM}B`$nx-b%~zSwOla|O-_OZJ&8MQ z><{vQSC454R6FWk^V}jc0z9FfnTdav+Md=nKWmrfI&KkEH>*~w@a zr9I3doMKE%aoQk27BT)&iB%ju6TUY@+MmMw@?wK~$Vc_`lCEo5yE(hHd;1`j>4+Cm z%^RT4i3Yja3<`Y`6|bUQr;1$`*9r1=!NSS>?D56_%@G5F@5~#vl^#`{8BWt9LSap{ zQ22Rf4EUS)8eR2wk+>ew6D6PXYiv!<<$5>zB~>^`@Lo&@7TS^0V#v`gqhi&Am9ZhR z19r~hRaO+=_k;3oXi0FZx8XmX1ZJ!?1!64;**cP>*A~#gIg3bqu8q_Y&D1_dfcxeo z_1+q*gC9GiCh9>goe{j;&sfxx+l9FIYn5cQjdo?p3qP`hN)-&*|4bOhi$n44(&awx z?|rDmRIqXk@S72`3IN(Do*A$=&KF{EIbym+My<5uG6?x@@>FqR9AjXVZ)QNrL4>(9 z`qENhBQmEJ?-h@3_pN$Z`619yxPlmNga;w|8T5QGqf$Cqty?_ ztC9c4{?Wt3(kY2|r__4<2;B*HoXUtXHc(k9Bg>VeP~Gif1AMI&a#sAX_2DmKQ5?|q zjn+mTlJQKu4H-q2>M^CSJZ_F$OTRe0^-IvUasoBn0Bmfe$^{u}wjXuGu`Y{UH4Z`B zST3o$P2(1)zj1g7Ds#qofY@uo@f zF-tQ)q5-Wrx)T^;jKo{v*>k1Y?RV4GdZUX0z)np`5(Ssl!sL?X9~t?7Ou^E6HPzVy z6f8pA|6H*CZM+Xv%5SO&5vu*ES@`~U%TCR~VlWOmHb2xJ!F{`#el)VW!f1KgegC4d zeEI7|W1h72T1UwQXpK(snJ!upd}{AY5uYx~iY|Yk&;`w>D1@_E&Oqr(7V&)X~K z_E;;JO01d+hDU&=?VI^Lqar`=sRyb-|0uZQiJy`q+uDxf&QgdB1-3QJRa7DoFxN(sp?T&AekJ4H%_g;k|2yvJKNY%OaW z?Uz8jk09QrrQo%BPF)IV`AjCo&^TethL4s5GK}*!5Km!$b4_RzvD6B0p0Mtq123AG zau>o&?i&W0uNYw(huL4*zrK&BwEF_FXEiivJjL-2i1&#!yxSfVUsr_nB3JY_ z_*Tem9Ba_|qnlYU76Uq(hVGJ^;2v5MU zH_iQ?ouduY#02xFuPn}$)v_!Z2#(iP(6dUUO}t)x`)tfgmA` zi1vVaDy^^d%R;&A>Xu4LI`Xyr>Z44NBVT3dYf4El_{dDrieH12GHLU@6%UV`?4H;jGu5QEsawQZl8HOK9#~cv?N^gx6OIn=g1y zy{)2=P*_KI({Y|iU1Nc%9%J)lxuBHMN6{);paFMxHu7eNO6vBJFQrKkWo}&vI_d^n za8`tV_^DG6)6b`VxF7vu$D^ESaL{<`IBDMPu_!(X*9}XvP;^7@{KTlkJ??Cjywlxd z2m8f^nh-~N0);>tIG#u>FUi3jSTR9k^ch2k<77k5rzhJH=NhVBGfXt=pmz|+8?Eg9 z%)^GX0=3Q(FWy(+tgntOA*49{QfR8f#FHJ{~mFyn!Zs4+&Ok zrh`I)ZzD_ONCR-7MGt@kWByU}DE}yWXupbH=f8>`)J^%#<#*A80GP7ufVZgW>ss9h zOX|@+=EiE~u#|x7%;O4ZwTac1J-@;DjVU8|C*5@rgPTk6!rhT|CCCOzrjJ2m_=@eeBeed!FH~ocbwRlBUqx@?%%R@39iT`iq)PmvNE(MHfNQUR z(j|YQO}_`=T!!BRa9*DP6iMD+TgOlU&Z#LTiB9oX?CHfxc4EAyoU1QBO`=&9>f!m~ zKQZaSsjDX+e*tieGvU6uwi3VuJnwd@eE~x$0@dI2S77_~umGQsm zYjK~95kk<)1U8I`jxLI931Mx9xhZuVQA=m!F3`AN0)<)`ZJDK80($33?eP_(oD|KJA_`@DkaVcGmhH zA#XIXRrO&heXH)Jm$cE6gXr@JcF_(X&fKTc7?_2v{iHsUA;AIDn3d~l#DHD*$*b>Q zuD{e=I{LaI_F-~iGE0~}P%hk8u$kKTl*SfKFt|}$eu*uL_&u1yj~S?bL3&A2qq)lB z(kO^juf^ch)iA}3$*`*Px!RDNnADUlRen{yLP{UC!OPF{k1tR>96%*9kZg&#Nn&@s*3^nKa;wrv1W z)b_InlY-oMmRgv-VE$Tc`^OYL%eYGyJfL4@>OUuu`Tk7??$I0cPzj*F@K3%C&HNlK z6y(6SPPsvk{178?C1q(XeQr(1c{|LKMoo8x5s`CMM73u7CEo4X8%`!*MfnHsceN1~ z_hkgpVNuV-@3A^5@z53J6y&;T8+i#-%laI8Ws=1XU?o_NRd^SVlVr&JyJ$37a0drN zbOl zSL}Plss#KX9wsbX*XSP6{Z;e~fubjVa&}D73!C{(szK*YF_DojxfQ9-+f>axJ%{m0 z6CWVGMD~SOlSfYg) zs~!)9GMUw*J#^cm!jzGPOAdY9?@%{5Pq~BW{m$Pi> z!QsDTS>)v6$)H)5UtNY{fR&dPu<}yhXIUQKXIVU_A*UPWZW=T9Ipq9={JPDJ7ANbE zBDxfH7rSM)DS?{qoYh0eZyQB!E-PhvW@@VS778Qbj8 zII@^348=4fQAOGQ>l(fT@=PQcHk>I!g>-G75a2WH1f}#cX-Uh&IIe&<5(;=u*bjQ}i)fJUkBq0;K%hmWzW1381G$s{J-IX^y_8GhxKFAgT0iG1#Cg^i z7XX0u_yGX0G!_3;MS^~S$uJP8v)tXT*yDnNBup?I`YJYZ z{vWmUuVmn#d160ls$#S3-}0cpor?fJQ4(FnCX4d$J<)wIP=rD%bTMgM%b5MDS_jUlD6mVFuZ!nveVChzFv9&=k%YD374h?vG^Z>XSq(UOOTBjr|QO4d}E zi{1G-`^!bcONiP&&7Una=Nv}bZ~Eh-_u+oG(46iCod1-VQ=~ z9Qqc6gReF~GEjt`N#Q;jNa1H}nrNNC?A*kBw4^6Yk16>CE~XPb--YCE<#OGEr)q%#?_3SS`pssXxqPbI4o^@AV^{v$ zrS)5!wUll#q(moArlPfIb7X`7Y;sy(1!hf5L>la`Pzt$&oxNyA_UyAP$K)q~Q+2N& z+C@_xWl%y9UI6pZZJQFPoT)A@$@H(D!n2->>m887ts)|czxfbgZj#_aK}$r1sTBDr zN31@RN!$@eyT*Mox*_0aS@xfE$Up2sHUEDt{r_k!#q4qAY$(|Y+AJeg-H{y5!`vXG z`eI14O8C^`5zw9eIs_pXS1{#8tYHr0G&OvOPLAG%7fiX5JfQ3uV(gIxTY-=RhJYFy z;d?r@!C6W4z5h<^kAJd%OgRnv#^!ekEJ9xV=j;pLU%A1*%jqLSbR==AV)d8*0~-$T z8N`5kIxf8o1Gw1Su0OsLC_rdN{x1q!)n$sMmwza1WuOY%o5n7kl+u5zu(f5j#(i^W z#@Fc#s;IgHf`iB%OkjoDca-a!lM6AgQ&{TX>Yr5sr>9j97M|mY3dIm_y6|Ww#$*jNW&1eq*FB z6&kcI`&ZD~_P++LQ$FaoXwxtC0oZWp)HKHvkpap7SI}AuU@vkG_(R>}V+ct@4WEnE zal7Yu+KlQcw^CJp1+CS+Da>zyp!JZuO8SXvNON<8Ol!@HB>~G$0^3o95(=NQ=E9lR zwjMvZgV5LkL{2gAI*t&RWzg8|-K1OP=;Zy8GR>beOvT;xT>U^4xxSDr_Wj%5d&14ucFS8)dU-$?(~DOG=LI zeW!YL)OF&<#l+dncLU#)y!IU%_g|(rdh&kA^p+6vC-vXO{en}l!#3Ej*?3VL zdV#{csGD$M`I*9>Z#hDO^&(rjTTiu9Pg&e|+6Q?34wsnGixdmvZ1QPgL2)!wo-6ty zI`=HFmiO!Q=M01|Kw_m%L%ayrO~f25Y6FjofX6fYc^MVg=czMXG=TrM`q7y|k@671 zH-rOm#3MsFHPu*C@S&Wq8q-9U=K&rEp_(0nV(9&Th)PB14=rX@Da}qp)js>dT#zT$3ALgca^?LSE?DM;1fk?S#V`Tl{+03Y=aJTTJB2yymgG+{5A))d~pX`D#9RU8Dn?p>pvCKc=}}m@42WK#N)n+?0H|7Ua-bDG#txUaSyU8=6U&$b0!&pw=8RQ@Auo=WeEx~+ zmv$zaHHSdGjQwBg<-a6n(5zs<@2p^t_v2qV>*m523*==$RuJV$xYb9o;ubdsdQ#dV zKwiluCw#}xeFRNfvz*eG#N;t?gc(4jIuw~woV)>`4LTPj)l{)B)?CUPqkZLGt(#U! z@)G5KpLzMq6(2+A(QC6!>WL797tDsdCw7)Ioi#5ixPq#wmL(q{|oU9hFwv^zG^#&&7JzaNdW~4-hW=xwE3r1ID$f zBLqr`gL&(zs`3?*=g5(G>fT#Cx}zn}kcdQcXX}eCPv;45`jfDApSUq|c%pV6JZ|PP znaCBDEI!KZ=G7;9d}9D+Vy;yuPrjmirb{3Y+RgI;wTJ0xsRwr>yF{5K2Hmo`-7_6> z{C4{a_Sm54>f-h=AA}W1^|uzu3X1u_PfxOT1mvq?^DrVKE~Z_wud=FVDB>!t#gQss zqL(+g${=du`e7>3?HH%N^~=^ltR%>bF^kPvgWR^h#18m_(DW-)jq7)BsbqRZjn|97 zYyt2mLPi~-{0U%>Mplrc%|((DWgm5`V>J7`1Kj=HMZ5fD!&NZCw%n_@PPKH;;>yEi z?m9ovP+LUzCa|n5UUdHKY-a7}NzbjK_RU1k!13X!mrk9r$5HIhX~#1cEuY@=42L33 z)t9&IDR)0_N}lkNFOIC~U;5D_@8CM%TBw-OLyb4SbM-R%~ga|?7vyDkY9XRWTJiQKR7 zQDgeyI-ceE6@X_mn^pL?B{9Nzd_$x~Q^}qE7A!8x2Q8cWm>;gBG6e*$Y8~ziXP)%U zB8whJ!7^$x`ZHN3Qgs=oS!r%jj=$?;Y!ydoxXN}EMPlKa@_o&;Pg1e?Y%IxiDx3LK zp01-n9V@00VmH^}^wi!8v(EDZEP>`>G7Pz5;eE~c#XTTweV-pTJa?0D|3!$tDX@q$ zLi<3Qe(f7q76L4;e!m_^dpJiCtBkkTk^kXVo}eIfFPE9?rIsFsCV4q!~LheX%XFFSOc+gN5m1uYU_S>?}ec@|^k zET?;04k{U+HNMPLtBRD5dXt=1{C0)C9=3kqx2RT7J$TzEDJyg(LM<=48ppNE9CE7vy0gZ`+T#0asXpCivwxg~o0FNM)ianT0U&y#v~a&%@@nmzMm+UvmK zhZ=q*WD$}SoB+eG81gyP@Cz(>(g-oPn@gGW;WBoUr!vKm!b4X)^N(9rxM9mixq(W_HvO>7YHWQikx=T=A6Pb7g41WU(` z>cu!9H^zdqp4F>)YWerr{a^ype&aMBcv9Q515`9**y6To4h4#!gN7e&t5r;%Z(zyC znod5zSRKqgJ|rNIU?$HFIYq?q%8T_62ZRUY^=dX(?b&n1i3(ipx&9|cWqPBN9}L<} zr5`6W@f6|Owmg)nypuuEwB{rA9sU8#)#^2j0}0boV~jGg_7Nrdx%(mbwT1bKr+w|i zW-KY4+ns5&G(t1Mo&D{D+fpXRi9G#X%zMD_2U?o2Rf$5qPhe;z^;>6tLf2w#*5n;2 zwkq}c8GlTKqypnJ{&9vOu`<3)A*$X{I zF#(j_jq||?72>I2$$;({bQ9Y$y$WApV2bHE(od2&)+Z$gLe*ucMG50dn`ILXk&bhF zQ5!ndCoKme#9NYNCbS_42@ZMD$voe+yPgG{TnGjYPygxa1Y$=Hm@Q!5I6>6uk7xHk z=JowR?Ufwg|50cE3Kaf59gPuSc!;H6v%vZ{Y2mvl^E2&7`Ib=4;KAI zgKKR1!rhzB)=zN+*iYBCl2%`BT|Z3*ww5I5&5;Kx4pv2*wBDr)?`^b?pZQt<&fSk} zM;2#P9=)QQ0$ObC_cC=GIN6hi&U3K+-NqZzdSE~O8DM4n3AHk|a(_84hguoa-=C!w z&d4`It&Gpuelc!M!(K%vG^Hw7>J*>A*Tl1SM_;=f1 zOfKseK6u`C+K&gGpl-UkMZ#SuoJQF3eaq?OqoH?9HT4-~kRhNl7 zS199QHo^rp+qL)QAwf6;UJsC!XcT^ME9iinr=k~YmjmXry=osLRi`~CG)L03+9X_L z^EPOY37l(M&n-}Cc3~myx)J>$ppDjJ*8=zs#yK?WB_Yp8<_z_un_<0^z$V}H<>5o* zlwLT4H0$Lc&llzlJBPpP+YREOeo+9};KoB{*9QZvZ_A#4=d3P06|iC<94ryx=(!S9PoaRX-=;kar%yquqRS!VG)} z4p(*3JI*&u(JHU)ZCm6|xEt=~l>E zFy%ckBze*Dt#Y?@s)ltalaUO>Tg_c;5t4HN>cv>2hiE3?zn!&f`#uMh+G_VN&hjx~ z?^~3hBwKSR$u<)Ltd!CUPW2abBZ#51C)>`a2cATZM&0AY1yFdO*qy`ZD)-IPc3t+$ z>*xU_+b+a6^SJ{e4dlN_w(%VtgN+vi>;#JpBd+xoMkfV+Rls3fcJi|#nyPb zn8mspM_U0m0W~K2wt#LVS)%6M8r+45pa9MpXaez2{3Xblfo*=m3p}*%CVCu2h`#90dYMY7vZc@pCnIx1_)yafmpO}M zBQ6(n^m$Y*-V;@ESiH9ZRzkmC`1f$!pbCTHJQf15>?m?QP-ZMmlpodTAg)W{6-KLc zj&sJM zWr5EMc5Wh%D~iMh&Ej^Ahy{-SSJu?!%nOYyJ-ZG9U?KOL!qWOvMz=|N?0QXErm&v~ zKe|iw2p5>3ClhzL_=Pr`*7xNMe+9qEz2a714QoOtXqGlRJ{NcC^J3z?BNvz}=K(fc zn%K4zjc6=9JdA1NfW9E;A_!=asjr|$4kQO6#$q~0B<<f~MB9r2N8qJOes3PWIvRs}4s)(@dp(Oe_ntN45L}IiEpo+k| zS4F&NvJwJR5&mx|vity5#9{CXS^B`mWuv?bM=7Mp`hgLbS&QgxtOAlT!T8N3MY|Nz z*tH_CUXcY|uNX&RX=(31@G~Yzv`k=g&H}m$4o@LKTPmWA972c7BH%WEdh*m|>Le+5 z&vc48?9@bib&6S+6@S1~VUydTuMlpwt>%HbPQp7ZyioS^wMjs=qw8}pH1zgVhUqd5 zQ0+MVrP?W-oX%~1KYRFkBfjD|&vU9^m3N^AfBgnO&RRb8kzDHYV?_CMg4V(t1~$Gh ze`1b3G*vZd;une=7H3dpW%R=W)aD_}Vy=hwq7`fQm~{G^quu0bOg%&(D^uudMbw0w z_-8y>Hh+t>zdxj^Os43wxLhM>8oxUBNn! zr@S<0b&BpJf41W%g75vg6V4*Y*Nc_we*#TJ&`Pi8egFP!+?#0_-J5## zC8}w~UjD{DdQA#Bd&1t4qX?OEIeY8N@+%N;@y^zc%W*n+gUQ*uGm7h_lky!P7<_iT z=60R;>IR%Lak(5spY|^!iR)el*=4q@OLsiDpCH(*ik!Ijf}+^wx5v|iLwyI zfVdBH36*Lv@wl=FavbN+;lj^^S+bx+`0&CK5GZdqQ!|1`Kb=_A@bskOp8oUqzH5gPd=IH0aw`y>(Z)vHKWNC7RO!2DKA4uZDAmWUI zu~OHgf@mqj)ChTtN+k$8fjOhL;o>+8GemQ}`De4tHAc2=XMu8Mg&ckwuVJhmU~=(@|kv1(`n* zH@wT?Lh65$rzdDe){*@wsm)l<_{AD+7Ict4CC+!6^XbY%$r7?M1?G=JX#KPOG;wmu z$rJcL@`~0x4G0B|M?3M24uwI?F&UFEbM3ckZ&21p+GP$B_*J8I>kvX&cua6cBxfms z-wT_XM+}#aJ{(OE6jug==|6(B@{$yM#`Ua|PhBF0S;v6i$n}X^qrg1}6D4;<_0uwr zyy7@;-G@9yC+-O1o@@7U)G`_6P)>Tly8c*zM&vCBMJ(xAB`ZXg;A0;-o~^V74{+A_ zso+l%3kQZMVuc%61bc~!K3V!1(96M3jr#B;8$M$&SHpc`(|`{t#4Q&1j-f*2VcC(i zv4_f=DkW`&Bp>CJzh`Jw*%d3TgGJ%XoaY6Lk##nR@Pvm!(`ULm!<7FNIWk0H{csjGh0#21>m3L0Q_?p z@kKy{nq;)V2h1*`P&Wx18~yE~Xf0uj7WFJAk*y~PR6H8a~~g=P5&SN0NkPUNVz>TsX90nND;Eo0p)$D^;w6=#QyAO!f??O?Iz->6D+5c9e@F$dL^IX+tvGQpJ!-2*-?MG2lH z(x-dtl~KcGz6BwdcIXrJ;&|s!mQJ1s3MC?LGSB)|wz00`?o(yE64uG+$j^0}0XSt@ znXl5%SNNdtd6kfCK(xkYoU`G2^f+OqK##*2umLIMCemBPTD4Sx?Drzj!qsIsA!0bt zY^W+uO|U??fB0S)H?F1nFI40n|N#rtR0<0!2y(o(#uPcfbvY_Z0g1yu9EP zwRJQ3okJLfwq@rh_hWcq+ZaeZSC)*Md;ANIZ{QFluujQ@ly!7eK2vTFM>+78aZhkA zDi~YAP-ME8@4jAUJ&+KAyMtaCzN+-^BlUCi1RwxlbSJr}K#}X1C-+nUXz~q&qU^Qb zC=WM{&lPofx2u3qvtcBgee?^U`r$q^4U!h&bYQaoAukpt`g4I^mdt@XNS^aM3eyGObewYV*w`EZlUmxRWEVex%6CpYc&}P?= z$82%x3dxHFIz%xCZR-Regqt~x?0HT4NPK-}Ot2!!s2r0lgaNJrKpF)yp4^`Vu8;#g zBVuB9jrB`9otKJObOP+~!M0j_dzwG*{(+C5=A3{TZ{YD$|Gzwb{#_o9feOl=HpBXR z0sohz4iKGu^YiUQd;OQ=^VTsI&2{Yy;uQY9<8wfb>5H|u*R4hb7m$aumLr)uehB2@ zl>U{6+XV7()p?(5YP6pR>GMMKaBHkz3uEscpLBT>squj0Gg1JR0iX@7eu&(YAuK9_ zTVsLx;A;b+KKP%CtU_<{gO!7Kz5Trp z{thj01kqqU-Y(XtBK2JRI*A!56TmIk z$1cM5KsF>{`O%vbk{htRr)l+yZkjkrg(u?l+q`>05<4Yd(~Ek#lIB8PUS=2Ra{#5< zDs8^^&{SLqtp}QiYqs4z3BCROJ!*FGlH6!*EUnkb)cHom0$@-^+nXQl($Q0nQ(iW8VP*`Shpr!h@XZ9On zO>ABgw$q0kOkt@7gU%noPf3;-Au9N;QQ8$y!@p=J5%TLS`0>EpTf;ncOYTw3i6A0r z5u>+(vydO?O>e+g*c^C+T;8kgZs}!ZX;l5k&jkGyg44dj;!U^PoWs@BjCD>+uPIBL zqmDmIiZ(%xotBL(C}+U}FcLD@%#d8}iZR~Bn?MdsdGQ|nT^y%}ei5{4$&uc21k|X04$GYGj2E;Y zv_L~FN!@{eiplQ@v<#aV%jzg*YTsUxWC}G#TD<+`yR|a8;Q&zQc8X$2?$Mt!xfLpdSk2zzpf@#odj8P}66p#MGpI z7lMs3ks?IwGBQFwlLKKXnNE*G5JQdWD#(iq@4z~53{zclKdL8`hB6t`XypwQ?~t)+ zCva>tmJ6a^pSn*o5J}52RW=ENn{2eZWA}#TLDeQ^{L|vqN?aj?E*8H|ISyhr^hClV z8r<3Y=8fZg@lX1N?$KbjY^7~=nWI5j9jr4oG(UsNaRJie`*HvN0sL-amjwwz zM1P~$GEoRg!ph;A=m(wnon4Qn{ky+|UjLZarUbidk~csfvPr?)h6>3%9@C zn-bU_ILunM*mz;FNp!R4?A_Y7M+)$)zWNDE3O==tmUYk{!{YOxdEET@`jbL!f^_(u zREO!qs0+H}P81->{j_Cys_LXK<`pa1y!&VkU#}Ivpia3tPg*`F`pbdCXjRz?UkVtm ztidCZzI{PZGCLD5`+*_W+jwxv`2!xl$fBmliaM$f}`H*ESz`YobCc4fb1djt1b zjJQAJT#GY6$$P97XDEcS31B5oUipl?ZQbpVp{k4XrLLG4q-S}4Z%x2OGF#oV)Ap5u z8fUcOP^t_GFho*mVS=-9t5)KKU0%{Nf!uA=UPyXyy?2F6)en3xK)Fqw7-hzJc5Gw# zdCUnl$drgD$eb%BX5POO7H;){+>Y0ehdx*KQjR&--20UjwqZ8Of24Oy;uWD(9T2p0 ze3e2$0{*`dEP61z(vFPO4=`PR4i3EQF5BwhVZEt9wf1=W|4{dp0a-0=yVBiV(v7sV zba$t8cXxMphtiFRqyp02-H0?uhjg6v=zjO-d%m;J|NVy_i}lQ!wPxm?Ywox%U(;Q2 zn#57!ZpX0FeqobvsFzg(edC_oUj-EGKOPVy`c@j@66^cjS-vbKS3DQenVc&`@jR!E zW#&!nWMXS=s~;NTX|H$X*UOI!#S9}vutfZcXfi~Q9K1BDKz(*W8(Twp&emfej2H&L z(J!2K^J#)eC|Pu(RIxJ&+ab8dKnh_%C=K38Q7z=BBAlTP)j|P(DE{$vQ3yc@677~| z85!kPUInZ_Hfu}mhonj*yWR{{e z5XYyZUPdxtr6v{DGl-ZMYFCI}XC0LUBKv8k;JO@GIXnwV_=`0*7?&?xczwCehLQ=R z4S4hH-afeQhkYE<{x3w>_+ej8ECEZE{{OL5e-{k?k83}O(1azBP;d8-U_XG`zpT|x`+c`DT{UO|+op+ux6bP<7LlJ^dkx|Sm8 zO6_?ountXp>qzZ#_h7`hvZtf%jA?9kL`&ENqy(?1&nQX`g`1Cn3YS5nZv7B}4thG@ zY>Fg(&3!BmAM&ctAVc*9%Qe)Wx^(;n*_jOMzz%@0eIJ6&r@tqgvt{!%d(9{ln9Nne zGo^2C`?PuVoY~;(J6VCbostWNabmqsc6!<;C*`NzdO-Ct*MAgmuUFT{OMR&0EQ34% zauMx+q|OoKK0z8KTc^&4m@@yY6MAjGrw&L7s?1b>aNvpR^L&rBsT2noDnJ^Gaqa_P zs0avE=E9+xKy;o3?ANXtX(VXsMIrt;ok1?d8-S*hr)X_afQ<(w%C}U{K(uA;(%Evq zy_=u_HbmG6YEhm@af(dDudVk0&JF}SV<3;MWhagud=#$5fZTvnE_z->faQ-Pm-?9E z-{*VOuR|_-!Sp{tRleRu#61~#TTic2M{danJhV4#u276Ngs{P zHg3D^-mOJgZPrh-&1tmUlkd;nm|+`>`f1Hmb-e$@tk=&OB?{}}x|v8oKRy0>m_YsE z+$$@0?Wxc7U3zd~1$F+y#3=t(Z|S8hN0mc+)$vcy?-f6WE+$ehuvjU2NKK?91uZB@ z%I#(MXYBmQqH`7YGp9Nf$l6~>!OjlEhhUzQ=fecCM&~JX2I1o{3o0sZf-5I<1!2z2 zojnV}tu~I-i21^EtQ;xAK|mt0m`Ih0Q5NMj#t|dnHir!ZmdcB2W#`N5d~^%lupkP$ zdP3=gI|2J-jsDL_>aPks9gqXMe~tQx zSJMv#8vILMLWK_2hhz@57JlA7NO}(O#%YS|t5tU!No86lOSGE+?x%Or&w49FDWcMdC&!7xGi$;}J!2j$ZMYLs4Fu8~! z_X+SnXB|}&uz>u}p_s?GdAPLde0JKld)mUQ;S`04M2IW2e48p6%>GzXaAx(h4bcIz zcR3%2bCbD2S}N7gRI*8E-MOJ_9SC&3I?_^pX2m!QH?bg<`eoCocV*HKoG+`<7J5+5 zXzpKhTYg*i_xJ+K%-5v7CzzHGs+>EF1m=j!Mvz>7iyxS zYaP{U+B1eMsxu$H(X;(E&aclsy(NyQ;AX*kQ9o`vUO|9~M9_@-VwO-+z>+I><%*(` zyn$>vnWXg?JEzDE5Fi{Z)G+1mj5w;Awu;C_EPDy=jZ0zxBbg>Hh20Jg#*2e$00Zgr zv+wjf?pzSjoP6oWYOtsy0<=<`v1kr`o^>d+=0B69({=2+0A9i-bWbq392_aE1bhj# zCbVLueHcYF>E+e=IP#IV3Ply?#6gu9$ZWy-SvA z_gx(%v)nkSjtr-qsU?*Xi9#x7pJB?3jwC27D2Nh!BCO0H5^75l3f`%R$9f=fPYekPsS;k=LSzP2B#LrYQ8-R@ z_qd-d%Ld`RT0-|D_q-^P8M7b}z)Y*>6lGayuh|CDbNU}J&5oqUUT?uw z=M{YB1;E1AchS48{C#W(g?FzlkHTFw7Q~uyEZ8a)*&xX=+_fpB zfmW`18N}E5$=v-;QAz3_IN7Iwhy9V7j- z-TPmabYyGETrl!L>N0q~U9o!QOOWUu0Eo2^Sn#q@HMW2S&~r=kr24j)FOD zD>;x(M<vy%1HhMn84uW7qusYO;T-1 zf2GsWdfHaAON9gJboU}}3Z&-(7MwbdiUY|MrY=o2XyqEg@A$*v^1o?ya|Y@AyqX>n zP)*9QGF3J7C4u>{(|@(w$wyL8{pLyl7K19#OyU^%G%V^H6)oX))gCk;@tl3h+@#C% z=9Evw-{Bfh2yrz)Vh}#;pf%cm(rNN$OAVkuw9$~JIoe<45XqJc*<7R$>U2W8ET`HT0JA3bHeGTDOpt^(Lt|979={SV6C=}+L=pOQNv z3&(U{20EC~Q<3-*DSX#^u!{P!s~4l=h2^I2I=vFCakO1U0%Mq8n9J8>8fNyy-gDu> zBR=o0KeG?9*)kQxkYUS^wv+yv4U-S0_QB$iPMI=~7Wd8I>NeDPk~4NdWC2W z1=+M5P)M-Tj_GbO`tlDBld9BTC(6)YJgv4P3XqaefAh3X1NCq2H1XDYPm1*Rg@{CXXhC-!a=y}OyEbD{{vJ@aq#Mq# zFPLCP7LZq%mlw7=QA>(D8wYm;r8UJdt`}T?3l7UOB#&xVYAUkqtD)aCzE6m zd4(OQQ>q4`GDF$I(uU!PGT2;Ud_VGfSR)Dx4~ahYQijH9l6NO@`zU+841LqL-1H0_ zqyBBxXaVvD$ozn*;XwXpQ}e&7(HH{E_hh+RudkKZT{Z1c3T*>n5sfk@nS~LD5jN-Qc#gZG6#%~!!atV zboNHq7dkkRVfgAYB$r+pk7Vn@vfy?z;-w*ntl8`oL}Ov9{DOiWBvKY%T%K{LO@h(5 zsPyVUT*h*M;{Y}F>lEfeu*wW!+-!iQ8kiAvkwZFuRHD(~McYi+F~y8;oOnupT_APX z$!S)}d;ftVNVcUPD^P;S1f%iWWK~hnC_3b5&M}%9F%*wY7bJAPgNQe@D7%);Rgdk{3rGNH{0VR zX&yvxopz2wX+kvGcF@y4_Bk;5y&ml2eC4;PHt#!T>x-m^IOHK8KP4n2Ahr{QIUZyw zy3f4VIvoOi?VW~cGe&r~%yZTz#=DKg11V0hZVA@GtgNquUoy%eaz%SQ<3n_u zk}U7T46RzqE2EaTWmcrii*P@#dKOh0ll58_Akd3FbIYg4r>_I*^Ab_^sV0T<-N~32-LA(iJ>0sn(HhhvRb;Jt_`|$TpjhDeFAA zpbALP7R$X6fber3xXFin&`g37NUJBe2!iE-hcDsk;NC(g;S!89QA!{uO8R-6-XFM@U=w^4=^=? zaOGGFUEJFZ3Ca#h1YyNaRiyDtcpIdEt+63;jB_iImo z<+Tn(c2j>vcKcN+n_VM;$gaE-5ZTog)0sU(C;r@d9esVW!&}VxM`@N&gdq|rvbzf~ zRiy%v-9kN#X={1<=R_NT=@c(f)y0DZ^A0<#!n*UO&`4*HmsgP8zC83!j@-++NXiWX zi0m$2VU(BvekY62Hy%J_7fazl-m=-saP=P0kvV#u!}4~z5U3YW{>5}^3y}Wh?;LE8 z55y?Ck?DQ}4t6Q1qxvDs9c*-dI#NnrM!n_>m$5a6kj_U_z3QrzPXuxOkVac!4oN;C z>s+AHtPF3UG^=-IY8D2RQ|hI*vCRr_Sfv@%W+bb~Q~s8bY3@N$Iy>FI7}>r_0a8jw zdf(g?raX*U47c<6H-3LW%{k%ws%*76m76zr%HSlW>7^iGt$LPar-Ly2S4ye75?A)O zVj!_7d&zghXjL;IK+8V8fQJt#A!;W<>nT?;tOx}+6jlCAjP@XL&3_E-k^&8)qB{N# zs)3zGByW7JKBy#suLJ?vI3Yq3mq3BA!52G)C~6H5oxv6$>OoO~w^Z(DqVi+IY*7?`SfCJjSSUj3ryJb=kKvSGfql#_h#0~2nup1GyZRAJf z3X}Y-DJKIGO8pj(-lxFQ{I_8ldbLlBy8t7A6T&}Y8Lt0F5fY3uB4lV)g}BmniMFfv z=U-JwF*fGO^?*CuL9$l4$PQpoHrRPKi}BwftT1p0uTV*u1w= zHZUPNvZ8bCr}x>y7GU7_%Q$IRTuO5e513elZyNhaNt)L1R*7H_sQ4_I6jy?YHxse3 z=lbwfQVKnMJ%xsj$A>HhAZ)V3@4Qj2d$;k9R|qkEM(DW_>+73o%odo^vc=;&xakU* z9&O3>xR(H!+1@Of4y&fDx<@Te$qx=>3!~>wKfB;eO)(JHS^fNCU~A^$=-k{yoTeqg zZr&ex#d{zlM5jlPQzSl6fO!|n%gY=P74@3RiqyqG8Yd-IOUXy--n{8+`Nqm=9 zlKIWUarQU=b)#t>AY1VpgQ@RZr{RvTiewRW`S8=|_#tStEDvGd`GHJze_;vBgl$7~ zAs!>%gL-^x@xlj+5V;HCh(hMEpw9yZHg{p@ZUgkB?`5a}#!=5R^-&j9VZv0;t9G+U z{lh;Tp!KOo@&GeasD0=qxXG*fdsuQj)Ju#FP;ljYfotE#@9?@W?w({=p3 zr8@cXz5=h0X3~1O-X=SabIDxlc+Xun4r@8(?1|MDdCyNfc>U1Vx1(pc{qDJZ^j;ua z&;2n|wGxI@OUtEi%i!&m>{KvSRvHs!dL`M{6tN}W=!&w4@B$t>^!&2O2-eru%EH;V zq5~48s`VykFT>Af@V^T<6SyDjIhuFaiY2{#PXlvYmJE4ZHjVOqu|0^u9a01LGgjz# zc!+pzDad$kTjy&}p)J)-C^|Vt=eI!!*RR&_^*cR~9JAO~upr7ij4|w)SNotG273D! zg(bQjp{3@YGVBeUA+mM5gcz*Qke$xBSZ_?r3=lOwahTt{#y)l6eBGhN6ePmPkIY^a z#FA2T)qnk|!%RbIII&qE_}}PMnVEbCu?c{VON@WE4!`SIRF>nGNl<-1&iD(q_T%!7 z0UY0IElM-K?fyE*eYo7?OHs7bQRulL-Pae_CuT6loYiPuJA!dv$ zI+I7{h7_>*F$@%x&0e-hBK_h0jBwerUSTVP0`)n`ANRY&vdoOE4(@MoW{CcXbd@n4KDa z9U$4AfE>l_azXmkd!cnXnEY;>Pv;G;DMRgnT4ee#!)SjYDb)quzB3)18>~z~Rhi5~ zpgfKXrm|5V3N7++FYldg%o9LPlpFj83s(SY6GrA^%wou;L_!ucmN4AQkx<-_uO6uI zQv%BH{TmupSl_%~fi3NOX}RLXcP5LamMzMATI`ip`KW9-I!R1R`DuJVUc+&|q1b9Z zBSA1L>@JzLBqf9y4z8l07Z$U_WQQW3V$IR5Vc_la;8K|;qdlI=5$4(8-HmOVi3##1 zIdp*(ZhaBXKG+BKO8g^69$lsBmQ(g7?|-gsy4?B@@qgP@I6u@-?SHyGI$@4^beOC7sX}_uxF0(h z?YOub$}zDPbGNBOztya@x@0!Xt0W;thDl3DCp;M#F?3h0Wm(UwpBOU!`S3!!o$oZY z!(5CNQ>{bd9mT0qDO3k5T%My)2R?y?7^y)ll8HPzSmt!~`OhHiA1bNeBk*x3R_yXa z)iKcvB$Y~u>JzxI3NC+w3%_xIgN;Q%{gHIq%~J`Fig0#1KMwIBB7LDli{F9Xp9H** z2d>aD5|@4f<((QS`A8+1o>8>#mikjJEH0-MZfvw(NxZix_JTMSouL61TBHSb`Lr-b zlhlh?1n{&45xOpHbR|T|ci23iWxy@ok_j#Z5@Fp^+V3Vr7zzHUU%$@Rq$bU=-4GHL zr|y;#mEOUQ-w+<9oDd!CGmHKHWBwkU3E9vT7G9+?hXE0Na?G$|gGB*KMxrQ^t4?l4 z32xqd*W?AAp%<1jIT59$Wbhp=iqNzukq~+mBYe8ft_dtW^;;HB@F8nPQJzGqvk?wQ ziO1Fv`VwbW$WV;x3>`u^Y^ytNSl%qEn+%vVE-cZr*})g=@HHc`E-CYu&Zt2pQUXDJ zx%kAQIfz1MN+Dm+6!oUZ1EF+pC5Hbv3IA){&F|k8$=(2#k>#J&cDR1mdHk1U#_`^H2a(VWg_?3QkbvGr#|WJg z_bhE+x_%km|GDv{EOTvKBUWnjHl^PVw!jF$!A{h$xEKb&ru+s%(lGX z7B)>6kP&4IIa$>%MM$;7$JR1VVfFwH8PNcvoQ7bOJ3~iA=*G z41Y~1$)a54vC_CS5gXE`U?PdfgZEj*qt-f;86Xb+E6&EvZ{23=kFQ`nFGqK~ztgwgu>Y5pe-9(!u@2Neen zi0=_AJmjvYghT|ywzJR`3Rt8{7P)rp60&>A9M-bS;-+JY_?5<9R`<7a)ROoSd^&$eB>{0SxX; zn>BiX*%JXK8pi?EyS(t(GFIfjjpJk-a8L&lZO_2uY&t0D(aRIUpTtF#now3hq`53V z`P#n;BO~6RGkl>CBpaWhI;-_J{P|yhlr$9|(h$$tEi8Qm1NJ$|-r)v2| zXpevq!q5RsxSgU^lUNOWGHX=7o&8dROPE zGCSjS&*aH2wT8AEm#DY!gT3O!mjE@D_TgH&@|P(w~}(3Es2 zS

Qb|QJgC@|Y;2zzY&yhuJA1?;Ojr z^d5-Xf#YBADo_!sJSJxUSpNgMt2X`{@EeyXsR_RQ{)wB-Q?lBjynAhYbK#^XK=|_ z!mei5UV3~OaAF|S5?AI}Oao|vhb&1a!jR(n8_nAM`|jTObK%CmFTNOZ!!m>Gm2~Tx zt5{YAvZiJ&q7qSBE59_pt2&LoyfHj`TJ^DCooiBt1`47zJ|pEb!JQSPhTZpE)dr{b z@pMD1G$WmTO>T`76HiW=VqtmfdLv1*`UY{CU3#Dxie`=j~g`ri-;uLvF`&EhGXDv0{7cNGu$6uTWF_kXWXgb=NOWr9a@GOG?*Z$q3|K zR0D7}W<8Hk^hOF5-me(Fytyl!og;11((q`Iw&Wn%&0yHsN>ZV(={|)|NR|r~sBy~t zL`rG)py+g>uUn`;m-R8o`qs0i6nayI`N?3vp#gNt)GpSDoexo~zf2Zsu(^?ku{bWR z5Ybt;WHoe2lY{rsyEnSdEn2Dvqxf#=BBRyLP>f@spCCD9q==?266_!@jf)$J9wFdr5+^MU}pfw>V_Po47nnw+?2@|4^kB=3Jv z<$2PJZkYU60_Q4_z=;TOv~7clzdN0eB75cVXv(jl1wJnB zejS7N=Os^^^ZdB4ivF1X;C7iH<+Ox<*6BQ{%HTnafKw`B?zE4eKmM9t8a3T*SQRny zxWFnG(k7f*3(UL9l9xGyh0fe`vCubWUH$XW=eqCovU!M}MANW@Xsomnk;RC}S$iv_ z&}_G-$$a)|!Pp>2W(DsQQ_yNoZRI00qj@F8A>nlSl!d&vtrUxbuIOq8Xwl6-jr-*1 z$z>1*;zHk6(oIom1hXnB5ojMuW#b|s6;q>RoZ`YU=MOJYS8cO>%HcbRB21+fR+H*# zdL5V~TG!$UdD|=fbOEKRDHSmEB|&d1%g1&&5>d)(ID%w|>|kq?@I@L~z*s0aK5IV% zJ=t`zsVED{!PY(D3w7W!B{&6JM=crpdKy}9Kvi!o7Yfwh4Kph%&9lkX@P6f*$=H~4eE^q~O6og{prO5`CI`f1x|_ely7qZ^?cB%fmGH4Wt?{V!7*wTJIa3h6WT z8C4De!ZU%hZG1u52UL`E#4x{a{p}w72>hO`7nz0G#c4|fNoj5<4*XFDLc<|u|4`DEMFhGR%)n#HrLFr3LPqIZ$&$La> z=F=LE??X>-qoX4B2y{5s>_wCgbXqtF#zo1>Sip-Hg$T45XnDb(d6dXgDe=eEK~AA9 z>y*xlv3=dI^vczW;ZuC=d>pe z3k6E|jUTgbl=_w=ZH5p#rC#c9x;%N{eOueHS3QT&nm^I^Up71p$Ee^?;L&iMW*@uvBFEF#g>b*K*+^j7fHv;AT?lw*cVX} z@95HZ7Vgnr5n?5i+}lWm=b=v*0{&KZkd;d2^fF!ub!OCXgTF?+(?~OsWdvC*4DG{# z48UsXD7<7|XF)d*PB)d$*yd#c0w==ALzsaT6fh-P*&S)BbzeOpAA2dDZ@}qf(es=b zO|ZXEDJ(mYiDWG?lSMQS@Z9pi1n8g%?h1n;;YFK@ZMj+EDj@=wxnTl|Ve_0LUknl% zXrYxmbOQ(3Im_X-TV6Cl7cF8wZFwBwo7X8W9@ZE%`>tKyEBll-6g7u7Y|m$y=@(vV zK?5xT?`&^gB%0b7YNeqC4p`OKR8`XmnkZ;#UP)q-)UsE3hqg4Z!J~d@f5pH_hs4|_ z<`tjpbr?IvL*V}qBcLH<8f!m8Zg|{&ud(rmr}JN9yo%Z&^AZ5xeG2S9d*}X2Mc1`o zCi#nNV5OhqsZ51lezqZMPAa>?SMQg5?q$M9`TG;zgoV+R>@uY;$L}}XCxPjUt9nre z!}aSGm8i(Zm^E<~S?-nak2h@@vPuRF`&MMC{d6t{(5s_s?b*MCz*q=g02E?Y0EHM0 zD~Li&5ugxD1%$vD9%d^CKonx_6k;hoXL1y9CliT^Kdf;pEV)eMqwFXS4$%rSNw6=o z)2_|(q`Z*i(Z7DX#Havbf|NKbfDjl|Qkp`gyk#xs#Pv(_5NL0tHAugGML-Dbcg~Zs z2#JKmX!_BbcoSMa`F`zlB{Nqv`?8aJz{j#J+aw46+9VClJMo3lUmRjc0JSeQzb_T) zCxQ*B_np5u#750Q9Af-+CbxMZQ-OM~=<7AV(=s{)7Thx6J6j>UIq0BT%&G3ZOux<* z*kl*&#pF6IOyU|8pYVT&oHKLs&VGyd58IV|gd7A+3;R$@IQ= z_Uev?YXItQHcX6&m0%$qs`gp!tbf$SnAh$cVw9p!Qsg1a8iXc>`|>r^utM7D%-}{n zx{sLjmy^BH^uQ}?r|G{X0P=$Yq4}rJb}^>(P`)RdDS*)YsoZzY!(o>Ljnw+BIWCo3 z*nzFG+vZ2wOmsj3095(bL;Gn%D-7o*O8Of$?buk=7En<_ZQ~Lax>Eo6W`@()wpPX^V_dc@R@tRBfAU&ym_kkZnd9R082e%%dmkNysc-dD%ab?Fh^k`u9 zyUsof=)UsclYxu;S~Z+Ce2mSfr5Y7wn;P!tH#{}3=#Cj{%tI8%wqozc)}jCs2WY8T z;$~n%K>@@8_{yS^7*e*xg#a$VSKX^n!?nJFLW{>)M-QY6Tm2Ob$ zK@KJX*jE9)C7}j1>*dvJL;TpAus9MAr|vKODV2bkt^oWGOPu?x zL$r?L6^=DB7}7spawMT&IQiaxUbwgA%irow9x9r*w|w^rNpVtMvLf}2)I2vy2@b)> z(Sgr`k-QiBL&mKLH~bl;YF>h-FeP~JeWYO?$8DtCgAe>oC+j`YW(P_jqyW?_OwE*( zK$4fQ-5V5RIF&AG1IbqSE%^J(^CH3XZ-&s~rBByj3%_(`+@&-aEBeK$T=>M2>yykZ zp~dq+#@YC#{Tp{^v&csFEMQqDiv9D_{$EMSK&BuDaIQwCq-Ux5*X3Z1h?U>Z3dN)0r<@maz##IRcsL zsFRN&v;gB;yG~BZx9ljE=m5oRLX9~NEnIwU7Ae_0eD&^ZAHYSK|No1X(883!qG+D8O%*QR}ve_`Zze|daMHy(PW ztUtVPlYCa7)G6(Rif#4Ki=eaZ@v=zKIH%~d|FzmXe&)7HhJhem0T(StEjE#L%z&yF zIi%!j;1wZQQpa&@vMk)*-d2-Rm?P6JtnbEO7$5e=UU@{Jy}_+CNf$U)d<6;JDbjJ3 zpaCAv^8MZ$dLa%C!cOzBC>mMQYHD$%$pRN@$W{l9l5@hBsNCLo@BYt{jqFjo z6>-!MeX#|Y2sbkT8;~LlD2KNKy5^3^pCDu$51UZ9Ia-H*d_*O>GaCrSPv0pOxQaQ^ zfU|4(|vFr?&yATIX-+)+V1E5bP@lQ zygEA1%E$lp{&BhcVtD$ZU##J|IIiWsrF3>{es=q@n#hfFc&(K|;K@n9?{W1g{k~K`YDk^Eu*^;jg~V!FVe|<7$h<8p$=+4#TrS%OW-z>K(;dJfdTbcoFBFO z=&aR@&$)?eS!k*((v*-& z89o)$>~~UX(U{|Ss*Y^6v)dudCJgr}39D2kDHl&RCbdQ8NxeB1>ciWdEl62CTmogA z_~2HrnvD>KFSkgwxFddaW@OftZgt2v!IdgZPWKO7-jL!!Qf`&^5(-j=dp64_ZtUAp!K~3pztvWq=Iog@~bD9!+3?G?1EwnoVmL^4> zZO4?@CU}QgQHZAeyup!!RcoDX&_LXA#4O|MR)S&^oOeBK13@O)t3eW)DMdC#9Vdsf z<(@ocv@!eSQHo%mD8-q#o`d-XK`Bl@AD`Ym#4x0!a|R}|ux%IbBq%jSvQ=z{ng*xg zB=r_skH~tKbDPZAVs0xmi%F>+DWB4$CQ1xaqa z)2z#FpjsYUClDHj!{G?MTCj($n65f}?x4dC6GJCFgxW|mRNu*+OfW)|{pD2_gt*K{ z><$Z6aCTNo!6YHYm(!>QqhN)07#z875M$yckdmyhQ3mYz;8olPGqy&Gl!D|c;1qa} zV$4~HU~`1bKR8Is+}@3gV-F#`j@~c~F<}34o&+I|)oB604Ye#iq`>wCjOjEZ?1c_8 zu4^_|;gSI}>nkRTXrb857L`G;!mzJ-v?~>Phk1~ac8>Aq889k(+Q@jW+02D7ub9M3 zwnI%&F)a_R=NMmq6wakhx~!IA4>EKx%%Zl>SY1jL~8jGY5hUx5S%&pF$T zm>=`eiTj~%fH6y&oHaji1Gq-YNQ-kWS3?s+t?xM#f$`B`dKDhiESE8vtoIc+Qx9lk z2q9^5(B~^6Xo!py|LXFowBciEKZ~3v9;holLZAnNMiWo0&TK7bD`8SFWon}mBQ4aN z`qGDny?+GMj{)FS3fYz}dwUlL>RS^S-Z%G+q@RhyGL(Rs_dVls0H3y)7VK(rqsKZp5VQu_ zPc-@oS%GO5$S=o5kja572`!WuQ~e&!2GwB%H2S|@ASLGS%fUMdlMyMbG|6a&i?`GCas_7P;}?Ju+7v92fxJ5j)$sZzN$dMFbcP zXf;-&#aUAy|B^S!4BuGr*hIv`e|2k5iMSXS^hz63ug#>zo6?^np8q(B{%c$=7T)PF z*#MxU6#r*H_gCr1|L~LmLPX1?U>sysiWZlRS+^qcYDBU`#$S(aICpy2KMI@*^#@ z0SRPm>emDGj;$F0z2i@qRSOJ2;8L)1HYH{-iKI1S(^;Oj6Zr|2jJyK;m1Wz*gQc{u z^1v-^?>9Z&{}Q-V=(zhfWBs9t{}Hc8&-DvcRZzLUEN~<{!iPEc8=RVj!k@+s!<(iM z>F)mM^{g}?ca#Tn2;IH4eI})ej2!log(6tKnm`fOx~S-xJ_urww8wY+O73eX`4-`XaYmSLR_~yh`L5bmfFuk*q7*-?kDW64ez}AivImUiT~8f@40YZ9 z>IUg2;v5Q`3ICs)4mN+D%W_ujmc=nc^m`{DW;Ph5qymleikR;3!>rlAS}2R!Ew%X$ zx}rupw+XpAR-;n{FUDN$`YgQ}>%N^nI9Q&(Siacoo@er3^L_k$;O4$7kSmazzUI5< z?wgqY??sk0p8@KMK^{3^{?#E&G$&dm&`Ya{Y#sX^8*|YE+zsM_ceW}5wW`^4| z{pxcf3gW1^BowjWEeNIZ{%EV@ni7h)x)g@{^3;*A6?QYU6q9*qmV5+`S{ZQBF0PXi zrcBRwk*YsEv~+Dd$Mb#&i#IkiWRJ2lW;2p*{wTmZP{LmCq02nPQ(etZFOE_#9iCe= zAyff?9Ou}0j3H_280KUKJ4s_VZtzB-WZYd|*S8`a%4Eegazw-R0lI8|hOF zc^%`OD+}bODt%o*OmLmq2!!QUjI>yc^{zVI;sMMiA*(FS1#AS!>vv}Q4IjV1^QTE_?hS=z&iy^TENx-*q{zh=%<%2YptT*ULVa%aai#} zTBg@9FYNfA;mJ5x2Ef*@ zPZlFPjPMJBO#%&w0PRA)`2iLDA9&a71-95`vYVhJCe0mo-o^TOC2WV9GCI=q``)oK zKW`S+BUus<6l`v$Ul{|oRJEd%N{yZCaCUNpN4Q@wPJzi68SgcKF{yn4jOgn{s>Q(c zY~7eS$shjvrF#d2IiZWxY8bbS}sphrmyUncGrZTEtZ8KN2HefU*L>m{&>+qj5Z z+kEWo%l(>$;}jj9h&S!yy`Q`kQS(7!nX!aJ`+@K8*Zy_85%?=68iKB&V!MLV9+NP3 zeZ4zEW?=f1`gwl&1>-QiqpFuk8_kuFaeqS6HXsl=a1NR|1?So93;|;gTzc)ojH^Xc z$mxoM$L8EQu?reK8BXA0rXF(wVg*8{rYjMm2x#&F07CMVolne$5Qjil*fU_Rok)>c zo&7|Q)9>#e*AGL}hK`RqfR|As(F@{%dl@Tf#a3nAQvfg9ex@ zpw0!6;i*mc@N6Z3CS1d7Lsr(W2ERwj3S;5PLl7D7gFpd>^^zKI=e=B1A}wCxuelr( z2AVLA;y?F$K^O>x-d2X6GC*?!gn_g?7OAxmtws>>VnG8UJaJlUZz3)J3-5k0&~N!Om=XF zuGJ`DTzzEy#pmP%@HsW^99)&2v6ldZDL{(5ENc|f8iIcSj_O@wQqtjwG?0}uwHJ z;1fW^bFFlzWP>=l0!YCsr?<2>oo=$vF?#jtYq+To(Kuz0`xpsrI6tKiV%vCv;Us2X-adyfQ=sk%=I$+U~^{{UAgK-892 ze&Ke~1~Aew&NT$r8gN=LFe${Zu%f<6!3tzEG0_%QsUf3$ID(p-GOh{7ekZIj_pUX7 z?ZqcR#@y91Ic}n_%Q0ND#`lmNzj$$#0@IBEGLBoY!!04?fzxD02=LW0#7;@2nHUQc zE=z;;yJ1s&4bYRj6F#HHfxi8pTK1~UQILScUwF@HTQd}3^afa-x?g9#%) zh?>aFE9$hM^BqzAPW0HReo2>@DSi3Og_p>UY206(>7Gut^5En2wCl}5oqA>e@~MQ% zhq3mLO}n}JOag5R?W&dSLJGU%YfnT>^B3EeinF;z<;X1;7U!leiyEUM4fs#aM1Fp6 zLQ1}U&_`+c$sNf<2mht4lx$E;f-EYVbJR=FdlLhvZPHZVHVnq4|N4bb9gQ99B=${N z85loV(q~;&JVO^!LfrsG;briRsv$Ja&mpoiBxGo*XyLoZHBu5dqAB>tZP{vg8xF?9 z$5|Xc3aXvVPL-z1Cc|8qK;g(KCRH0nuRw?TH;o-;(9S6mR!tnjA4!lp>v~j z1~&Q0m!eoNF^3X$URBr-g}>bE;A&oQ4I%qsrq;IryW*=LiVes#G={!!b`>JjWgz32 z)e0Ss&`m94AaBxk^KFdzfB<@o_GTwnrIUDX-wZ~o>6ZF%^*FA`5jgjv=1?(=?5jE% z)*eW$ag)X)%n|t4csa^rIlQ&F6YL9bOQVnIw?dYVGDoV-JF65kI;oFjIcoCcAbg8u zDq8Qq<1MgZb(%y<9CRt+`H+p97&CtYqr_sQb|ax8&tbT-(A^X2q`sErDB%x|+@+{y zr&^(`;{(saNG=!cR;KeLJ|E=Y^o~Ai1dDrM95fIL-WOqb(o{_IXHU6HPl|n>uq)t{`PzzI8tAcW^nO}>hhPlWn4jbE0 zm3fA$>DnqK8>_(k6izfbc3&(*tA!#M3(Gmoj|Ky4L>dAjSCOJH7V0%yuvS=}nU$c4 z+d+wSf!4YUTCO7dBJM;)sZ3JmSFs!-W<0QW!MH(b>NA$mqG5ssXz@7tN>m$XT_%tz zSyGl_zD|h=T8bE-_NlNKY1({Q@z#sJ&|p*PZ6rri5wtk3`y3`A3gstxQ<3M{P!+kO za1!g?K^7V+TKA`$(WIyjM3&MdqseDQ*E>W-DKKW)ILPWWmF!N@6qaCpTAaXs+0UYj z@jeUt+vi?t961iNl=7RfG!qYd;J(jm~sJ7V|bSWq^Ce=Uc5)UYS zxaEJ8VvnRbki5PX2#K5?I4wLyYApbK4^ee-sc#K~IlID$M$(73{ttO?6;wyJZ~+3r z-QC^Y-GjTky9D>(?(Xg$BtQs+;O+!>2o8ZjaG55b&eXmC`>mzU%78l ziF+3y-p5_;Pv%25c)$t@K?p5nTVB1j{S~V`+;t0@%6tzlxq$>gRj!9WXhYxeW)ho_ zK|~PGPoDJ6FA=6~*j-}mFRPUoZ*|REmD9IKJ8;#0atKI4(LAA+u3&N#Y`I@n3;OMv zG`ST}1!vtAj*gB7=|avTdf!X$iLo${;AthIJ}>t)&$xUj&%%kn-=UWc-$5~|`Fx8) z2+v{yb=+(N2K9{q9G8&T2rmN5T|hUy_KhfDGhE~}S|;i@WA)@WSZ4mp83W_G$x@r3 zmdh+neB<*;Teq}KkleZ{TG|=GGuem}o&i4e>EF1uWdpQ#h8j}bf?~?1nS3q@T*5iw z5XGE-(&9U+Sy_Ld1fA-7h7zLFg*(&R>6=zJ(a>m^$M{F_&~-hNKWBY>tPSUA{p{to zpunQVrK=m!>c-`d@Ap41kG~JzoXa=eRgWD$o}X@9H0Cf(DtvoC)53Ey`DMt`@O#7I zy~WORQyb7kG1BsIx?@uWbe{26Wko0&2@&mI_I2lC zbwg3E)IpT8F>k1qao!YVMx8|fkC#m$C_soCN)YRa@6zUo6{)^|B-=kcgdI-%dN3qh2ql$+I4e?$bmsl=VH!!C zI$u6QepNhD%^ybA3GBRTVlA4Rs0W5WUcE&z8i*yS+i2~ikWG8lo?9!aoX zTo1hdO9jHYq3!@Nm`GGv5@=^Bv6zc7E7*un55DgwjHa`OjxMO9Ix|sgBWJ$7;`%)H zukbw~ZE`u|9_Ez&(W!FO^73@T)-gCCFitpQ-8E-23Ua0LNy(Q8c^2gu1?;0S+q{9_ zi@GBa-fQ}*bXazWxMt-8g+oBGp_Moq?a)+6hMa;k@bs_a8UZu(Y(+4k4nMsLU|4?t zX3CP;$7Zk;i%b-GYS-ifE74a-R9wN7lPbTnhM*p0ZIM8OT|=I0;VuS_cufX%9THuWytA;?ZN_^2-_ptnex&6ZSELixPHTWY zm2kl^@L&aQ-4EMpuAi!UgFUjDhi+|$=Z|*#&)>=a3}O8Y^=2&qzzhz+r-luPqy9s% z_TNQxfPpvc2i-3MtbtiB|#M$u)5jg)~4Z_)?wkc*vs}m zpM1Qiz*vSmF0qD{OGYP~ey2KOp}Ltbq!CObInh*RHo{)?l?q5F-`)wo>t3v_4n2p4 zj-`8d>X(hS?a9FI5@{{*hAy=s%j?#btM8-62UbdJiAMHZ6{Y8326esTfC0ypf6_saI=+=S5YrwNwJbQRMhOs`Pr{z)4njCvwIaB+TAh_JS}s%+>-8= zT@%BtONM{{ekje2m<9#(bt7VYQhxQPjlKi?X(!nGV&P>?blE?0xbF3m^JYJb-_Ee0 z=p3OP>PMnq*U;f`)>miBCmnk7XUU0)wMs~%Km9WmN=aXN?S2R|gt!BRtsw~+BK`(t z=eTl}&~gLxKLC>E3?QG@Bdwv+1$q4z@yVC1<|Q{+I_qKQBISqTgZvrDx}<(Xy#P7 z#$iy|_=JH~HoZ%d8JOF`hKulL7y6N5`R*r5 z9uF?RslboHU9Vq%o*m@>3>Hd)=3!itVqN`Cj=_{(Amk!B%c}+VduDMrTg%)2D}_W7 zH{b~&wsByC^M*56@l`_;b;>>xU%6Q@)_`E|lO4VO277NZ4-nQqHX3x`$(;1E9aBUv#HZ&ZH``2|5aMz8V@9B3Bya&0|{E= zG1T@tpwX1sj4J9QFkyXPsRP~;CQI@7L6I*zY^T0F-2e1oNoZ~^{u2Lg+jv#)kj0Q(iW+@ zpE>S$Cmorf5t;;9RU_}t5?x`ZJR|ROcNf^_WWfUaXDbv0;wd08G4?SEWgjPo4{o~C zGjM|6Q7HT0zuiM}q)%T&vHk@JKVN|6MAn#o$Bdtb<6yS6id|#@orF6HMJV z*W0*H-*o&e)qd8m7ogT4N$tva&Uo+4=8M>!xB>3sR={2C{un7MWk?Rwf$cBK;lEaW z5$`_2Sk2fQeQu)EE!&=osB_N%tNEQfSA3Y7upH;?%y0HVQLly$3gDzX?R4<5R#}+^ zhN6gZXjvHwX8N_r z*M2$cUufKrw76E@@Bkep$WBAbW$$Ph#X@T14vmen5oE?3t+>k=KIY)dpU)J&^Sy1O zlmCUr;7nE(bEkf1_Q1dWcy#+>+drX^`-zZgQiy0m=u7xUO245hk)j8{MosJ-KJKco zC~Ay6ov~;7=INb{Rx!Z6q))%xyE&SDUgfZwt^Z|%N#UE5BWnkLf}5f zbAAC;l!PlD7r{ZkolD_FdKVymC{^ENs8hHMkH9(s60W1SuQ&8J zc4|rlV1`~()_kd_C79U%`n71T8RK{z#$HQu;K-_-Lpp^Oex*i0qbFIeH{veqFXEx~ zyk1&6y?lz5FB2;WZ%#;Kx5m#Ul0jJ6dR@_@5Y*^ z9ydI+U%>Iu_q}3-H5;iL5=PBpW$Z=ne{tGBUg@_@0|1C4Ft__JeL6gU`K|v2AjxRt zI;1@|aH4B6wHg8jc!MOE?m5eQb5%dq8>GQdxlSaz(Q=0O{Rg@%U zO(0k5Op?}ZHCLfE2U+QhR1|Y$5q(Ms*R9;pF9CRU^_<4iBEDf$SOgsCI8o!mt=793p za=i7sVz0H-fpB~63!@xA49AK~Yao`|Pflqk-VaG|c8`);oL}`myMEa*4}6ha;|Rk3 zOoCeqhkfsb^|Ez0_OL54X_;1oB}4sMK)s2fH)@@>^-d5jJSQobKo2g#LOn2l`|3I4*!>vs&H>!~$tP6L(mtHAbC;geJYen3;!AC==n2Y$Wf0`doi>o_HZ|FM>Jd z9sm8i^)NidY;X-olCeY;I64Gb(rT^&GXu}PCwK9VQv!d9)6v#IUQRMlPVEYmQ?K0{ zJc0!J-5^I0kdGT61U_9OM|36)EA9I6QWAifglBv)fMWl#nn?ZWUETefw6q_W*v7=a z^()%b0D!*xn?M*RpiCY= z;_&`o_)%$aW~;7w3E;5IqFOj5rt!rs5P0?DOwIZuo?5U12l`dy-)A zxod&0qPkVsl+7M6Ft>$G0*Z>dH&f!mG9?KEY+qE0XZVXKNac-1 zBGgqn&&)xVA!sZdoDDl{`_PcGk~x}4C1C|(icR*=j*|FJ4=Km}PeaQQDJ2b1D^g;b z#DSH2Je1ODgl;fvJ*^V)4UlzmXLQ%n$bu3{$!|*`lHbr#KFvs_DoK!qTW2t$1xx3q z)HFpd6~ZoMS8qY@cb(Cfxx`Y2$uWhXa+0PDUZs<@f2@j`)V3Cn{zzKfS722fnrq#rpm&3RKZ&!k9fNW63vmCd^5ItdVP1%L-?sI0DT{)L1PB-GW^~9+FJd zYb@kRdp;JG4w{YJB03qki}yU{TdH7`LiV!IYNG~?B<5Z z?g;mzCVKqc1-eWps$XAlk2pEfMUlRjUB7KrKC_-Wr9%w1;9|k%L6osjJ>_Lr!4b`D zYKYb9;E`)S&K^rCa-dzR6XQ!IN#QNkaAkpPinUtc;-Qr=y^gG|7L)zuR7e+FvAgNC zGtRA&(Qof)!tCYdHD)BQuoO&aJ~+(XH}*&~vZt`4|pdkOyb1Dx7Y~zC|>gk#2{(VyF9U zu~RH1t@akO39~akeHns5)3(gSrQ$@cfj`ES*E2csNcKx!#dvl-sB+?+o7IvL>KFGN z|9Ah|HvFHVl`<)@3@riQe8+!JqviS2H~+il+AqKP#pq4|TT1E;Y-O3n^gXNkgYWOu z$T7S9;_Ukk4|`D+8WjwTK&A|z34sN{ybYpMaUX}8Df`G|>Vb$>InAQAl-vDyKn4l4 zAk|jPF)&@QwcftJxafT>_@iY6zLvphM^6*kM7#I31<4c6-{!Ri$(pn8kN6{CeWD1g zPx=MKj2*V7+!(M8ZGN|mME+i%04*bdK+DJhI>(AWmx+#>a08}F+rBUm8`-~8_6>-Q zyz-NyOeri5wDe8baP7Z+$lmh3;e#jQT?b-h=(t3O&_r zZP)a^yIaQI-Y&=c^U!Gd9bv#T9}IZrlXM~DptO~M+n3xHXx$>ppL!r3fvJ?tJqoIVze-w|5~Tlq)xwv zd;pn8-`_~0K~F`IB1|=JL}2UOOtGTO+xrXka+>fpBSlalFMPS0`$XAV-a=r*mO=XC z^JIY#EDhL$10&`cBFidKXq@d_KWnBU+elvx)-0{C6% zMmm#_^zgN|4LGLLwbUbHa8Rx1vl>2FP@%zRU=VJ|z`t|C#(AKi&;Siq)+kx(H5xzs z$v%)AuCVp{5KaDo{zuZPw}I-naE<1$LxYg$o2;r|KVQ=`sAI+6>4e7Qog0f*ShA>YLdm=lHvkJU8`0P{Mp`X)Y)br^Lhoy)3dK(d zO{-JL3bE!?WN4>eb_4_BVh7vlxx{1E$Z{$Kf3YI0+a6_KX9dCib0ci)vxut8!gq{{b?AMVa@l-v$Xg7O2(+x-_A{EXPHge zw>e0*#v?M*hji*toWY&b)25-z;q5u%hn&r;f?8U`?qNtA-dUmc2z@;x70Gl_Uwb?A zvya!`4ULaKvA5gq+{pdJ&cD6a;-p4cExp=PZ+|%6YveBG@$E!&M&yrHmJ>MIyYUQs zErT#jjRAfe#N5)j&|5>(u?_d5VozV=F5Nc=ASL5@gQkxkDi85s}R+YhO5MZvNQdoWLium(ons zaIg7_RdzA^b0@rCx~kIwn++N|m+_scT)t0U83LO4=SE9{u{jkOlTFoA{xv#DS~}EP zto!%dFg<+ysLsEj#pXH6?HCS4K1{?Q_v@H^?Q-y}cVrhK>V_%04qq=+xe8ePnU)-H+;Ln&x`KHm2!&F3P_qfUmA5vt_~MZXUM^#!jfXX~esK5Yacq=dlxoKB3CTEU zNcChW9Kly2^hXnV9~zx+==eH}Eal<{JzAmjs;^zeGdHv9YP{O0H96E$GM1^gnaOqg zm)bax<~jrZ=g!8!Oqc;H%uaSmCKTQk(@r8LaVwYR!_H^rH1kX9*hluLUh=+m=Pmi3 zD6x3>;~?~ExJQ~Ht}Q$01{5J~zC*4b&_8|68H&RK$3cn^`x-z# zcTPs9y@Kh9kaoqC4Q@b%6nwt7Z{HFtfW`!?UPBo^@0(aY8S?{|ng%4vzOtjeCbMj6 zCt(qRA$0^3z84Kf5MSd!*_p8R=LkClqAC~cjw_)se-V^@$t}+WcyP5ejE`+9bKbxm zbegk@LnbGlVA~xP1m`yuqYf3;7{WP8O@vVppvN2 z39t$C1#53uO8neZE89=6U6!L3DP7MszcEetOf<<0_{Hp$9y9sr<_mQtyO5*JCbHlx@Jc%D>4arLB-1`dJy8|s>y~3#$aP~m|rqtl(F{IY41K&w; z76tVJp3gZ04xj>gSJmG`->NU1ul?>PWrl->|T8+=H&oj(#u?R_w?Y}Rt!`qf~3oi(+y*PRs5YX5? zt~|^4QuPB%-oKKsiHQQkJ=0AY_H88yY zzR>>Dy#H^eHaS=tEE2j}{jf^6@>|t!`5I(e_z!0*NkdWFIi3#*U?o3|B``4c- zG)hkD;T2}#hZ_W-IA+j_H;rCQ5+OBFNDj=D6@0YujGJ8D{QT>|qq=y;N7cyz1sOMa zXJnc4(yy16vGPJ~6wgzYmZ37V%X>dt!$rq6+Uzu$SjtygBA6*ePSLoc5k1Bcolk0g z5l;LvOQ&K(t%&1|d?O9F^sncsiHsx$;+7)J>s1k!Bzm7!4w+edgmy(^fU33jg!bL< z->Mo69_pqR0~@{H|0(@Zg*^j1zr}yBPEHzs&YgGph$1kF>|NqwR?6X z^bY9`IHk~I1+ZM7oZwSoHv~7xT(5Y1G$eUCB!qDS!#b)Lbxzp0o-gi#-31ud)8I|U(9Vv#veYS*Hko_lSKtBP!-d;8)5WH zt_L#F*3*>*C(@uv{ML)Ls3)mg*6Xpzo8I{2U+;N0CI_ERpBDDqE7U&X2u?VP-5&R= zWp9k+Ffnbs`-Np+z4Of4X!!P4X{lv75!)&B8)ic1dolMe$-#1X!G@f&>TzSabd?)OZw0r10+r$Z5eMm;%sq z%{cKNQs$YeQ6%H*g1u`3`9s~6kiadXk^Yz`8 z8^!c&P~TU;5$V52yt!F${L#ALvN&Vh`}7$!1`Ec}cb#Whi+vaUj6k#!(YBxQ`&A<+ zYX4OFJeF;UM8ipAj_Ker&qw++DKF7VOkYK`Iq>4QmvahCJ&`h+MXWt45QOH6)V3f$ z!ILP_%tVDeS*_Csk~2;6)R?8cj+T@kWG`qR^ETTWnjdSSFh*&RRP@tqkLVF_7dxOm zQBajrIDf1|S>lj*W(LYd0kT(e95`D7{Aw7U00L)Ai0RF&oq|a-CjsZNr*h$1PhV?yI%GA#;_K7!m z>)9ClqVVpk*)EjPlz*R^w_Y?OR$1hWJh8Mp8eiLBXvwUVmS@}-z873h z);U*BO=OjZRMYcbp2gBBk2U6Y%9l7!yk(TxS*gG52L?dL`V#zil=zQ1 z5HN5+Ih{WGZ{?n+J$|^>qLWQF#H$R$9jvBL9w=Gp#__+5fAaD2PXX&>wr{h6!-qnV ztSPP9K5YTCd+EtMk^@OCq@o{dzEWA7KOH@N{w{KuYmMCm4P8s~&eT3Vys!`HUk2wO*l>=LE{>251ToDz>t}I(jn#bS$m3!bjGs7SM!VgG>8|=yxcn z-Xv?+La=D%g%(V!1e+MC9r7wU`dY&nK)bn}d*G+jnY%nqh-W;6e3-sPglTd*WA4e% zw@CGAuR%>8o6RmOLT02KxgZ!vS)Y(6%enO!dSw;*yAd4#Le?#iX!~*NvfOO%PeS$^ z+iQD^WTcT{jtGR75ZE!Fs$o-?Noc%4(M(6EQ$a;13&ff_!vh#xGbZ2Jo)T#DYx(7DYuDiDyDuFORnH~%Zj1S* ziIWW@F6JvXXwR%6^&3bd^AD#FfLKpaNs%N~EKig-JPzDu72wxChUYVGV^xE9o%hl| z;+_{LfC|BCpBGO>8L5ghYlw)1Ba|R>CWv4{z|1w%1sSVjY85uX!nzZh+Vw7}`tVLvNleUTB{8~t_d9c8-TJ4>a3 zgpvMP6)*ZI#`zTw5I>K~j_V4zAc-{y`EA#D-i&2@ojKu zR$;PBd~XrMDMr17?D1BhFeiwp2Th8Wawx>OS;=m%GM(luih2M@k?)2-#WBZ_qf?|l z%pkThWfNj{QFB8XZis0P!I)Pa+bXz#PtHRNExJS=l7Q>aqlwr}9vpWOJe84P{`T=* zhj&z@ACEF|dj|L?tIWq@DbneIt@)CSZ=^d7zGM<;p#-_%+Kf7sP&7$$&DJCV*XT{S z%#+NGuCr{)t`vxstX@|1WY<=3ZzU92ER92b!ceADqLf_oY`xx&?iP7wCz7@HAG`%# zn|rJ=5oMM|2P0dR!~}j2#$UlnHdH!-sI_HjEzz{T+ttWyMDwt<_AWb***0ep)f$~#cN}a{wL@mr|LV-CuRO98op$Q zOF+}txOkp>j^!y*TAwWblZ~$P>wSF)!UVG+BinjZ<5&Nr*>b3~TZ%)3$C*>WucSy- z2(%BnZXY<8y-GvUAPnf&86-D@b`Hq}A5y@UyVF5%3@~mZWAX+4hJpaU63Oj)UdA&H z&zkRUYPJ&%96uTM)4YzKx!TXkFQ&%H!tlGFeJg(rio_bAu>7(Cc$anoc8e?aqQFhSYd?k`BvbfqIOyH!nb(BCv>AG@?;_8oG%`5C?5wQus#y#Ur- zY%+FqCr1}j45SK3FD1!LOCYb2f)N^@>bpWd`C^WSTH2el`{q2nLGXTJ0t&mK)=eiD zJOQmLRG0`HdJ&C$vY39HC~WsV^s0YAz-bD(ruBL`IiCpNWvU@cq`!-|BR*{*m-g<~ z(|jcDH#DX`5c+3kRrBY5Un()thrT3+6=1(Fjqn;z1hd9Ri;rEq_36n>wrPwkb~n%w z!iW1pE|Q-n{CM=cGhF$~p{J++L#LPjy2i@*ul>VcxG&ySt=Z|ikHt$46J2$!twe@E z9F=_H>7Jr`{)D38OW5cyU$5ATC#qSy`0z`qpI&BO>zt?VXfH0YTk)pfPLMvw?-+Yb z6o`PUqwh*26c!K%)MT@KrnaBARJ)3$S2lcPhV#R`qENDjsetq&Ref_WUWO6q#1je@ zM^8Ov42l*3>#8LjSt$|-mTa#HKA>Mo{LV}yP#+3Ij+ho%#K7#RFbFuJ>lHnqUkV%o z4J=#VA(W>s`cMbD3sDu7s$|6Krm8^86RIGwJ=8{hto*cV|4@M#y zf+h@~-4HYFtab`bgHtX}sHiMjfoST9JSYCBgRu?NzI_EM{N7uH-bqVrH?$Ky3v_6E zjWDy)9T!Sm17-d!97w!Yh^|cv&cdSMQzMB{&0>si7ksHks&buHrB2R;mp1y_A1(<^=PL7Yr8uY>toAABa9Fwq7a z^F@KenXEcp9}pF9&?G&XwH>%1lst!+;}5?N6|w2?OHD-`ag&jKO0k&6PGTEjuA$~E zhW|{Z<|-NeML6`2Ly$-t3C6_DgBB^qHz83I6^6Ewyc5)4W??6+oD7^LO0ftQnk=po z*iaW-pLEz}oFpY(C2yMzNAW%ueM~>jX zL|Wkbx>)et;~yl{)DhiDTAqe}r*TCwI99>R$kD<&99_{Se$v5}To8M3C2(fN7#g@#9fP@3C~w z1~+skdc(>6_R=4iDGp#}9pgE9Mu~Nj{Fw^><71J>k55_)h-%$-nl4^mTJJ^+V1(6? z%hxGpQG{>o5R2Ta=ga3lA2towCj*!~f zj1!-2NcX^dgV<#nKwu`0#j*}59f$nkjhWnYHdxj}jQ9nPYvy?qwttYm;J^M5YP3aO z^_7oNg-~;(G?DJccooB9T_|mmvtr4l?z7i7rQ#YtCm0I}uQBZ)$>P#-2u8wJE`NE) zE8djPZk_&G*gIX!uyA>}xN?^D_dCfNzZ7_y=E@$OTzUHSuz%cIuUfkF$hkKAeJ5S$ z!uzwHA!^l=(Zil=TMT)=WSZ&hgGKVQi|qHCQFN; z)fv8`WpGqqVyN_qvWX-@ynz{%cxVtQm3O#4x^Sco&y2XKcY!G0Tg*Bq9^B-OJhrIj z>1#*@ZREBXD6uG<-K4pt2K##Ww>>l_?KPqh; z4u>(LfZCn|wyd1nVH%QQ!iOYssb@ruZX{xY)>4jWVdLyvkNZTcRv*7}#|Py-I<#FsVtYj&z!6#mV86xQr>E z>QYR7M<)*a&5M4@`PyQ^IG02os%-fwhybKyIqx!T?fr3cDa z%gY-sdK@euS}4_IB%iks#k*V&$;q-+VPnz>@}|LhA zugJuK$=ozm;-|M?`c*bDCBlb0x0`EP&d1&WhY7+Uszh9~jIB~H z57*j-p3b!Nt8!w>!3cob*>6W1Sv7zTXz9p0xkJrBFU;4&n_4tUsQQ_4UZ3qsO0sLv zxoLlYTxnmjPxly*2`nb1nNB@i+&PH$Lj2d|9K0Q#p*w40Qo-Izs1(u7e#-jfn@Rfc z_vcK|xJeKL*ba2*$eNnjOi(n0T+j}5PnskZgC+O7{(Gi>rq=&6q$Nh7#Pm;KYfBgx z1O)i^AFX4|e|5wDtF-6#q>sfZjgrK*Fr{?RRw4}zW!RbG`v(TUo48$kOwsfY-4}~V z&yLTDZA+}(mvL74rh%%1j zVL*EAR2Hmb&FKg;yK65wOW=_f99t|PBK7=sJmm_+%SV?$CsX5wC7om5gs5!vD#`cK z=u)>Q*L)OsO|QM>!duT|lb`Wl3UN4EUBsKf$waO%?2DHaJNmBFL zw4vUX@3X&uq)gsbqbtV61K~Ll*hmvX93&~knz4WKFy5x0vzuIldi5J?M_t0ved?J3 z{Ki-rD~$SQp88ut(}!FE*q?RTu|=6~%P&_A`Ezdty=G=3DXKrA%8+#$sC#~*Z*(Ob zf5)90lFq>q4&=)Ru-no;k}zUPAEn)50K4TGSd&9lXK1!3IWVBn-D{4eyP81K{K-8A zaVVD739DVmI9`bE9UR-R-3?`4cB;1mkwo#Wc``**sHX~ z+7<;~6KO%sdkCb@ z6xi5V06po!^aV5ZPkua1L z?@GVCxLdin;?L{ci!>PPV)`=K_5NP5>RY(Yz~R} zc19b9uzhp#>cjz?8h->}nv>K)RuT>OxnB z*z1Oj%SSF5{Wuv8Y3PRd5ERiAs7wj-K&s>*10U)oLJ1EWpGLf`WRx-t_mM_a!qkLb z4&Jf1?c7zG7BS2qb4p1`@{EDNX>Cfs_kN(1vJa*ngOKILlv#ffhfLiSBU{e7g4Hc} zpwA(LU>$NnPK2Q$Nk)t9d}KF_c9zphPA+VC%N`pCUxKa@ob`MpB>d0Oi`P*#m_J4- zq%ucDZr-rq$RZaiTE#jksxEeM3t4Wa$|kUOij}@(KE_EEJ7{ysCbO+K+t^cc|l<{fZR0@+^&U?i{J@I~eb`fD-Zb zu56-zmx!Orh|=4>hA8o^cjrp}4pG80@d%scjrhy1)@vzh4Wwe0p~Nt8tkA80V(WV+ zO>pI?+tBnzzQN~RRMzQxKn{8e@+t>Sf8`{9TF+XGEuiiRQt+4`m;sz56W&P3Q?-l? zb8)SM9=MtF*`4g^ZZtHEHCGsEohY1NzCJo-Ix_+N zZjld@(64?q_6Z}LYoH7h>vA*MvMGbF{r#K@o*CycY`sSHqbch+v-a39MLDJsls{lt zE9)Uja?T9UoHwglWt5 zq+SV@ktx@6YwFtzhvpWACuhYT!kR49&LjFqTRQ$&N@@O4N(jO;zv)3mJv$vJ`EG}E zO`!Vilev+n6|D@MVWKq*S$9;*xg#TXTAnC>-t;hc7N&$?o;Np8qoi)ge)!9hA_g@D z*~gslZ9n-0Dz&RDG!h3i2_i+HQ?bfA9PxF~@VE^5*uQKwH5or%O(=b@A_rLaXXg8q$?z35>$&`%u|?VqAIcsdmJv#W&MRyK2*fQ|#04 zmq<}?9H)$$1f?WZ&&;mq81edkEbW{!Mrhc_uPCFrMLa4*ty|u!x2P-E1*Y9@z$J zR{=%3A{%-!Eg@>Lo!*X}!YsJc#SE<*QYb)GJP9ENRl02w?DY;~aGW9)m{@Ws($vf{ zyP-?wh1)D7n3Q3yD0ki;QR_>e8hCW9s)_hNb$iQz7 zf#XR58!?!xI_#3HcGonh=s-e0l@JJ+_if~&jBsh{0t=+3k7n? z3?YNyW(X~>h~NoiQOJ*0|CS{uqWXOI!9G~JQUAH=;kT{#_oV-SX1*^=_eBr^AjygWDcgU2i~k4L zF<=^dRVhFfI+SWu6V}J>Aj9z~*t;yhn#M>#BeShuO~;qO&eFx>Gcm+63m{T}{Vh@` ztlAxK|0?89|5i07hC*IC#6~MHer)rhe-P=ia|Tb9%>q!esctSWb0Ud}*-}QrsEy)! zs?sn-0!lW5EDbi5d*WA-LZcGu`X(C5f*5vH6}S0hlmmtB3CtgDQdzBK#nQasRFUg; zD=6xX5PeZ_4)KIhi6wWV?aEm-;B$TvR3SydVUA#3PU%2fh1uVpF)F|_Hrb;sWu@3& z>yJ#C7m{__#`hJD)+@h+`&4@v0?_o+9~;-{^KSeENV4KfOK?tiS@sdi53Uar&%M!~ z@{=_?GjtohRYa{z7OKIR(&I;Q+BV;@Ao=7c^>Vji5|3Ab3H9CercVwp@_6MN=A4dy zWAj#(d0#I6q256lB1Vun5$`Bf1#kZu%!I5w7)ElMn7G1n_%hnw%F%3wSn*W?@v?CIJDnY>G%3jy$nHLrZ4`A;rfuC!i$w{PPeuYPKKy70UIHT#rg z=`X<(!zA>aTjrIs9$R%wTKzZ`+j6U^>z7ZLYq^)d^!Vt7tUi4zh_vQ#RYXRIsx;R` z3L`-!S#p$ZVVU5#is~#hY+0RwQT^l2CiJ#r$k#49K;ns1r9efUL{O6a$Y`*HLBJrqWgzXF5C88T#tl!0|;ncUr8+G zkc1!Qcd9m&jG#reLDy5n+wxbm5n4qodg92+WYd7A-JWAnqUjt4*&ZXP;=`;bhWKjQ zy1iRh1ZjkC*QqdwxT*i^v8V|8^8@vph(_V#DW)Q5(hWy8u7E{yk!E#jQeK0%^+6F< z1osl?BD)U|kInKyR@F-4c3cJ!C>QjMuV*tEaTQ7R9E>PQ*>P9Ht86=6RY6-6n16Kv zml2pO%cgJ)80?y(Ae3GhFCo5-nD(UR$s}GsQm-gSp`Etv;>K(X$LqZ8w40QJHlR>IiYZG>M_q%^{r2!M)Y&m2r8$)RvBRELCALsnqC zR#M=+Ng*MVLGwL{4Q*%W3}CJtI04m(Ti1*x&}%723@nQj3K}QN;$}>?R};a%DFjEi z!f{?@$C3I_SVF=jL%B&U0)JD84UDp`vWrN47%m}|?2{mosGC4CFBBe4Kq-|L3yP(} zU?F8hqH*Or^J`f2{mJm=l4h2iR5J|QA#~p*6|`4f>YI;x2-_4Zb3Us)sk1q>W$f$t z1Zuu+eUwupNe$vyxg1)A9?nSQn`zqM9PU9M^_XM?agQH~o5!{6fl`f!B?E%ZBOsOx z4O`yY@F`x|OAs1YnV2`mLV{x8z#Z|Ctpi9;7O4GRt1H7$4& ze^`%ymlDz>yvh@x@Tn4=O>52BIP>oIh_EgGavtk$zdDZ@)G-_vC;;a%&j<@^S~CVp zl{tkVOEA&?kBxDFG?MGhkPx<#kHoWWmB7YbW(F#cT53XtKE67S=Z>fBILK0wl1Sx> zsNpEK7|x(WfyyJd@jpo;f>+Y$fD2(GE06LJIfvZ4X(g^AN%uEtv|ETRtY@F{ep_^VXtkn~=&IZRXnaWrfAfqmEwi{rI zI*~z}EGOjx9>Nz1VmAIC^4=;ck1l=l#@*fBJrF!daCZm~65QS0-Q5Xp!QCaeTX1)G zcbF&d+x_pJ`DXgO*LT9IMb+Na3HPpBuHVI<;n7uMm)lXhQZDU-@}0d@T^3j>lI(Id z%0N5l7ABA#M5aCe_-oXy3Lm~!cm6?L@dwtJf~k8fCdJQDi6q}VU6J^<8F*Rg=yf6< z$4p2!;32Zw9mUroC&w0fIH68C`Lx4U8t|*r17?wp;s-)hkkx&St_P?uE)doIs9t@r z=t&?Ge@hyZyXc2vd#XkvWzDs4*CA#1vX^r4ztxUTthfIdkbFl_!jlbSRcQUX&HeSFZ;~3OHcj{xwQ)3)5?^XIVT<99ACRrRlv)= zO3TGdUS)*phfA~ecWgWgn?D$>nA$v z{&Y$mWi)=2mKZnGlA-84G}Tgz9_rBg={h*nWB`m8rqp6%Ac{z6Z1^cnPvBWHid5cN zyB?kj#Z>(rk8Y}M0A44(cr)M z!;xAK@hmDP3MRgc?+2r-Fobr(iBqhcz|ciX%y<8_gn7I8?_U=`VHAF-7)7bFpeu+BkH zfn)Q`5$dt;-_IH{QO%k{A7PmaU!I~6rmipKhbWyD?B7)G&!myRzWRn`-Si4Y)`!Ol zj@HGfBJCH>CyVe|{#{X@fS!=S1B1vM`@z3V)8WLZ%QcP zw~>gSIew;LO6rAbcjTy>=h%-*5Gc7_E70_2mKe)XQ0B!GPBDw-NsJDCamtdx z0KTTXAT{uOieK*$OiDE=FxvG!{*p$MsF#V@5hly}YMA@&lR_a^zr?HvS=u&|(bi+sU3NsZD0Gx_zc7d#Llqp}= z_`e-0|24S;vL2&8HZYe6{ZF~X-vZ%;f9Yb#HWIimStW?ZA#nR7OJb+kjAb{fPa7>EnA6V@uX%pV> zyNAf<{NSNAnwPp?f(tiXu9!8(I^@6K>01xG{{&jou9pM7P-SPf&;)W#KgCRNLqhX5 zqe7%7al1#>4ayTIUtr}yA*w=Z*V$dCc)zUYvLIb z1;(S%5bSrhK2Ge@URldY9iB`5H)n09J)OXBgc#)%yn4BX+3nSsD$%{u5Xd`*fzKJh zo&oqy#z>F$;vLm!_zWzt}++zoQz(qofsIEuHD{Te+l}AY}Me=8iK9e z(Dt5w4y0D{sA|el>x!>G~n_ zjrhT)c;`Jm$4^L1h&-q~a00>{>0*pu-Q&R|;xR*&sH_q2!uxsif_!QyrxM%;qISYq ziVH!fR1nex)A5jxD^dZw^E(q8aIL%TP!2z5Bn!@Rt#3B~5`hD&)h0BSWl{aGGfr?I z|0@`v>A51X*LD+*D^vBC-eI~YQ*u6!h}3-bpz;ujQ5@YKu{75g3_Gqe(~!l&IIs}L zFpA3}JZ616HAO7^RjfFF zI-U};fJ9L+$O!zXW$YT@Wm<(YxX-kSe#SbrwJMk*Abr}aoM6n#?fu(V(Em>x3{)>Z zNM*pR!uCI975`9l|I2raVFR6-)DP&=uu}OK5YOjNZ3^hrP&*Fxr^Ubvt6(P#9N;>= z;xwTO*<1U{aTsJluA;d~1M_K{QMu5x3G)5jif@>OHMx<}N@Wz@a~Eo(V!ab^p5)EJ zegFg-u>*ldXZAt}Wi16%3WPRW1xgx9@B(+qsd5e)&(gJ|b~qEE1wh~g=|U5WiYn{? zF~*AI`Z7_Tn=s=cXT#x`M8YXnX2G-Df^2F$Aqhtw>ir=wtwj3cr$Qlb3QSlcNVePP7jSL31-7Eg3JWtHN)_>r&We7W-0`?!8!5}E zN!yRmLN0bkftUfup7}>E1iT`>;wS%%JtN3G5WXo%c^lPlW&ik!U+oP8JWtkX?oO46 zzFN9g+Doc?C<~aWT!)|I!C!la|DG2FqIrnq^11qVwy+yMe)Tst+QPN1v$(l=ZU*}W zG<01gf#Wq7~na^+xgWXi~8N8rjr_6@U32lU}0mL2QFa zZj(sQ7$%Q@9koKC*&;;|r^MFI!u3M-+A?egw`)!a`luknxF?6%VLPzz`Ix2h_VxMK zpkjIIzu7U6-3ilGBdUz#R_XmUphaRobAKisE zj>V$_ceDb4OtpdN=I6c)kc@!fBd&3x#?`_|h%A?{tBM_BX@Lq|fCW}s{BBiGKE_dT zLxk1}lA%EPsq7BG)zb-_YLgH;{hc!c61ZLO3Dufz9 zcQJ#teS6xMEHjT0?$H9`{_U84M1x3H80b8k3pl|s=@p)e`^-8S z2&K>94f+PT(}mbk9^VkcCj<8no2abQND9=^YT2{s^AV^~jY+A zlj0Ob4lB&E!|6o%a5?0ApZb?lQ#9v#RB^e#uyNfbb0sjVE`LD?s=q%GG_<$Kh8L)i(|034?Us}k*+p)HxF!av<^5N0d z8w4f{e+PIHy8tZ6n4QS3CzCH(`~-g!g`E5(1qMPFWK!~gQSKl{)Fu*06k_^0%g%fm zruoY9@~G!NWo)pJ$qNyu7tECdF)V3=Q zEuHx)iak(X_AN>G6;StMyTO7aSo&D7OFN?CpSl+36`~n)_|U@Go*!TsDn=f`_^_*aerszzyw(o--ToAYAv4wo;F9l>(8=9!u z`ysBw;%Dh~YEf;30oxBd_Y2^_8Qq6kZiKbgrjJWYyyxAyv7%_E?D|=#w7J?}5&dLd z6g!~N#xsXNBOX)eKU5*rP43|X9e(6cpt}K3IloxO?LPB2^R)9TWxY2-#YKiYP|VWS z<-54}$K7B9=x(rdL(SCv7KhRdgr0sD5GcFSMYMBoiVr*50CnUBc!@aDU#*(k^gE0rzSgIQ2Pdf?73 z*_M>`yz0*i`Ao-YiPUwfRK#A?;GTc`Unozz_(Qh_wwa$m!!NSWL?C{0)O#U{C?+8P zO}2jU{JQGqEGKm3CCrjOH+ir|m@)q7%Jah|5&}oJ9=N%Z$&aD?M9bHg>n4(s8pv`RQtZiHjlu8K~f< z;UIEMFpHa@N~lC6=-dz#WHZJfR;a&*Awk=ap)z|ItY}Hcml$r{u56P)04hBYfJ&0D z%p&Su>Cc28D%GIdV4ybNKau*$SrmsFdl+X$;50F-1P?OLFO-6;%p~E6L%5yZpQ}Zp zj|*fSwFR!|x1dUV9AJrR{fBTE z(yPs0lCh1hZ03=|t@vZVI3@rJ|5HRfC+-F9C-Po7W7ef%+&Y=^DKl>kkdfL*w#EG1 z^kyO~k3`^WSC~0ar|%a-=6uEhoGOkRE&lN`XaN+7JEdo1`PMS*m`nJ2l~BoJG%+Ti zDrn5~Y_EvdHTb-6d0?lCl|r5}tT*E&1Q)T=FDG}%qmgnOK*75b8~O9e0^k?TMoO!$cR;< zRHU^>!lxJzkN2(BFhsbujc&lY1Lh?ola0bm4U^A~`$~qGR&g6sM8v)i`k24}7k0d_ z+;hkFfoTO1!GGv@|6g_ae|5a+{vDG_uw?A_ca$gMF6UwfV)V_rIIQTGb7#&wrKpUojNPn4z``YaOVeO{kZeu>c048Jrr=_{FuV-pH z4xDf`2LSC6{xmDfT>iqOGXJw#fp`wnLe#6E+E1%V?;cxT^N(f)yUn;@f+K<)T8BVA zdZ{6NC?oc279R$=lsyjBh9^RcD+y_VDWHyFS+`v$a}iP5R)4Qm{R~*sDfbux1{L< zlHno!RmYEUSK3y3n8qD?*VpaF!Ttfc;vmC033Q-vdccOnH&g-%IesD_B>^mokC(Fu zBoEpkiQxG@uoCNhVnOKCVum8M_=q7xKyZ%>W;HED@RT%yB(2yky=6SgV9Xt=FAH?g zlP}i}<#0bpkbq?PbEwI*56p1zOk_MhBWH?J(zfT`#WwI$t#y1(;%*U9eE_I^+GQL=h3eRlMIe80G2&0=QuTlSik zbz03Xj;&H2$z=u7TQ(xM1~0_tPVZM9cDy~J|3`~Y1Z%jQ1k~cs$zxw-C?Tn$6Ukg# zAU=9QT_c#|U6RK(@+hX|(&}>+=Hxo)HVYPYcp<>J!8z#;GUGWlLiEm$@+(|mrrp- z`mY4wawvix(2DZxbZVE30h&PEz-TplJB=iH*Hb&XU z4CP5^Wl5~;CK2d^epiOxCXy8(u784uq(?NFL6?xKqbT0Y`EyGf6}V8U7xx64E@gd7 z>aSZX-J+c37*b{0s3+WF=DmPZa;SB#3S7#5v*fc)c_di$ z;^95jJXT7kqR0~*IaRwbHdh=bhWE}_n^qX>|xR+na zWNw@m245*v{f>1{cKSXz|7Q$NrV}*%9JJtMdsy_7??ofD%X{Xpu2?mz+Ij&-7yxID19Q8&jWdTNcMsnQz;&uHNu+c~E+e$GJ{r-(u-{inO&x?#5Pk{NyzJ$OV~nG$Sw6S0@fUU|#( z&kdJF5FuZBLwS*V3A1|wJ<^1V&2lZSyd!W{wYYY;gKVg93auivIrPe&IXW=k{{^l1 zugOSWjzS@vfu}<;&^PD*IS=)>(q4Hb8raJAs+#qwc8&Se=uo#^?pzn%$~;%PVB&8V z2}T8JZ!za{A*g>L71ube!C|n&Z8Gso&)G$Vb=kon$XZ%t8$z_*s1@z3RRpNChepQ$ zh_8f8tzD!2Xcl$3i6J(I28sr^Rz-hJEu*ndSiwg!S~TZz%xkXqWNQF363=w@M$KL` zOhKvb&yr&5iqm;)|Ad_WWes{VLGf2cV%0bAY#F{LR9v!j+6Z1Wheh+pg#oUBMycFY zqv?;~T4xMJF#``?v$AV#rA%s9X#oV=^6_&2ugJ;ts+H_*+M;rkKh~gl@dmvQJvN*0 zsz4V8!$pTeX2T`kVKKfm9VX>d5!F0_;XOP-3U3Lhd=H#fH{y@HCx*w}r7@G}N-Pa? z^t8KDkyNk8vFWauTK4GD9DdcoCLZKd#Rb`qrkOU@EO!pip8yQU5Om~V-YCRlBX~ufl0}w zzsb?3zTPxm!oed$iC}X1i9evzpLi4x5{oCkfv#WoXHs{EKWwWjK%uYv$#*#6_pm|w zkYeLG>9(e}|E*LD9De$P%ns7&zXWH9Gdw_+^j%J_UVy39J?mf2m1{dY6JPQ(JsxUH zb;9-}EpecT*Yh~dwrTQkY0;S&d}z|?fBC6mH2u-uet&zUkko(kgMZe@?(OixMxb;3 zdna-MgLm1nJ)h^x%-ZwGSyJA-j-z%~%(v{_VH578yGn+`jI7H8z}(5s@r|dJHt|xdkgY#%#jd=~C=spFokM!&{uZT{(KUtk%Du}{Mw;kHI zio`Bi&jd-xCUv73=}EVSYmO14mCdWZYW*y+QmND?3#HpA7`LiT&1XP&uuEcpM`39S zbFYyV^=lD9N!y`EAvetECooEjjxFKE^N}!&#<251aA=ejp=C*tV^>c8T+5bNi1TW! zL>X{8K9ACM8l|O=eq{qmNu5)NQQvhNtt%Pkw1S4I#c>5l6f0ieL zH``b#mFnFJKl-cB7np$&nV{V6G()zi;_Fw}m(QnDW05TVR@O+LiQjF|%|kx-I#m#P z$cGG(*@F#->=S7hFw`T_gBxO!P{*naAT~+>N<7q{hUf(4NLudg92gXfyzrjVLm9~a z+{S+(Gm0TpPuZIIOcF5!OOa&P#;C+`UR}>q!z!o-ZVx7D)PBsQgr%kc+`=5V#m`92 zInj|Gs^Jk30OFqoS3NBffJJZsE{U`coS4@(MEr=Wrd9z1gI$3PQLIVgNwq|clOR@p zrl1laOR>@}k-Rqaf4>$=8)h2``E38MJJz=U`8vNA^W)p;zbP92Yoav>V>^ihFj^P> zr)d5EF>)r`Kp!OiW8}Ohs`yZ(arZxrt-rV^RC@HJR@46wA#4jo0G*ttv+(I1HA&E@ zX|@?>l1w=vpYIz8#uW?+t?22TM&TW|vDTP3x-<#umzIMaut9ShAk8yR?Eew2fh_{L zil{uK_jJU@A6xZsWR!O46w2i#rqgM$8Jak)m5@91*UHh>HdfiG949!PLr0tPywz52no!mzMeYmp3eyZ zn0>iml&+;H3B+FE|NZ;@j|4%~hjIiO!;%_B%~u6Y^9@)Vav^Tjv^s2jdx-|WW^s@u z#_P)MHTAUl!iKvTJ$Z0r#PvNI2)|mXI`;aO(Te9opd$l{Ob1hZqk-W{@`1YWwO=djlM&r@qoV0; zogVTkmMmur`-STpk~-@x6g)l>Wy&gy{8yj-*h~As=4pWG`~t1X$7^E@TuEL~p&VZ( zDf;gGi6^O&GG?_1U@_jxF#@>SeC6~9 z&+n%Win>hbBKt%bJFTJIBlZG9DlP=uq$31~cxs==m-x|*era(ec_;v*HT<7wJ;5_) zeuctvpdx&qM)NsE)~Mx^D8M=#cm`-CS8hRbuMLwD`R~t`9I^pJd3N~9w^X)KvUC0P zwjRglH4Z}X_uJhg2R&1k?6IrUIHb|`_9#~mUM4v=oTe6!yr)Z_36C*80U00x0YL|*&_GX0M^hs!qrZRtRpdVf zj7Q*eVsv3Y3m`bSyt41aP_A!IS|+Sf82(5kXlOiDRAXa}Z^uUmqvXC*qA4g$5whV+ z{4EHM*l`;JOHqGBJWV~mNM5l=kzpyN;fxp|{@zhs{E+4Ce&cxcyCc1Y3>qQ*s@lO*d{ zJw%1)x!ksI7pkLJ>r*<~buEOYF+mGCDn8Z0#0agMqVQE;Y5BE!Lw*<+o184ihTs-!HVPR6;X5qZwa z58?}^L?O97+>anX1ykD`LBqY-w?a7sgJu(qMy1=VLW?M+`dG#9_g+LE-pImQkff~} zrjD<4@2cN7EYtW(pEJiv!koqD@qT%96Vk=!b9?yIt5e(3KqqYtO{uJWJ{P0&@%Dzj zuG95?d3?orG)sNe)7SO-G@8=&am902y}gRb-05|FeUyN`;dOT)A49mjLO_^$Ng7sj zS-E9!K^39rhxBp!9p2Y2ID{Rf7b5LGj(BPN!{03tIBaoz&WlkBUmTWY;)nXYsgOuT<6HtHu{~p! zct!Yx2^4BStv10n_PiOBHAC*2rzcW}J{wIC*0e{abr54a`d3F7Eq`fTY#0w?1Pl2H~dbmoo zsy4B)^LNFf2}9i|c)}A|lhWqe%T#gy5sf6f$qu$hyc;n?y8wB}65rM(c@hN!FiCO8 zI``DJrT4a}8`RZV=R50!!1Xl8CAn|9A4gHN@c*J03LrmUgU0AU#IFwaftbO<-85_Umu-Bx z!@QfS!}qzzkC#&8neY5nMiUlkHyQ(X_jg~-)7m}#MyM{X53}UkYxdYk6VFE>``d(E zydc`ABcWMJRuo&QTg*Wx$R5+#QyEqh$r*R-s0654mt&?7G=z=Ter1Ns+^M*-QRNsE zggDV-W=~bT$lbWcM9s*Vw3N4||AdE(e{!YOiV{wdDmv8QyI8N7J@GzNaRH=2(Jam2 z=*bx4D>~sQ>L3YWd^ZXFzLcgu?WjJjaGa8>A!fG+$6|$v>AH8nDcZ3Y@^$%ZurWd6 zfdOW5J+L5O2{(}@=AOXzGYwQhpP7v$#!-2x)y~b_$*i z(go>>Gwe_td52tCyUERh*KicGlFds&BB;H#wrVFm+K9$t5aO5XJddtke}svv~m*T;=8J(78v?51~h$PIFb7C z_&l=OK4%Q=;`hbf)`zQD=}*`IFu7V;&f;6x0n}FtY>_Gb?DLajWb*lXH0Z2 zfC0{WGY}u`bbnhXW_}1Ih^rMY2Q7hB$%!CUL~d6Yp;F6(7)$q5})0pd!_Q!f7P z2Sxux-O0*Ti0uUwOC2KlhTJB{vg8%N{h4f}U?+8y5g^4g142K1Yr>`S>-Ng@sGfkm zkdF=ZZkQ_tx1v_wCa+7j^H-cDd7^4}6{<#Z0!%(U_(2+KA#r?1&utMs0_y~1-*0eD zn%m8?&a%Uamc@M#sUdnwpCyU9;@@x(`##5!Jmjtw> zki254b3x}XO=8tOwq4HM>x!Tj_K(4Ku%P9w&1ls#q_hzAD~#AN&X&+)1*+a!U{8BmAYx z(U<3$2L~`lqC#Pfp>9iVxDZp!2N4F6r*T|$c)|4Qj=e-}RIZJT5<;{@g59R-v^G!m zPMTi4fId2G{>)PNNY9YZ+Y#J>WNrXpzm}*qsxwEBqVk|S8)NYw;Jj4TGI*?vZCEc%}Spt|}o&{8`{AOiCHRt_R>xdHFU>OAC zWF9ny;3AmDH&-%j@oK=ZqN29vQCf}1KBJ<#e-dma*!m^PX_OkroON78)6!m*qJ)9( zTTO*|Z4!P>5}wlpif2}jDLC~{vJa@PY$QhGtTx$SE8>O^ksFfD;v2+Nu$dfKb%-@C zdb%E|oChdNkU36TlP~_o6+VrS)|j@$O+vPpi~>*fX%V*8y^*|Kfu?cVMUTJne{Dd1 zhJ17;>0ZC+n28?|JDPf#R7`D_6OxabeQZUc9|BPGDycTB%!Vha~CVA&##`(g3@~$SE;ZB*y-r;n%II`XumKuZFBIR z)_!u7tsei6y{?K8YQ5H&2l`?GruC><3l;4CbFmL{rIU&Jtd0tk5h2XXv)+~zs&)YkWz0%X z;?<}m2##9#l|WdIF8LFM!=?c)HY;M~i}2Ghet|w-Ks+{o<0qP>EdzoBw$?H^7Bd`L z_K2wtSDy^+Bn)#6D~ zQr%LP&KCG8!ZFg8Eu&zWT4LaWIHD_7d7>wD&JHBEbVt%|{So>P1Fs!Q=_+xeFGMZv zywOY@o;V&>E6z zJjx;oonw=u64&PGubmpQ!qSP*iATE_6CIgeIu{yrHjdC8ohN#m4Uh#!;tHlJw3Y6v z8mcOkuu*u>E+WDLlC(qa@SMA06TNT(E$a$w2%g4vK2Ts^@Nhv$MhL?;{dFbc`y zwz*pZ?n&tHn_DVavI@8Q@>1<3**@8<>|Gv3GZ&u2Vdvp}IT?RxeR)7jqt*tkcW* zxw*ZxkI91lgw3c|*a0e6VV0_~9i}!a+NhyB5i`lkaaqq0H+Q)@DJV`BDUzu&qIQ-? z24K3H8E2F)3@tV&16W<}n}<|ZOIXkwXk}#v7MjK4DR3T|>$*rGKoKG*72rbUyRobqROkF?#cuS-%E*e2zrQc0Nn2 zz;sHjeaNT%nU-|7V1gl>MpqA82&(L;IcqY4cJwR*2wvY6R9)Gl#aI5`o3pnsdUl7~ zH`f@ToZ5KzRjYKFKS0Z6vVP{PrPXzTqsp=->D+c);vlUAxpz#i0a|B}un0+jtGe9y zT>v`~?)7gRS(R`2Y0LI}zp2Xh+!5c<4czYXf6qS$7pW}=!Osnk>@wZw+_8`NJ78IM zB^o%?*e3*Q;@$Y2(OvATr(Cd$5&=rfBdJ=gA`!Ib#FC357oH8DasV1ZE>^lXWel`Z z%VH5@7A~+?+7dsmSIH)6O7mk?ex2cx7I;z?)b_hw{oTO+KR*!Ov=n7p{Xsy`_P{_e z{_%les%LLxsO)HOW^MAc{_3?mxs zd~iBWIc;Cj%Fe~`1tWxY&H^%Ts1DBChxvz}Sj#Ro0YO6O>2V!95jBe?*<Y!+p4l407RAhTVw#y4L-NfTI!GY zw+o+#Vun%hTWzBazLwFOJI={$le#ujTw{-69*wP0*?6X20-vI$$vP*zpqo>s@aw(p zCsUt~y&EGO;C6L}bt9iH-rvin6LjmsKRUxEW^M8ppa4?Ay16RUgUTxeC7zuI!i_ zdDgs2qRO;)EJmzhFAo{^1n}Mo>tt?u?5(k1z5qOYJ=7oKOAJv9-1nCA!AEaYn5jY7 z35{2KbR0ORV3F-IzhTKi=6j6#^P6&22VOYWH#f6*5(a{$PuT*kTYjWCm#pe@h#tdSIn*n)CfLhk* z5gwA;HPG=RDs3;_VaB+c=VP30IDG*M(XV*9uZQu-!*Ax-pCtDa>UQgBejX#XLp{?1 znxTcjsU51;i(v^Xe$(uzx?05jd`>VhHMb*5E5$b3KTarf$jV~ukuhAZdEXbYK$Rcl zj;!I($Ybq&Mwnn^IL9dFKH{tfae&EoO}^sBV#4~`7;Ri|ym`AVAlag#b8(@6NOX73 zxy2y=o1qzAK)f5{9?a`U98cc>jv3Cjq;q4ao=|v1t^jxSJLnJ~l4zNxVUjSQ9d>4t zWz`!FQnL)_=lZ~>)ewgjx0250HjPJU?W_K^JB;L}pt3M#+xZ*wa7!JVO+zK3&__YM zePKuZ3KscvO9D?EC@%0JImCGULMmZs-(iq(?DmA#Ft|qlXTUU9A@@|c z+dY+RvaS{Z?JA$FZpSa=uQL&2^B_~AvOyA=;upCu8ZL=`u&YpPI52_!16Capx=1x= zv0`;J?~!ZOk;X1tbOY}s@O0YUjiBzdmdxrXQ+QhvdW0EgFl6xe*~_+SUJ9i5RGHre z%FjwmK`+efGR0`SOE)1pE_%!mtYPdCFf3Uc+=f$ImITRkV}9vI*0oVi1%Bm@!9o(! z5jMvW7pIM(Gc7f;uI{VL5uJnxiDQjRk5qyy&*Xv?p(Kuc=bUENjDOrF4lkUNfwq&pkf*+N}3x^1pie6!VI^l)>;$3VnRpgnv@GYu~Y=+2PpqQ=29B-yni| z2ZR;oB0gs_E^vex^zM_tG}S)ZNN#`y&c~E zRgHn*QuFa=pZsj}ngrb>mfLIMS(U`2lkUmX9<0$4`H5d8KUo)&3MNZ*(i|ei=nVcs zm6?^rqockR*JAr8A}`7pH9g+r0mqdNO&P)0tE8>d#V&#V>9^h2owoZ=NSu~9o&$qQ znp-yt^z^n+LJ@m2vcz5rRYkUX&;a{{n+vY79G73$l+3)51~fbhm6y;bbrhA7+dmd$ z4bB%{F`X-mjPQSf*^c^mMt#eM;Jp#y)h-`F)U1g$O@CYI{t~B zQ`^`$ZKY5%4Vl`>+RZE;)@|aq-CkoS*{@L?(T{v60whDZJtUyBy^qPxA>T1gDbEz& z%l#>^{mI3B;0kO$Lth1;8Yng*?P~^SkK{zve9?$_Hm%0f$CB!L9x_k&bHKpU^cCEy z_K0OqViP&YEeCs%6~n_H4!9v6ND=6y&ke5C3J*`s+w3NIF@x)57x4?9!)+5y_!^Rn zZrUV7g*Qz1+42FZRNWoQ<{3BF(`P(0$}^m|!a?bSA5Nb`k00{-DxbQ4U}{ z^glc>ZB*O`ha4`-aMhc7=#{6E6c|jL)_v(1a?L5h9S2G(sSHFTLMeKq!*3vcdOs>F zCnmEY@hSqoy+FTIWi?Viq4EbekO~jG$&2{TH3DXSqr%#%*EgqOYcFEPhE1~z1^*7t zwOM4}7vCle!ed}U;sOJC6&nbR=2@e_Sfp~rNZw#cZyVh^_w4j=c^J2UiaK(6#TSyd z5@hO5X^OjIV`rQv>YV$CG~UfLbK#H6do-kiBd*-Y#vvG$%lmP#HKvXbj*e?#XC7%g zf^`bZu&7J@@*>NGShyUUWMTPsBfUe-gW!K-3JK){!-NX{(XzICdfM{{OZ5ilkIPLJ z`V@a~=dWE1)ieAYRfAZW;B*;GiJ;EGNn@AyW^!YQTcsOsA+F(Z_|eQNxA?Ib=wM$u z?q5cu1$hwkvlG245>VPGZLXPm2L)C)9^?zsf|S$x%L(OljN_VBYk>gaOs}dyuj-gT zv~n6hDk*wCYuC}+z}I`^JW~IXRwI<4uflo=ofi4+tL`~6h8fTyR1QgmiaEXdr8gF3 z!33;gR52}GTZNX|cIv%1$s+4}gn|sUYYf7v+yNCi=G&WEp=pJd66a+i{`S#wA`bQL zXQ6Y*-IAC~h4Eo8%uSm4_1gI_iSiG!jYuX#bphX)BT!siuf24I*f{oN5eW)Uxkcp> z@v`R^{7Xt@UH54l%rDeh@B6;nhUe@zLs>T)rj-Cw}WiwzeMl&h?p3&g1!-iqG~p*us%;jTO0g(P5AshYm7fGdLOUOlswwwZC$r% z`%4QvVst5d{oY~AR9@#vG7@D@Aw?1L9b8jj~8zSrr zIhoek04&}MxxjYueB@}yfZH>2ZIVmqFsAEVMskV4ny)$fzC?k~B#Kh}x{%@QlWJ!- z*9Dn-fl0W(?a5MK_sM~jtOjZOjBri#x^|)XSVl_yY6BZ#cgGS6QhlZ%iuzNypEaZv zl%lc)iArBF|jml{Y=!;1mQoaYxqNF=?3l!G^PnGghUz_(a4@O*zRUx?>v$6ynQ-4*(U0#=!YW9 zJ_+QD`1j!1HCjT%a#P~Mio$2k*{+21L%~Ne{#M4&*=|AmEZug}N!ftZ0f8oT@yMv>hYorE*dd{;KVYj;3XgL#= za#P(8H6}AH%AS!dJIse>2n1X~Z)A3aVM>y0&bKP2SOiq$mx2&-LaVy4@C%rmh~_#- zPKsicJ3N&a@)RC=Yrg_diX1XHqyT71E4v61b2T>KD0xtWMn?TSSTQ{9*G`S6c@_G$ z$9vffn~lVkrv9dZBBf-+9$Tak>K9m=mBLHw(msU%P!oSiL63QJx>=5jm&=?AX4(Po za>fWXJY}VLURT+vWRDuariE|j#74v0n&!y8ZisbZ;;<|Rw<4^nd^V)8f`Mk4=P=@G@P*8_t*s%Z@|KV|xPti~9A%gd;)^Rv{#K{^a>(r!OH5Cti_%$~b} zPo}LD-;9`#UmP778(=ob#KgRN?#Em2tM>xM)UZNU$W4nRBpVD%6MsZ)QaXL_=3HU# z;2~XeL%p-5wVz|$QesEb&(9M`W&VKmqnH~-6;nb?Jf3(kaqvGL>#1v)Os&m$C6L6Y_*0 zj*a`85}=;7#53NaOzQw9wWH9&UrOWWs2TAp1=0sI>;$T0PgalH8!}rO%t|q^UfcYfB#4>&6QUG9(Ld#fZ(>v* zS7uRIl`Yz4oM9NgkwBboc4=b}o`vZkFM?#CqZG7By<-Wf^_`DGp?s(&G zhK#yk_ahhXdXMN-@@rx1Y`$Tu39MC-!M;)%;N_0It@SQeZ`{)! z+Dg>Cveqe%)%}VB)d~#odKARQdO~7gteMi5>E>GHV?E$6Xo+de(mZ6E@T&K)obVEH zAhzLan$pgEaeZjue)u&0=6=!=biTb><${bfHmozV3k|I~$#jQZEWowMhk}Eoj1IC= zm&xUe(7ko;_scmogJd!5st?oMw%voInq;2}rqM*m?tcNG zKwrNA5rW%X0)WbtJz{#HyEr*Z?>9;$<1lDS@4L_@z47I1likNJXGTRUmcGY(FN4|g z5#qZ&fGo&f?jDSeO%SLvanfk-cxxzZW5^6W0!JUeG9h6Qcw6ng+8Pw=AePPbYIihx zEx>XN7y!#?wD)>@SZsrcumFzT(Xjvv!$7bcKLQr(ATlh+uXhg*_f5Jm45V-zZcP=- z5VF>B2%YEEfe8oZCn#R+9c&GUWe6FLR|mT<4o3nU1OXsK7vgVL`ZH*WRq+Gen$xE4rS zGlg}@(S!T~q-@Rig7+wf6I`ALJD1lVet62+Lj0Y7I>&GHBc~IEwY$*jf+IJiTaHu= z6Ic55^}~Dkj8QnGnhRsaC@WM=t7>4VLHN>SSYDR=Ho&#)D7}wy1CT3=wgwF;kqMVu zqm?Q*RIBMjXiy}g#PRans3gLam2QP8;!0mmP+t?}kx^q5v96d}6o|Gj5jHX8JfsIE z9zsg9DAR>|q^eum$i=6&Pk}DRx_ltTH@?}aE~iqLaIuCaAvr^Ihxcz!-d!8B{dIhP z(sw%U^L|0qXI&FsTpG9k@KbNx&_%+EmQSn{#_P&oT<|Ux%5GoaE%_VQMJujC z`PGfSMxgG~?p$7-JvBIOJU%mS^fB$hMGTab7uXA$jLO~8HAh~1Fk>={xwIRHp=nDk zsp=Jf#Wp!QGGKh4i#H_SCo$6L9G~=_RONTG+WuI8-^-h|bmNt!4DJu(LNAx9rM(Hc z1BYE%K#P8&Qdii%St*7r5{HG25w>RE6K*xr-7Q>)r9$JX#IKTZ?e-L~GB2~%a>A__ zTIuSvJc%k^FpueeJe3=g>pTg!k6gDp-DzWG>83V*=RX?16jw)aN1AF^NjFGKK+0ry zE!Fj1ZPZ@Iv9dd*^5^B$x)xRqWv~s?K3<`67vC|b0%@pHyg+5^5a|WcqGSX*UEW@f zugg31id}*^RiwggS=`e`{sA2aq^Zo~Y`q9kp$Gc2AZ^ONL9w`3gEvo$|flva0B(_hZGz5No`7SYk}m zcB#2@!#- z##~8)OH+mcZv2x>U_P2+*HYK8C;j40hX zUO`ZUY`nHyY-FWxUkj^aY#O~h#g-ASb{Eo`Al0-HHpE|S{7Pz7ldou?=EnI#%!rWo znNc$U7aFNjV(^w~ys4X_JAW{Ix#|NKdn{@Jw#Cg^`Z1p8#)SmclRt?!<*&k@QLKF# z%s5~5UK)bJu;#Ja4$ijWc@y4$%22)?l1~oIwmY1jfIvbOlUi<#CKi>07l>5n3|)hW zTH@UVzE9XFvS~k4ApB6Wl^zEmNymGXIHZ=hgMq3tibX+l3N8yr{prcuHlBRY?=G;F z7WLcIZ^INNC5k+JTh>M$#~MfkMI}>MJWff_POai=}IP!pBM3HHA(>aWcc z{TuZ9#qtv|^l{GgIb}(!3o zuuP?A(8UAQtT3_kK?YhVWd}m&Hd600)C)D1nYLtIu*$9_9ds=q$RE#6Qf>;#1pCpX@-F98U==CLV+6knGM4( zjkBreL1?jU#?~Me%!7^miR&nn_PpMuI7QP&&`J=itJwF2x=N`}N;OplQfbt}|5Vp> z*>SXjC0HtKbEUvFlq+LNe#mkYY5d4V%;&D!JncqCLdPtBZ&oEySt$#t`RMxGtV^WV3kxA#`J!R~QpKUF7ZF+#e^|ZJhT98RK@C5L z@q!;7Vy#1YlHj-E2XEm2;zQdkG5dx9KQ#&}SpaVc&n>`j?3m$@Aa{&Z@roRlwrp>9 z;b1egSMoOxY|{g4?2zHTsfLnBzUTp5dXE~nw{uR^%?ru#>v-A>0=OM*#(_vVy&F{`<;e`n6p*Z~D4!iq|tlW7aqWCD+aJ@PDr3rU$vb9XCEiXYc9x$5UJ+C@R%Z@uz+Z z!Gp}BS%_E`$|6(oVtP|W+r`i9;lavG{-^P<^;jq!cIv+&bjK}xAMGV?SeBLlg^D$} zm-w+x7*yp!nJ{vC&e(dU>JUVT*1No>lrx+%UWe;f>XT_Nhv|JWv18Z4nNcgx!{;H4 zr8GuOok3k5hDyX94_~lNkH_+<$dnGJ%|KocE?nZnnnE=+v-n)S1lrdXU};omlOrr% zr?ejD-{>I_uEvLjqnoE*N5+oO`?o-h@hI6A%VT%0tG#wXWxi1Xo}*G-fq}ho`FPo_BixNCZ$oFMu0xAO?MK`^SO{OY2kha&SOMTe)Z`9DT*{Njc{ zqt1>b+_$m@T16&*Jrm#ygn4@`kw=)$R~udL`(ir0d$vUCxof~BRfgKc2Qd(hI_ z+(gcXO_sMbJ##acrB}VQG;xrj%*U(AIEfdNAAUB9A70@OY>Iqx`X1nWLU&%J`(|Rp z_Do6&PSnm=OYZ@fn??&v>rqrTT(D$q&vXtU>opHGbnMJxE6xR>T|;BC$PW!kQ1oR6 zXOZy7MgA=p|FWTFxo=%U!6gDnM(}yXm(^%I(#VX0h&Awn$!+8XABv9*1K%x-Jv#6h zL?k0n{{DjN&Uk@)m?tki=y@9D_jEJtkWagpv^yS6*{LyRH+5g;$$?Q?zU0tq{R?@A}>cbCS0CTCaVZgL<1e2i)VpfVKtl3!kg7hL>?}j?e?Qk96V&Zh{GGiQh zMwVZ}gwr?;C97O~mF0Own}MpgYzdOOki0BL5f!#>ai<`LrbD{$SZl!~m_Vvi)Dlp3 z01=Q3BD)>nqF*@&sf2Y+8*@x)j?!i!)9k4swe+p#Ix-WI(XKV1>ZL5kg}dS`I!mA= zF)qz$6_@2mHKAS#&F<+-`Q0fW+xQkxvcF9+9duWN5!f5|F$SHP@kqTDFNZ^Or#sQO zTB}&=hKd-I%}fd;^vdYxS+vgaf23St7l!EM{Z>LMLB;HnF_%B ztPTT=N-RvB3@d7h`Vy1sg_X(ZNNf_QCP14`?9tv4s;^_(m0hHKPsWg@0Nar?Q-Evp zc|5~e4V9f9m&1V7!A-+1)v!p;jA1%g&3D9Rsty*J2dINW7xF>Lb(~VxUt!hY?KviG zyySd9T2j=pNP@e~5*OR=qHtkWMHsiKa!!Du)BnDnorBJ|>;*sE^V{qq1N*QuPW4AaWtH+Cw{O4XE?vaNm$z4t?{0KqlA^ z_aSspFm*uKjj=lz#Sd~)JO>2Ue%xw;^iwKr=6PYK2}+-{%QlLcWk6Y*vF%QaI#cY? zAru-lmZ7MS@9L zcTrlxx(^z2V$kl+Up>-M2d81-v!^v{yz z6m^Moyp2gv(q83_pjv9Oj1h=}J;5^r^>t2uL^3~=A0LQBXhWqFbA?DKNk@BRJyTS>sc3!vJ zbcb;)@1dv~TZ%J^LG%^hTEOWh*`&2_lfmYah_gt^e;#>e6K8tgTJZboWt3AGS#_r` zEqUDX#Ris^XfU^bDPiIi6wa{II(Mobt7NZN1rXB&N@3}39navQA zjbws1RC0gX5{jxRdwV?#q@{R}8CLNK1J&@C13fkxh#{WsB0B;Mt=NryAvb0yp{ zrP|Eh;TRhbQhEyKjH$SZJFkq}*hUt^J3MqpKYd7sV?1d z4O1fPJghNNtfXi$FJqbLz^Y4Uv{)@CzwSydbkw1XsORzMrC{yYfF5irLgtcPqnUX8PL|%dJn7hJWn;PpA=Y9Tz<=}ltQVPX!XsE zr&#p2$4CvEI$;wZExpbU#_c1rjIpPl(E)NptLwF@#fe_1g;u?rRV*ozZc+EPTsWs5 z*tKw44Kx?dq6ZEKW8YA^O#|$+b{>kM`N%hWhU>~-{~3Gfgcb-)wa?=0DnM;2V10n@ ztCyJ&!>3<&k4b7I9afWz1p=~@arD_LeyKt5Hd@{0ch3Seq~MIY+91A7gZN;AXY%;j zx>D1otgss%NWDB5;6@Y@g}GWWJr#!QN}RQ%3)VH7&JzR+No&qSWLME`qbeD!Of`e8 ziV#vbn^8KNgo;M=%DhWdsESO95>Yfn4m{#$1EIPs#{1I9Vu#rmRc*f}ru~*Q=gqk7 zTGA4h*@yL1LFf8aC<)6aq11QrtVnsT+IDCWXHBjj*5dY~)WX`zP&3;O-5Ec{^&p)n zx$_=>G;%6;PVfs1xRUWGBl+xUeHU4FV|&61U}+ryaFg!81kAz$wV{50ouHhBB;pYC zoQBgFj(xrg#_izSXh=C@v}PX!XJ>ch4{4B)vtX-@Zh^=oq8u5ug4rZ@KS)c$b-=2K zCqBwZEIQiXy~%@*c*G>g))D1*6jVf+)A;#aYTm>zd)=44kOT7f4R!5G6|6q zph-)q#+2gRMvxP(CO)9y0Zal-WoSJTE|lG*^yYd>vH@7QO4bh(>(hHWcN&!s@G9j^ zaK_DDZ))fc^qeJim~jWotmhFjg>xg(<8-t5gj9e2R-g3K?Q@|36}Lv74UJ@QBraBUcRH~Ak_)l>aKd!By7HDfg-6HK5 zf!mkfWGhVo(19VPHmHM*q%bz72;xOxZNm<8nh|Z(W2E}6!Fw*j!4)cShir+9DSus4 z3K=H{RlTxciNq{O3w{!=s6dcXa-Dw9HCfTSz(IZw+W{tuu2oPzUJ6GCu5tv4%9y3+ zT~*WR85jt+tf&M_^(5f z7akkO+NMU57ylw8`IsAG;$tZVr~p=7ph(x>nyu@ig&&lJW`$i#+65&WZdjb)HklF{ zBu2;sq2Gn$f-b^EJQjK%b7S*b0Uh-MbTl-e#+I@Ide{rl!=V8+7~Kl!i(Y`f7z|L^ ziPUhdnC0WWJWoP>e%9d}P8`23EpRpw_4G+jK_-YX+%@!36w%n{|wmYio)9?0>v^cdlVYP?s>g(jnLc2``s zCN(vSRM9cJcZs&$gtuKAgla?DoHLapr>t@bzhW|rxf)UB*l$|f?Rl=FB}(Xqblb!6 zDcHF%okLa6#{lq`RWx~%!v4U!?E(<^9K4}>1Vsa}wvFygep50JOL+G8_Q}@R-y0pV zC08pf7G$U-7R(k>1{1cL1Eg!*X?hGufCVre^Z@7$41IXqTtMk2j{xkTsQ%KZ3gIFX zbg&FrlTKRcHjjX-%x|pcf;qtA%0f1F;`Hv`tR$s-b1ayvSXp_Oqr$4tRqrV|*-Vwg zBmLKKsPgobtm~egOVMpNIc|1M!&!_qX0zG6phzxZmR-S)MZKs=2t+a3@}&gJx@%w3 zRcOy;cZ~LuIGd_D3@{oEgVA(k|FN(UZ}%IjUMq}Bfmn$O4UO`X3(-gR4yt3A7luo^ zwK|AgS8vQC7lO=d_(qS;@hf@cHF(v$bL3K@_z|T@=oQChfwHt5UNr%rOaoPJ=j7x{Fuda8G#7kt(XVTJanPI7oPQ2YrOo#2ne| zbyC!&CwMqj%q-?s?9)`2qEPV^Q8ax~dmhm>W6%P!x0Z@w=&76#qS7=B?ai<}MVo+h z@$x2-3HvwOnFFn4T7slST|cm8Mw6>NzUk8BCt05$R zQwUkyaL(ZdMCj0pkl}W#AtZlO2wB{9&fx|`=!JohsgJN0=yz1J!o%%5m4JOz3#!yY zui=|rI%jCAie57`yL8S_Qy=~4Q>mNs*wO)S(d~ufMev#`NnSiDVK(?P4jLG?Y=#?R zPCZ?rnvk_zK2~u?Ry!={9WiW<6K%CwPPKl(1^3jUM%j=$8384q*)O7ll%y%MhhQEf zgOci^%8miP_v8Xrg7P$ic2FcI`a-FmE%2J;e(@-B+hKbgxs4)s9ppY5j@%$L$o--pxh?RT7 zx$Uq$j@(9>$qsVA9FE)|G{}9_kK7h`O>)0{6uIrNJ&xSRhEdJhgjFLs9#A8Js@9X( z7HCakA3uuNq;yJ<^(XadNZMGN#R_-j zp)KdJYG0r18*CAz&<6UADp3BOYL%rcRLMnk@fE^>!ch3jbV#rBkIE3y43=Z0Z$ z>XEWK5cQa9e8TL#+MarCrL-UQ+%ODIJ<>e~qTbOys77(Am#X&hcDuH%WA>w-8-~HD zN2=sN)MKhqC~N-!UZJgpUR!7EN4^dq2B#nChC@j{rW+A(bc~FPtqIuH0(;874k!kv zAgOypow!h{9!b2mR@d{$wF9t?VwXV+I-#pTvI-}_=G4H1_U9kZ@dgQ^fD@`cH^KdF zBVNg$34%isjr{r$H4Dy@`;{(=WX8iOAXY{fQCnvo%&EDG%&NEN$a_V8wrbd>xK$Hy zl^!(`;(;rKGocH{^hAsbsR`A<+8SSlBUiU`BgyV;RbFmTENkPsPn8PV0~Ej??YqGR zq@{CeP}13-IAlo*Z>h_>euC%2XSc?`s450(=`y zy5Ox0%R!;F*{k-=#@EzEW>6Q{OS$3)r?Lq>WlEWw;>`&p{l>|SQAt6Ne$=do^vkIE z*CYL$NY+FK>>b*^mB84O-K#P_ghOpC%l!I8Wh@X zrJn?AOZxf2*^+*4nbKSO=_+{clbbRu$vDyP0u6e)w8n0^%eK-4<+^`0?MlBd)S+Jy zwj7UAiLX>*ayZqOX;~lL`?%U?&E-{x!cJB3YR;fx)tA=bzMvoNzsi$WuU@-BFT5bH zUhTamOL$Pw+k^Xp4yfq`)Z-3~kzuZz@q+?yjNU_c?1o*vgsR;SgDa4}wmGcA-s+xC z0QaRvA@ZE3NlPpZdZhfCBG0W$YmM8Bylx%OTjVLP;Dp>W(y=S2I9IMjm61dKy7q}s1a`%0 zj5>Y`&!O7^SPkDT3p6G+XJr>Ab{FO#nAlvIl9NPZVs%M&q2h2<4uVTBlU*ZY_gHpe z8Xv1WvsMnEx22u_eoVH4`$=Y@LmJuc&_m2CAiv0hK!8+$T$`g47|<^ZR)g7 zIaOTf@zzIQOUmIe??R`;jXnTItr@)cK=IJbHYQ@*ll=u2sy&6jvFLD?cj~#(<1NpF9bC%p@=F8}%fc=dNVX}p|n_AbOao$mu+wuL{cGFWUrcpsCcbS8a)?bY!7 zJNMRh28o64wc`v%1x|=qkS(U!B%I+L99uJ0i)v>v z#f|FcLTw*9`zIOREY2(iA6Pk{7yPndOw}2kbso4ekH(c0%W95P7XpQ(!p$P*w~^__ zs&Ol>4T@1?KnBH93Bd{q+Sfth?CefhjMbN6u@nlh!h-e!(zEbZ-oWz z>#&So_`qV^-IigoTrs!8g7$S-`2K$98W|UxWmqitudT44eFGM{v*3b-eH+F-QNDv( z14yiJP=i4ng(RPIv$AOP-K^Yr+s)br#n`MeD3;A?1;uN#wqY?gs|<@}vsz*C+N^C@ zjLj;;V%e-#SiClC8x~`;%CJ~As}&Zn&Dw^=*sL-vmd$E~#cQ+HV3D?&OADz%$vfD5 z8=La;)us}+usYns;8bNQd;GqZ-2{iyCUQ)~Cb za-nO;qVP4*vfP9AJ&Ru)@m+h*$t>4~eGl802Yf}-b27^6f9L0tU|$1J_R07fi*hHvAm)}PyE_%SlPDq8F$1@birP8smMH`iVt0Mem$z3-8_=YX6&88752pSiA z@v?b-H#t9j(^h>?a346ljjBq4uz#;(yorod5$+W12nsbh7((5%^dAS>bjFok?mnkE zX&imv(i4aD4q14Mx4CcmRxiJ6tc(3hV4ta%vhdiXc!i(QWT9&fK;m~Bbt?etDoRfPYx+Zf01=cBN!ZFN(t3<7$gR;WoJ+Oq z*=e$5UQN>YHeTT_dqv`ku+O;3Oh137THrlj=tdvtrFJj}Z*dX`nweV!o7RBYzD_8!y)2)c?^EH# zX^bhpWu+2i8XHU=)WSQ0VqjT&sj3L8*XGg*O+Q4-m;&6%iByD~M8`O<4e z*|8hx@g3d<=m7!Va#ZbmfS}$Jr&qZxi-R@RM8|zb^_V!n;k_d)fhvg)>0Bs*`m{&S zSxUuU_%UyKxROf>a=4+JN(w}-!eEC{zbCG0H3+Y>6mM+TpS^&NF`Ffu6>HQ46;;7m zgloJ}pkH72gb*)y%;G4!_-Q;bYHwF;saxR*u%E`Lj5Cj(;w>)lmm;c&AG03EobZ4} ztsj@+*1+Rs3nD0v!zGQT2;F$rqYtrbsF>d2Vy)=4B0{(h(ijE?G`3+e%G96(BKH36 z$-8U6Wl~Lp>|r@g7Jb*M)%lArn8wRz&03&swQyeO4ZnI9mnVKZ?DAy09ai@H@;eNu zc!%Ua8g`4U@eU(Pj79^S?lE%dH=|DdW`u%do%+pa;?{3QK@a_=n$fM_j3!R~W)uvh z-`JRVGMYH`n^7>Be&Yb4TfZ6oBKl1yh)(@x6nuI8#1T_ogg~(o5No~zj3Xjhkk?Q{A%(Xy(xP3+XjW=FC zYxdRZHy&*1(r@Z)`D^PpeyDiuu&+zMaUs^N-(ZQl^_#4*!w-0U7th2eX%XJUP(>h=B$pnI-`+Mv0Cm6M-mOn^Lg*z+sYNiR zSyjK_uNpLxzvCG4MnQa`L#;pZtM7$HKmh&7R7d=imdsfFJEUOZoIz42{=sM?CeBi9 zjT}Roq>fPez)2QFF+QfjW=#ykPY6&9eU2YMzc~M2dRXHyVS&AyC%Z~=^Rs!=coF9h zrof#4kft99Kl2kXqx?rS!1Q7p{;|wCrIU)EdWk-(gQEBXi6755;R4H9eg9GLTG z!TntfMq_qBkZX}-RO=XTW?4EH9Ro_Qy^rGCJM1cY0P+8`_ifE>97($G6EXjxV`FEQ zIz#blN!IviBPdcDGi*v)lD5xzLV!S%#0ms3xQOC;@_#r_8*%o}`InsU%dF~KWjDHk z1|?67C+v~X-BnpxnOS+OOdP#zTFtXpa#qKq>p?#r^>{qozU z?S#hMXa6JmA%2i$hOF)K5Rs^i%>Y~WB|%#$8Xd%;%}Ac2qh?9|c<6xu*wylO(9?Ow zi#g>d_Vp$nA@>@DQk?1MLAQj1onxZ(1rm-Ip1q;8PKv;vI$AUX(DEuOQ_q#s~G9MBQCtSObcJdHkyqG;Y!bt>{J~5!*qP*mjyr|jX`df z&?81BnU^)(ugBLtdZ~gtAb23I!I;DGeGyy8e3A5YvLP7vscbMeZ5upx0||yqu$f22 zFdp4##yhFD$Gv|7US=;VO+b|ir}6bL?#&aifO7;=o_a9a(8u7UeLo%-MUss^DoMh* zI(IA&_7vu&yy*{SlVMk7k+6v}?VU$SM0k_jq3qcTDNX8iyQ0UI8x1fCv{zv030Vd? z+KZ{bk)Sh77my1hNWuGCTwVZ3l!?q1;_`1HzC`&qz>pTGj(%?Bfb~!v5uzDX3l4Gi zzfRt~i_U)f@iM1OT;W`}kB}ma8D#}s$hRIk#U?8*QcM3BykL=06YB8%)Pv-NT4zdu z?j5ttL`Lgd5ZnMwkO|75Bp=3~RKsxNu-V$)UUVlyAF2$FPTjCOY$>pxN^fR=#a)UK z>RwlIuM24{XrD>GT_2kvc*|!?Gnx8ojE=g$h?d41A`_+$va$ih0jQI>7EXUkPJgN= zPbRr9r60d>-6+3p?ySs@>5-@QgHmeG)52#YcndRR^~&a?pxRsY;b2KJ z$Pi-9oxqgs?!;C0Nhuom^u#O-bQ2@7G$R8XR-8JQ#|SrqqzZn0$|(qJRsaNQ+h87B zOCec1@MQ1O9l+*8!NuM(Q&UJ(G@Ka*;t3vq&d3--qcS1cSBgPRC|&}o=q)NYf~(WMsse=>10+>y8z7;1(R^6A`Y^2Fq%OvRa4ZN1Kf;RYW4vkTl-IhXgr|N zHK+ydH&yWQrx6CA6O7cgb)YZ%{SqU9$5T8SFK!^JalX0@1L{$1W-z;@%~7`W%MalV zy&_hOTLMUW9*hG$^20QqV@r7@h8rL1Q1X~nv8x{A)N#j>BOn+6zy13E9^%<=zy7zV z6|glpPjUR8pddr##DN(1J3XWz8Dvo8MK2PAotqDJ zPT$z-jz&00w^bDL4}kG$Z+yo_@&lZ(Q0hdB-R8AFu3onjI-M%zkn>NXQ#DJGlZY3@ zQiOXKcqaW}IQ4lB;p%~@$9eMrQ3_C-@y=0su@Xm9h_2BhFhp}0IM;WUV#45q3jKznq)gov-fG^WdufAl}gm&!lc zpXJRbURHZG7CsAq+c{xhOq3f7EF+9S*GKV@lK_d$1-auD$dFI#Gq5*qx|zd3u11a` zAeW24A%SXPQ=Hj()-NLd^!z;d2@-J1n^AC~$<65Vn8%34!>9gL(c2)?AX?>B*_V$a z-mSro!}pao|~Z=Mly5Y%Od^N=0jX~S74h4+>-MCRpcmViq_>-7nF zklPFl9`k6RX~`|T>*6}Lh8HsS7As&l*NGQzN@^Exuyjfzwv6u|5aO$IO@Q-;AI&jZTPQj~`9 zic2Rbh}~3q!7IIVgJg$g8@zEXRLsAq@j5{^gUIE~NyF6`^JVy?=FY&7>_$q*4nrCR zYegkVy%RaC)RoD}mdJh4(jAdFaOH-$`=EvuW?PbG*13^j!0h;to55ABZ@EISdVh zj){0_p^=i$T%qBud$8{l(bzA#_rvjxFA}pAclp45?S6%hDQ68F3D_li59mywXjfkY z4nrFG-7Cf`ox=tilnb7z`ol5c>XL&@9a-LD#Rm>5I==;zfm{+Sy&fZk^L9L*FU6F+ znV{&Ze?7OnQza<6;xq|90z~B>f1T*^HZC>iz(e65ih)z4HtNj5*%9jTK1GDbY+lbw zl19d(nM6tQqq#VV3y~|WfUKZE4@pxnjqo>jcauLrt-hNTfs_=14kWet0QE#Hy~a?8 z;P<1YB`QD5b~R)@y97x}s;iJGOP+1LJF*H2I#n_!1%8LL%H=W0eiy^n+VhzrvtY$% zgHh+?^mTDh@Uw&$E|G1L$qqpp3yi()^rKn!#D6r$M@jK2_?P(+wAPQoB;C*E+|F&@ zY;N~a?YX(`u=JZ>Lb7IPr?0^_(87H66{GZ<|0-Lt>q@_}ukoC5<;Lu85e;Ye@eyBE z4=`8Gjxa+cGVM(+>;(Ah0$M_yYiz>BLgR+i_M9ValuuI6g4!ruEBP1yW z5|x6`j*jpNR3=6cr|@$ZzkEACEW?H?w3MKutlXG;uLLKYz{bgVxPaN^?LiYG`idOa zMZo3w?Yy0rL7zLGlQonb)B3hk5lU8)%xEqrH(%AFa#NX0b7kO|GZ=0(l3FTprdj9a zxXZi)K^kwI-0@Hw>YC)lf5>sIYC!I^Ab_YMh?tsEE z!-*S5)(g~}B`4e&!Bc(!<(D7)HQM^{B>M1Fo*#`y;~AV8*%!Wxwl1DT7v(Q(M_Wfv zqN6Fo8i;EQy1B3M@D~h!8xMzr5k^K%&~z{;t^ikaI>(~%1`2gr+|IAC>_z0XA>bgP zRu+fFzcYk?rVxC*NrR*z32!(9&;2B?NlHAt=iMn{!VX3LIgJ8W;tuwZY6q(-c$VNrA9HGgV7DyeWaL*gU%fiU zc|84QMU3CO63AX3buRw?HV7M_s33S-*bTFu`Ux)_l(WCvt`+@EaO-%z8sNYHOY%^i zU(?Pmg0I5mmvI(B!bb>5wdiw;7r#?BvoA@=bvI#L&U~7fH5)H*J1`KHOiYEpF2qz$ z6eStXOZ{|mY{;F(vDWfYveNGw8-P)5`J zN~V&qD|2-+=cXK}f$aYTwXO%_f}TLkYdn`C>9Qdg4{{qa0neyG$sO>OG2M+&)>zLT z zWniR|+)FlNT6ZV}GuAm1jN!aE53)-Qac+Db$YSFiVR$p3WSg~tfUvPuWdw;HmtL*P z-VA`)mn#Zig`JcYK&CC>j1Tc1dxhAY7RV%rK!bgTR1hzRX!Ke7O=o`(#~AJ$S`OF! zJ>+({>d3s7i1B%Go~p2iFQrVY>4yx!ci8sAYgnK>eZu>KE%mEdy)<>X#Kzzg!n;8DJAo@9$NzW=v_niL6P*t5E*FjZ?TH+rlz6-4!LA95#B~rV3$St*zcx8RqTAzp{i)0=~!M` zR+2-Rw6wh|%ZN)xtKo&QB^zovBD0nygXXv+!_K0(y4C2Pg5a{J@%{ev`h?tUX*f~n zoD`SuUgw#aLY9PdvVo+cmM==aR5_3c-7^Mx>G+UpiDp!+q?;`BSku^0LDD-NU+%-v z7U06wljE!#Br79Vz!mV3xEj3sxKNL*_n?Z{=}4CS4E~%p*8R*^om#f=e|HmO+Wl5A zj#5`FcvS=E$<)s}2dyj`lVa)vgnR3*8uK2svT97qsT-^s^B%UcYD|i$4;!qyoq7L! zGyks1tX46e)cXi_K0+FJLEaT3Ib{VRSj&ldbLGtH{0-$in`PD#nIx9_Rm?j{r6Cpb zU~%&3wS0=kjqx1L*dJJm%1Y_9Wl=`a9p=M_S%*VW7{$}1FS(jf+G}l^xBjK!**AvgRW^X2--So9YbiL^t z32B|ao|vvReKSGrrmrQc>rLNCSnKpP#C5H?n+R;3xt7RYHg^M=9dPoxQd^fHa$ALO zQMhG*e>BNmS6;OsyWcP73@~<965a0Od@cobt4+&qB-Tn;v>gHNaj=^FE=59pA?^WK zQHGa7&_IwUAgm_G%R#6w%smJz%JNbW8VK|Rgw^DEISBQIx(8tunO-`7ZNctmUrnyt z^Vip4(^9%;_JF4(@BUf~7mNMe!R zf`GPfF6Z+x zop9oF;milmzG-82nOGbFJKxj?fRi77yWa)?2hT7u-2vb3?AHf?lRw-0whaJeVgT@L zZ|B?k0C4i>hpl*GWMTmD{BY-4eE>N5i|1y);GBBM$028|n)LXYbY&3H2;qN~1tQSJskQH9- ztEV{xAeSoB8osEfKqO|>s^X&DuxchVQp;vVkx^mWG?E*MeY2|ACLdLsVMhan+qB-UJ zMrDiY6yK3bU2lz#U8Rk!vPv9&aJ{5e999fBql?4enAOX))d+AnxZV z53W`Xv4F-s@i}VHV@b&!MJ=J=t#wp{t5~<>l3JS&zP@Hb$)CfU>GBMnx>)%d4h+0e4n~jTr0+_9F-hAHV77hFEiJ~0YJsG=gzXJ3j^$w2sq{qy#iD82va#FNEkd%KrzY_cE^w=kRsZ zRK@F8d_9YLcP*ZDy;G1VO%p9Twr$(CZQHiJ$F^``7kbFeTi-vaPy8CZq<1gJB1K?^X}b0d-0)7XP_zS{$I_1FAT z#cC3!xS7SPz=9H%wux}W;1iT1l>uku z<@#Bih_=}@5yqqj!0FRVIDmj6A?>c0ZsV!@(nUa-{0#fl4*pzeJ`i0JOe-j4yOAy8 zLR`Y~)N1hKfGEeI#Z_O<4%VeTr-|nmp&XO!0-ld!<6mU}RY zY-2xY=9z`;gHt)c7cQoHWah#CV{lDb5hGVozHJm6N$@U6er>8Znu*?~j!a#r1xZDT zO2O2mT}c)(RO}>=i{IxE3~E!se7&OHJdhl9O8VmDQ?J-cAXfN^^(ut3558wnM~h#` z6czV)f1+ODku}3<#yPu=^+OZ$2`^U5--iuHeDp;m8VNsswY@Ydk@XCJ%9wKE12Iv3 zR(&5Z=0Jf&`9^z7e$d5C=OuR(2sLi3zbh6UhmiH*%tQl)IaERo41I+qQ&$H_e*3Tq}{_ZqifY+iiUQ`x^uV!^XfmuwV>Gq1lxV)!Rfw&gYt?9ep zzKGg8UG^HXQCkbMvg-D4X%?CqI`Dxwf*egb`mz?A)oPG+Gy;GycjmX)wQ@~6&RS^^ zIPVK1H=0RBr#lcP7G?A*Xs}UJC%tkZR zY>HzpBKKimPe9;0wK=F-^o7_?jsXHa>X9IG1X7L!&Ivzp$7 zUr=0@f-4l2gn)j9ZKosNo6u0bg=%80!e`uJGY>R;N5TjF@s&bW$ZvA6y(En;!*guC z0$?+AD;S#8EaM3(?tZH%-vz<^hX9RvxCM0Vab=jrgjonx7Qp&VP?(nHf!S`Bg$cS< z*6{UL#1zPjs3s3*V#MM&Wuf@Ottz|nQ z^uYV(=cjG`HAPsHbfja%Zf;Ax0qk5y^UDMT!K=M0l2>pUr}SCmSy7;A&x8Q^{rqU} zUJ>>aqaYHuvh_#vazP3{Z)-EbF4(*ADE8}O%$z@`NRe6A1E_shn8qYJ<-k&y9^w;z z=EZmJDKB<^qO#;jE*x$d%~W|=N_1uT8J99)BrIuB>C>(7cqLZ0`G-#5;l7fJf1++w zC}}5aeEr(3Pu;czQhTm2VXWT8grQ!+M~azagcd47r;=+HQrfaI38RcWAhUvK>8=Un zfHFuXY2t!;De{VGIZO?3?^q7XV@-0}NET+CE@p<_+!2x}B;6;3A5Ovj^dJZy&I)); zm=&@sFr;EY{VG|K4XLZ|HlbBG;k0%en}q%G$au89&dP*v#uh@j_6u;0gek4rnQIaT_4w z-oM()^;o&Fp8Ue`XGaC{%1(s9W)qTIVi{hpv(23GsyF!eJ02AoFs zj6`#L{dJU8HXi|&V=9n`8xbMNZF0pnv@_gn+K0(-VN}S*m!I@+Y5Z>j+iN(tQ1pa= zNL9R&8@$T{vzQ(#FSk^J_TTgIz&nv9OfjxZT2MgD8KjYzzc(v1kI!(RCDga)`q+0Z z78l0$_at$fSQ1;$veSQ{8FwnP{<*IgWC1jM;7OSjh2lm|9{`bk5XjxSw@brl(H=P6 z>y0yO*Ow&^%i|vSYdHn0kl+rUQjXFqVXohJvgk%52^4mLhND6#OqYyT$xKjg*&As~ zd$~DnM5IxW|6-r*mAXt8mQ+XC)Y7^d=Eco{X;&GS5e4>!UT|h-m|)1jlsV$0r)WtF z(Bv}?;+&WL0lzm|a^M<;EQi3>|EH}3YEeIBrdzA2JP2@0VA1tDZWKA49a@$^cr<+` z>8L-I2(~}I!9a6(F@494oU6+hEo1+T{EtOL9Ef*G@|1J# z1o{XU1l^n>=td{%AH}?UYWBh72hY_YK1TpXGRl`tw6M?DH?lZx^#PdUpw(Uh*4;P_ zj$h<)2~uC`SX2uOW47PNQ(t-Et2^l+(yO`r&&x93dh0(#tg#w}Lu6c#*E}LWw%3;* z&Yu?%OUhAQY$IK2f;T&?(>PRl)pHJa1Ht+<;G~rHC(vsvqZWvfxY_*UDBu2u?-z?I z{31hV95)>4ZGfCkcW)W0lE*y_>PC=-SaJ5}?r*`7;c@D!Nf`WK#S|?+RMIL4ssmK{ z9lhB=@fY*vGxIh=YDlKZTBU{6ey?EMjh8oaa5!F z&)ab&8`n^e8r0ADma|l6mglY#BR{o;HY;@w?9h==LQh6=0h*_>5FUZJeja}J&tDx$ z zGurT|AN6-LV@2kV0FJ?V*!)c^xX^4_{Ihjx`~BtE(R`mjL{{i{neO%aW)fh z_&+xre!*x9z;z6b>FI)55Rz$#onCyDtRT}9jU>ij^5$<^E~=??yvM_!S`KDZhWu=p zX)7~>MKH>fqmmQ=RMy1u-|_6Y^=iE^V#MK3pP7ctssoH@0C!fzgJj5p6=FIj|IJlm zXOdcqC!^#^CQ9uEdF4h<3v6J=A{uNv zVFCp7-3s9yIKK$pJ+MpEAQMsf)Q5ls`3WbpPd?1C3g68m=DT&x=DYEYxDSFdxYs2p z)4+(PSt5}}^S|svGDZ3dh{2D6m6D-!xNrdUGIcK|H1pmZ0b+mTwxCI-SrmxsD2!70UR0SE3hJO}0cMkO6h`d0vFcI0cKSlCZ zo~|{Z*fGjfn=GhYpgjzGh6s@|x0nnw)+$)vuPnqZn<};?ed8BUd8 zpS1-d))cY_k&WUF+PKMkscX5t0c-H5P;e;yt|&n@kIZ{{f(a|`*EjZY$nAxr+!)k1 z-klnKH<&mc%qdF}A;6c=%nD4R!s(Q{>>gn%qt2&EuAa^Fi0%Fe;nBTE7KCZ;`3z1{ zbPhtB$K3~{Hh7`>U`GyK>z<@B)Ff2Q4X@E>)`WjsDTr3bIoJJ3quSz?m_?cO;VKj} z98s;3gNrdPaNL@zxh*ZF1v-4$Kae;qmEKLB%4s0OKQLh9*aSON1T6zh7+y*~)H8RJ zNNOq~Cg;yrm5Ab41A8V-QfN$x}g3PytD3AQj?I^$jX!=esy=e zJ@Y6Jwq41HpQ&1V;TEzv(J3W zMS}~OF>dP2c8KE`9Ul^)^ zieYA}5pA2;0(|JHqdMWXW*V73CNr|A4_v1_GanG?+6Ufc!(B1r>>Lt5st7G*WII#y zOOS2gwzU;8G8U47ik08CX&)gKUra%;nL8CU1Vrp3m@6u=A91Cn4~ZBd(L3L}PGcjQ z)X+Lv!;USXalypT!uPOQ>O@r!5}%tNYouMNqAhGOqrR@)f%+>$Bh-LoqzIx+m37LS zn{g!_!q1Hh(HZ-RD-AHFNyJ{b!w5G&l+H%8%}DF1|1vlHS^a|tdN^(dJ!a~5mRYM449AMJ4 zqzC?#B-D!(%WtB1nYvs$@+~FSZ25>urH!dVMf#E367B{-YFc-0d}U@A_}q3$*9>WB z=Oqos=18&sS@=ppK5gz`bt5TSV!RHb$!4yfn7KAA zxbQH^?${F`$-AghVUuNJ+|BM?3~!N?VMr3tNv|wz^l91VCw{ZM^xS!1l*0>0f1eoB z7`oW4z`rj|M7bEy6upmdR=D=sPOXv1os>sbY6qB$x1?@m=%5V&N9^eny&mY^N!g1q zmM@Bwt^5Fobc5_kXwawx3aNn@wLAlE$QV1n0eYcHAa6ri_R9cs7=JdUplN~pW8$gi zaWt3|YBZmG35UMMtIcR+$xv?;9rwI}to-#UJrbcQ-m{`DC-pAi4-5Unha?pNAmxe5 zz#v=B85b2)*$mPnjP96TPD9aAi?8FOH9(HN9J&}o`M>vqN`0p+f~3PdC}=pEQpHVu>>?|Gh23nT;ThJz~|^N2AfL)?{92np+;}j zj~f-->O5efnD zfu%JhB^}$HniBrq+QUcby1g>q@y?f6QsM@Xtf5!tJ(2bw-47ZC=PCvc#rRR6%yc+5 z+ps7B;Yr%TIQ&2z6dN2ekLy%tG-*2mK@#>|Cd(p_c)a!2C*74|lhLNzgx%fDI60j- z)Cx%OEWt`T?BdNfqZ>&8PWShH2Sh)*%#IWgqzN0-Zt&8%#s}PsM7k2fSkf8ik=847 z6XcXQzk3*T{nfWJYDXc7lx{iRJg`_oxMbO7WTq_a*uoP#c=>`qC=k588FQNCxbl^K zp^bHg5MlmTPZ@oW47hTcrE2eTY&Iv8DdID-;7spV6ONVQ(~xZoe5Aj!3x2^fHcR@< z*an4u7z2S)P<+I{3CVEdB5zoFxXzfQ4GoI9u=^-1LnxO_=oc3M1%3)mv2RBQWg=+~ zQVIwt3ko*Z-d#eee#X#16vzQ% zMDsz^+N5$*;7s~2)R#L-g``O2G3_~?DLiFnN#@1GS1CSI>3ax8JrU-t?9EgO{aE#6 zafPC?@G$tXhI3hPWa?kU;z<=iXZmmiBu?teSe(MNoxI);2Vcj_qJU&k6DM-c`AQ9* zvL88R03sv)DSgvH<7gW?)uv5#gEru~-0q>^F#E#CcPU&6DyLrv8u`BxlGL?2&fzgI zMto!c3{{z<@~rvlRKpaJe43u1vSH<|fy-!A`bb7@@NkILd80qlI=l~eKVjw*DD^mM zF<76g?z^D6Zh`_7%=Vl{^WQ`G;sVu z^*{r_@9vbAdUK>zr*J7tBkcXdiaV4pP}7eYNb-to*9>RgW%-=@>4ExEpjXpQqdu7k zU@1m@RhlTa7HMX-G&@_?lbBlc~^CA&&U^x=fP#=?9^=2FX(fq@k;_5_<61g@v= zew7AZ#IRsGJ3}cEK~|+%njF;$*XV!vi`^UfB_wy(bXN2anl z%CI7vv`kWfhrc4~bJfF^c#&v!^!CU#UJLC(0H2!O(2IdeWq4axtylj_w+2XlZIcUDPYa+F zN&Lhf%2d190_dc|k#%;xPy)F*m_j}1iV^Z*a`UDBsb4I7I+rKG$6S*kbx!a4C|Plx zNDx^?KF}6m9ZfLPpA2LTtT;|Gx9)?~NV&6Iq=SxdOV5Kziar50QWm;b#i|y}#2UOk zpz9CT5u~FfXi+ z?7f3A-eP%x9CNC(F+fo*u9Lf73P{T;|Eshjd##R(l=5_pSmVLQ*WF^k8EhDrK9F9S z?RS;C!HRSXp|L^wEnu5^p?DV#YxfTg8}PIvflZw$mcd*pi7JKxiFWds683l%Rlev) zlIbT6_7qdQV{%9rS56kcIyEe5uyGaVlVdfgHC93(sCNlg1K}*}eZ4@H8V=S#YvpJm z03Ib9-E$vd&-YzX-fzqK`Co|a& zfq}vyTE{Du^y7)9>S+(B5|q5%S->A6)|2r-LM`Kv56i|)?RInN4td4<{4_KtvKnq? zFE@}GU@uZF2g{gT`b+v&y@yAZUL6_4q73e;qs<;5=Z%bNz02WADFd8ERjTd{HY<=g z=oZ#guu{CcoVLLB%oeOo;B;S~%Cr^%uc^zvv|L;(>?3OKyJHC9sV=Ns8k{`$ED0r&poBO0yujxMBlAakd=oej;HMdjXW{q+E zaMI>zpJ1a6JaOMd&NAfCttxH{OX?7HcjU`TQZJ0T6))CmH!QEYj(?6xS4${R+f}A= z9D<^)aBzwmby4D9$Sg7dC^4#@Tj^7$OlEOS=F?g3^-O!NOjALVjcSIz>mhh#jZ{Nf%55s{v%5WCHIFo&og6))K6p0zRk&m zT^7q|wZJ2_7EZ6yoLvrE%H?9Sp;u5Q#bjwk7P!H!>ix7LL1u|%&YW0)rUlhdwYoyK zI~ z*}v)P1D+0Io9uX96=5UzQc>8qBRiV5ExJzxKe0Ggb!?Ff6pwT6K)SAKiD5ELPo}H; zzC`_@{PT#z$`yECifqk*!b$nI^&fl|kQ1@F(1rHT2#-V@7Sou#8fva4J5F+*rK>Wl z!m8TP3KzRtVIZE;f=sOv^@aoSPzlYVN`J1@k(Wk0h3msmEis z9gie6B}?Ln%xVmLT^(7!ix?`N-t2-$-CWz&H8s&0QS`>)6OwJy2u3FsuE+V7*kX{- z5US#xFaptdAR^V zn`x@~Etk~|`#&7q6~H9_Se`Y3>cBffIva2Av^FesTeZ;)ng23QWG}*WVGL=aL#D>2 z!k%Co=dO@wQVO3{Rb(72j%YF^4xcYV+Q4dH|M3+VDzJ#rMvpqKm#+Wgq8aDjWwAOb zW>TM}^f3eQeA-AxYz|gEx*(p$+QG%_1PsRCSv|8)Nq6r2F=s04JL9h(^+fHIg0AG? zqzQM=6^X@6*F;HG4nc6T&V+iA&1y7|Z9RQO=}U^ic2iH=7h#F(?>eG5U1JEVqOOOb z<>tuICok)0+Dz4Y*h|@fWe7VG8-wJp>P#!V)A6UI{%^QyqMK}19jGowww0!;ET-F3 zh=-?@xnQpMvPOCiUJH7U(3U+)N2=5^1?kQOZK;jWUR_K5V0&qE|0i_%j8Fgv!9GQ;-J2PSq19FraQOc_jH>+Jxtnb|hkZNk8 zVx&czKX{%Ukw`K+!fz106;)~)LPZXxANRcz4SF@+dPr|AB8GIddJ5Oq)Rd9DxHO>U zx%X1-=Vv2oEfRA=D1*z4;824nMi zk?Dh2f7_Lm%ks6%3T&xTj$Ui8{!~C2y}=!agsh;m?NjGq|(uSrPkj@u-;oHVng*?b|?}&AG`hHxq2sd@iZ`h?WZGJk*dUFr^twq?$ zw1x0vSohv@^v`q^Gi6qFUQE)L;}Yu5F%~ku3FFxZRc#+~1Vn*a0UeE!Yfsj1M=7cp zd)J6p6E^ifxj*2w!1VveQA?*0YlC?iPkT1X`)HG}(Z-gT?E+2_m_6lB^q~PL)tLh| z&7|;v-6{A;>ZKVndW`bD-_e&pPqtHBlzKk}wW#awN_*ZqbS#=nfn?NECuKSK{prS+ zH~HP!<>lws=ghmIIr+YolXX|7>i{>rW4nnvZSQ_^O2mv+WU@7MUF^rZ!OMA(zp>Ly zT(iJsF7D^`e!sR5G(E7r-2}%qGf8&4>>l>|@jbBp5QNVCS}yT#?T`3^rrq`UzE!Ii zbKd<99A2*mmk`{2m!|!TC*NAnH_OIVoEMkM`~xieXWD==Hhdp|=$(rTAKr}oY#7GL zIA-S-j31wOr}!s?r+=`0mJCPF#?d>s#d$}RA9w%2KvY_c02`vi{X0>B<=5OSn@Xli z9lMe}#S~)$Y1imDen_)fVAs>0H*lZOQDaHWror&G$hs*cY~w1*n~|gYN)DgPwu|}0 zbjII_wNBOF@5EZ5ohxyzE6cJ{4IgB|kbkDgEev5b_2#_P93Nq)-eF*4ojlL1&)aCW zViQWZE)_h(Ta@qKO;?Pb!v&g`pMbjAs|FfzYHU<0JF~5wwB>&FoUs>n<2UnWj1W5` z%oV19EAUVn4E54=am~_Kh1kijtR_nOlE$IE`RjQuw7}2|JCXva@-S^3CIf zVq#%)gqtcOv?wj&yh_BaP_DA6B_WTr0CS>8+8kFRH{1HXZ`8(ovj8PgM(dCWefa}q zW^Tbq12OxIXIykrdECvjg;|$_uIgWACl2O*Cs~njvD^U>$ujM^VJ1ry&+mgEI1C(O=19s4H))h z{e}&F)@bc$C>L{-JZn{mta^mgPrW~Ig5M=*)40~ ziL`@PJ)K=zcwTmV50-E$QbR`RC6TUo)Ri_%H0ia6j=A-&LsK!9^t>M;Oz2B-pQjm! z;p=6x&~xn`TY6gJWP$TXoL_pu++!;}L1`tf$s(Jlb&=e>5m9_$!~MRU3e|`}Km6M9 zrkuz5U(<|zCPZ>MCnVV9-!0#7aruH<5lQx>3ME*&ln_i@&6qQh<;?Rd(;cn?eD9#Wdd%05`^x3I=J&@QP zkvtEMxDI`TbH(@R>C#vgN7k5OcPZ^`rKc%%!Y~R`w3(dEEu4R#c&>sI<+0;EnJtx>%E53wR(95O74d z2ETynoL$7z&1bmhuoHuXdg|=|DO`}DW!D7eL$XG|qrP#@5IvQUs~D~@Ufg)nRNLCS z?6P1W_cxM{gkHeT33(c-a7B*W9T(o)bDfl3ZH%+ERkO2?O)si5PIG49JvTdPxP$LH zdEDX_A60KWpcILD@q*o+wm^Q=`q9JmzL2QJ6)Nx%bPgWoWR-=P`Bg*5pXT3s?+Uc0_#wDH|Et99@ca^W$xi+*4|di zy&uFvmy(YEii1beyBUKH@!4Osb|F{iutdvw_>}+PEGZ+w8~8iIMBeS z10a6=;rO|Z9PdtIB$gP{KcMfrS9akwiAyu&>CD(+A~xW;+9SG+DNo`(hIovhO8fx4 zbX@Ael0bw7Q`$n`n8W`eXgDEZ2Q!xs%?s}D*lO%@pCns2i0X%d!1F8mLpM84FT^tb zfO+p#x>k1R>*TCY_o{BTx9T};CASQJz-g{`Zk!Vnu=a5+JjKBly0jG`^5vnU84n>h zr6ZB_m%ti)sCH8snfB=_YYa@K3869a%IH|RcGXJ)tt5h`H)S^LCCy%bX2;?fQ@qau zU9ca&OgE=h<%V~4;HQ5Neavb0TFzs^-M2GDXx&v)9wwelg{~~#5QA*E0#$g-s!z8#u-m4Rv7&BJGkh?31geM~r5ZNK;&sp_msS?Zqf zQ3ZW2yWy0|?3*1V^b&f8Sk|&=TXB&_xsDz0eIvVa_ELmjf=s8C5*6IJjTu8B#5vR5 zOY+N+zbMCL;Zq@^@=b?UHNR0))ggrZik5{;J-B{5wv^Y|&m79kQ+9kjHo8pshT`ts zf#*u_n!jNC8P zRwh4DW7A#_*cjxf8Bi&R4wnYpM#U&;*-1Qe9#?{q)Fp1e-4se#hSZ5nn?jQ}N*(9z zmmdOuI!Q6sTq$?)<#@nNVkdRYoyIY|Sa&~g=IrB_^LuRAHoDF|>18}?H;vG$V^R(6 zd0_th@A2iOIT?*It=hJd5q(sTrm_yMc{me;dX=xot@e(FmiD&81Oz%mcZTC7erNfL zQ6Dma#@2eUMk#8~E)Uf0sI1I|pU>f!+$x@d*bMyXa#K-I+)quvM`E?H_Yevkvp!M$ zIex0XovEWq6ryJ@C;#%ZjbpvffR4DXi>lW@E!%e6(vsDDEf6i@Qh(w`3Qp=|-fSl*ZRg*4+$B~VQB#o>tLz|Ssr#Co6}gB!f?a}&wOKn zL2F|NRtw3Lm;BeLf3asQ@>>GYv?GsB3sXYO)aR7D2<15a#rXt_K$So)6Mu?0%4@VP8}m5fmk~uHv5eRS^v@%D;SgrOFL8%g zbyMzKbB%qF8FDxHg1+G6{^38yXbfw@2nCKwF&Tz~!+mp4Lvginqyx`t+d(kt5y#2Sd?NSmx?#_-BP@~n zX3-b)vsbSU^w=R)%QL9UB_w2*UVJe}4<%W)f}3$0d`FR6Aa+=JNMQ%N3znzxh+(o2 zg>e~Ossn@sMTiY~;ADX0<;1{DIDK~dv4yvi+Min^B1FlvKSVwy4pN{~UyA+hlG>LI zSUWH5(9zTD43U{mH>1U^iknEf@y9DYAei`^KR*sUr}t}^>MR}aqee(I965&PiwvDq zMI#K7|7B=am=~@;?yhH5ldPtJUTz<2wduu~r{f9l?LncXw8eFILH$fImv9Lm^hK_~ zTH+>J;bv-dufWi)>h2*q3NRok{Q`b2BdLr*w=6g2)qk8WAHMhPJTsuK#5Y-Re=XR!cZ_?Z%tww7vf= z!*3d|OQWQ=w4c6_O9B}-pmx1nT0f^w5p;h^vzlu~ZXbS(JFFlb(2i1!nXBxHSWi%@ z0CmESET&#WR5s)|VreRTlE;$e@FMEVFa4#K@99~tVTV1o1PaE!ysep2lVjH z5IgC&R($8qdPBdKcowCReWhgJY^YkolIu9io~e`{dK0CkjJp|UNZBwB`FjxwCmEFR zFf<7H*ckbr*c_1B19`RTd5(g5M%FJsDwKsb1~!|s_EAnBkqP{|QlP@K0x9M(v1Re7 zU?JvWz)!xcGU)`{_90bV6%L9cvvNa|9E-h53d2ygS!+R%^-y2gjrcuJCLMlnQ2OeU ziDS&(VkV+qg++N!?7&jevv6HUn%*|;Yr4T&l@yDf<)}1|1ssDEv{L0Pu?oBQ_IMNGh<~FW^A@%53w}EbbTm*#dUuP zM^dXYhTa$2vOB@XyQc$PF{(WY=4*_l6v?Q$)x-{{z`~~Ga2!%Z+mjT@DNM7>m%IpL zvZVs1(DtVl!Y4KtBSnEPzMM4!7F8$PLKV;}Og6$sge>a`*Q+dy>fkgrp?gjAI|zdg0H@?lb};98c>kHkq4t>)?*|!&D`Dw7)Kyn&o>6&8;lwD zY7_``mSB~<#dr9Lhd#8C_d|UE0Dzw#U;qVaU=S1lFaU^OnGm34%J~xr8UO%Z3;+P* zSL0zr?{4p8?QCIc>f%iQzY`OkhpkO^(njnC0gC7j^%FkAO+yUsiO~qAEO{iCs&v?>_W39TQHd_ zFa&DC5bkD$Xp{-Ol@>M^Qo z-ZQSBECv${tZ$l6c%GvD6-gq?naG*?!<2eO_=gSC#u^HzPi`(f;PMFiLO~I4N5`*$ z2hEEla^^hFPS05-Y?I|G9Qw4m!5xn5nL)l%1OxCs(6L*l(HD}gpT_`^hB&JrUx?l& zblXFhhlI520BOiO?kROG`_E7Dc>F)6I!?#1VH7Ge-NxNf zh7*@{ZazELPj40EHEB$#S92ar<-4R?Qs9!`C?Qo&Jb2(|98wb5`wP41Jzg^-olg1C zp4uCxBZdRCLCyf3KoFs%8L9DP$r6x$`2(XaJIh_MIV6HSl9F8a4i|9Sn~cE?HLhB? zpz*|&K>~WTAm_xvBt`x(MSd6z@AzOG`N&8kLwLY{;0|1PERlJw@3>cv@6i7Xt^dVW zv$nP!jyO#BKO=Yq+nJ`(c#vU+KpkO)U=I9NpqhP>HhF&c%%x&Rh=2NQNP*g9YpNt= zAK&k9M@L@^3m*#yUmF)YWo=^bc>3pDRyaPZM?YexJGD z6K{`kS-H9VpU*dCX%`O@D+aD_mgzHbFEexFGjkI|e=ugse)-4t`2D3t(9&`g3fq_-LsETL zIHW~UUzi3^MQhH^<)0E0JD^4RpDdjk1Fo@ls)57{s`ePz!U_jKjV;*x{6Hn;Tht$^ zSKrFD|4$5H!hjClBY2=}PF7v_gK@%~@k=9LH{o(lNX+P6=Af}(jD%i&Opl0J>5RiA zZ_|Y}v_!v}z>GU5oX8ocSKh9ElI$?jh%`a=12bWaBl!mE1R5<%fhcN8&;(~WPF6zP zWMTUB2&BB*-ZV-0vo_w7dPh1c@&3e4Z`fvtD=L1!dH%0W6VYEqe-6x%JR9dT#px=07a;ba6j-N>l;)X zo#7RqH!<5bySIK$z#W_aiS|SXw?7K6eKBi`OMOg0GNGyBY9^Nu_aFoq#slFcJ3wU6 zIM$Orj>v-oYMx$>bPZE-eXcl|VP6LdfhSJaMy2(Bvra|d2kQZdO@lwS=4?f&Wjp6a z%kd2cYwdpw2&kcP=Q0X@bzHI0LqCrEp`ZNjuB9*lgjvh)u|q#agFnh?vaUesv?e&9 z7|AZQ-TRuMzLTrkzkV?tg6HUW{+mb;=qa6m(7k~wPLfD*w&Z-r-J~Vd6Jb20;c7i zK8t`1`6{sNzhnMKEHQCz$KPi&knWmCq5{j1;K*X2#L}-DZ&j5dQ`W|J;2>h4B+{?T zwLNbMLX)bt6GSvQNR{?wKAC5TomG^SXn$xJ90 z*U~C~M(7zFR0%tWoz3x!mn$wo5)gtKpi~2uG9U2^B>lAc`Q$Jt1#AxzsFu^ffik0IfKMSrD*zzU=)u>$#l z@X5b9|3k3R>DtLf$NUah;=h11zlu_8+dCUIYRu+RJW`fe2oF>8L%P*9wW^?54yxUv zEIO<7Su4=lXyM)e1_o%Z>B6fi7f8p7<_$a<`<*_Mjh=#XF$bRC7{|Od-6LL)p))&I zvtY{h}L{Sl+Bfkg?Vj!wC{WFx^_6<35!{q4uTm*M&lsh zCwM=4x|&e-R(kByM=H9Vk&T3EgfMr}YPE{C8VBw(-^7WG)q@pJ$3qZadDoy~!D35(I_ zs9V=@qhKvKpR@56+!Tmg4WDQyveVcjBQ%64p)=mp*-mqX;TjRsDXyqF5KEVee)^CN zZM4hRw;48dLTrobOe%|Ik8-^iSo!U_io9yz2OJ5!R(hI)UF~kpuXf$a0~@gt`&+VS z1Y)}R7}XfIGFpw$FdvRsVt94H>y-0YEh8oHy`yzJKzN|@$yK0T4 z{uxWYSB0K_&1ga`7!5T?>d8rMmvSzoW0TzSbh)YooZwHKi$ zo2#5$5)(`JV^=>8(i~_hNV)1c&EFF`U;DK1b?8PFSBlqd@iUATCQQoUlR3$PAcY@` zzGg3m^#S;DR1U(>`N4&Wk@39o9~ERt<=F{6nmWZZ3PF)TdpB^a&yN>&$c;9oT(AF$ z1U#Jv*Bn8g1V@q%r$rkL%$GJYy6w z{n#a~5tBoRIY$yRM5Mkmf;^LXkI$o=M3mbXW1?TUC?9iuId=o?lP)v>aR*KMx9u28D>eN zf*x9IL1ADwDk^vq4+kCLJ$H|}+{`E)q2-vm@?3Zdp2H`VN-GKu4c<{b4t31Z=8L*#qq@ zynm7W7mBX-4Rz6n%+}dI=(c7=T$T7ODW8WItJz-MgVKXwe$vwC!WP5#r}3AqcLKa9 zn$)d@=FBKzdMK@NEm_xyD#8syTYzSf^eY)PugL|$$Y`u7ILC{byf0>M2UPu*^;Nmx zLD|Lk_HjPl6~a%X#xfodO2h$ukHcmU5G9me%!9^vM2n+G0y4r})83kHpVFhTI55*b zdDK_WR+exS!EnVM}H+lMME2Vzvmdxa5wRQcK@`S8Gy4aczN$D~o?6aRnt z@c$0US-N(IYzV=1Mw5U>ib$kZjK%~}qSuBTVE2s|{RcLQ8)5ucn2nh*o!e;Jff__z z{BB8^4^MF`D{=NS_%re+FKvDJ+w|n_p6%anp9fe!Po{jlp9jk)Y4m+RA6HNB_wNS> zPMN+LUuS2ZiOqdvcSp^aWnr)UE3YSc@=^T!-`-sOz2V2!b2ur(H6OAM7-2mzxT8&R zIm2lSovQG;Lk<0>qAej}E!(P7uh7iCNcwWVmHIY%hOb0}du`trb(6P}Fm*S_A3+cA z-n75TRW2r9#KG-Tcjudb8~v~BNO%>MH|+RIR*42agr4B|iZS%Om&5_5KiZQ845Kgd zcke)CJxtz6=fgB~FKUd#J6q!8Rx;YUZoW4>dZ;U16vQ=AtL8h0lJxn3nV!4~IMxf) z$`*ho{j;{b8jj+<1MYh>kdT6^3OLfQw!TKRKa%r50V+TaWA&Q09XR~oxqo3kG7KAm z2Kgo+B^(!2uqLiEq1=cqv>SDxhKe??vNMM5P^^)mnm9Nk0W~-kQb_3TE?kWnu^S3p z6IUwXlUZ|x0194UfFS8E1%a7sc3>ykstOJiqAi$NWVj|StjO->vVky81VoSl128k_ zaCNM-Lf>X6cVc)oSi4pIZGA)l?t($8)odylbI4G2s0fS%5F+M-L#ajjQaor_WPqq-X2?zxK{LuBzr=)HIUP zUDDkx-Q5jJcM3?OAl;ypbTonCDzrGZhXP&gWpEg~y<)!}it&gT$H4~Sf|1BIDx*;@ zuBE;r!ELbPN(N;GsDPlB9x-fa=TsAh89^XbcQqz9K>GD19O`ZzX?QO|AQobCRwc8x zJL8mu8E2&`<)DquD`Ht%@=~DsQe!KH#OI%hbz^n!2ZfAm61 zc9g5*H^}CT-FkVh`n4O=Kd;J6~E&<#uo{#s!Ob*^3_|# z)du@Qg{TV>wyRm4l)q3bd!#cCIy}rfCJc1|Q&m^n-(-2gG^d09$?xQ+sF)A2;jW>( zL|a?bWd?1EMp4VgCCwNgLP>U(!I2b~>q=-rW1)#}*iacEhxXd|EgNrg4mh+6pkedl z5!u3rhv=ffzD}(a!bq5e?CKb0!kDC2`N-hEY^=4C9d&V`=w#KnfB>{>f))=|(v0xl z1~@E~fYHiX>`CNbfA`8*s{=NvLrPR)3O~yTPtJG7=Wtnr;K)%MF3dxPb@ z^F^AemGI4WllQAt2}MxGJKid;yGD9mFk|lWpPr2cH1;MzxV#}?TVXkmtp3D9rx+R8(DWx zj>c3sOZSL@;}ZQL9?PWC#y%S%LxW-J`D-uk=4}Uy>Y@3)Ky?f1ovyW^Nmq_F<(D)S ziP{lECLg}S?b(jL;dw_r$9m}Xv7YCh!%b6Wxg+ktV&nR8q2a@?85w0GI}X#gbtcf> zNdewHne!Dlo|0xxjpQ%a!`pr3whW(Bywo4#VhG=;*p$}7s?mM6+1dK_!vhM2ZSI)u zqg9)+`9-DME7x7(;p>&27|Wmgc0!H(-ka1vC%vZZ9V{m1hK9^I8k=-09JHrjD($~p zpI;R|8?$S^I<@&A8{xpcXW^)=T|Ku5lili8ear%}fjm=bc{V*V80;fv=lJ4zs^Rs| zuHo(<(H+lz$QMdXed{QE#fhUhK)=hH{?eP%lab(aJ1WnEJx>YM?nIa@ zcX^WaA;*O!^>3$d>TFYKyqPgesxrE*8pU5EBaW=6UUGdFTZ`|zs%T7G3h28M=c(6w z;)WSJKpEt&zjuhuncIDVdon85+)?J<$t&%xNl2yU?Z+66x2AJz3ri`iP$?bhTsAhj zP^*3#^7b^;cpE+1D&jS%#VUoAwN#Fo_pwWINeo^AF_KG6G-|{yMKE81m(9k!=uam@ zUXx@~x$qBi;m}3G(b3(MTAG@3c2l0`Jwbd0&3N_`bT6zP5~!QUbdNJ<3fCY-ZE+#& zlrXuojfasmly1!)Z+G~u_CDd!cfgsL`!UzZLKzZ0E15v_t&5dBN}Cd^MApOr+d&hZ z@f0;ofvlxgJvPVKy1+|qwICQMF_mq=`02*t#g3} z`BPh^@OYq_oMaXq(RDgMY9CMxZF&~oioF|>$JXV1OWDU6Er`Ed+^b08y^+cE zr}btjJ@euYmmq!fIS~3~a*|QlRjC!su2rG*nkH+V19J>fec@4M=~;8?89qe~@RCOl zg(NE&kJD>j2p%TJo7=vEZ;SjHhyLwtSKFDG*z0)82)&*S1(*3&Gkw|j&)Xu9mHeAz z`f;lIb(2_1P%#L%)3|+YPc<<0m3859 zNT|%ZE{5(a@~1@#lpj#*pTAA?cX2>cc|}yK%07a`#f#;LMH`~063r7tNfK0*NX>LH zQjhKYo@px{i!00)7$1a-+CWV?Q8v(yO?qTCWKz|MAJ|M3OC5ddWiwo0-aq_|d|`y~ zk%hGJ+38GFEAIuCJ#x2Z9+C>0GA%=S~MiW6m!|e;zhVJ{~X=$QQC30mVy?iFtoS#bk zvqtE0%IdJGO*^2=4VIT|B==3c>&g0)O4nlhwi2*I(W+#>g+^}Tkraw(z}Qo!r^{a( zl}A0p{hHAlVW6^KiVCa~f3l?+*K`o|v8llng)Ml>0kTm zFhl|NO2j(Rc%+K~B9;TIXe%faN=svI>S$EvdeT((eLo*EwM1x%N4!bw04gHJ>qppD zsF)YhR6(k;AI>Hh(`}i|B%?P=MWH%hoA6eBeXJHgO~pFsoN~HRy6k>%em+p|w!|0| z!*5F;`W`ZzM$8pHP_oEe7U3J!i+3*#ayGI_7Evun2ohTh_CEyTJ)`xkp!0(0Mq17? z+3`g$jl#qWg*OpL*=!~_+m~aLpsJQcF-sa%FnJHt(Le)VLSFd`c4>XLP^N} zBL9h-r}hx?)!M@&*;gBaU8aY#IcjL%D}~LFqhW}hP_k!2XO)AEF5r{CSh<^zzi+Cg z_hQA$F5z~Dn?O{7T3ct-F}HQ8oQ9x}tt%^RLvzTpfa z`?zVDvm{_}gtGlEmQU(0pLTi`oZ69xtNMoo{gQwnOZ}ZjUS0OLlr*I#}6P4};p|O~l+(AH25i z_F2w7&Cg6D9{&76v3&gNX`AlnEY^@@kKmuw9CG8-XM#=;R`hXw?5x+1EB9U~ERt1* z5c|GOpv!1yAD^5k7Y)ubint^)8j-;26B%|YsMv!`;AmAImV->9^T^D0dH?}WXB0&X zQ~rr9gEu61b^sUErwUh{suox6RK~vF2-=QNDm*w%e4zadOOYHsa)2wtD;ooD*|s6U zev8n7(~j*dGg^Bm^BZ0nqDSRx3BP6%&cWOl;bo)t8_wQXx0vFx!$Q=D6rqHs7)GzZ zF)q)BS0m$vx3nG+GZtQ3TAi$kdGE3-yhc^x4vzlxFQ0Mss?_JKTZ&RX6U%CZT*wu7?pjsUz=r zN-ukqGbA1kCL+14s3?`vh0%0`Na{*^!4;a*ZR>aT;{EN5b4)~%dQ=D0en8eb5?yv zoTMR|W1E|v$&1q-+iS<0-}AF~SJ@xiv&**uBW^KB2nY(`^WUrNhR)`8f3CGN|N1^K zrY*dk6-)9I`bONt`^{7kvbZ`Ad7b74w8_O6xVfa*Q><(6Y9jMbYimv;Yuu@q0>y+D zsBw&+8=!(#O>wO%552!IwTf2pZhyr>U=oNmo?vcCfmTwI3+sv1!A7bIQl-4c>v+*Q zTNRB^94oXwD;ws?+IJp7I9gU>WBk{j?1iQE$?b>A=i`?7Pd-izC6j=&Q5AM!86CCkw9@XOBK4gMz#BBlkZmA-O0TV zi4e*fx%>8j4HGryKznZ!hhss7{keeqawIFA)oiTSw!stT?qZH*avJjmwO571(CfqB z$EI0AHtL38eL`7MqhpM)+Y5))LiY*9nsk;mho5{ghSH|**Q)nRDwBHh^y?~@)QuSi z#fcBf#%5Pa?u7Gp<-~YQ`q-K{yy5lDa!pAJ)QDBpQ)BX{=cqM-2|9DJggTs-TsSY2 z)(&$I_V>SrH)1o-b4fc;@k8cQn~uvu?gWb#xLn^wtGcI;(H4>$t0jhgKmHvEWuV0$Lx+ zpFi(CvH&ql?U#6n3@#Owr8v>`%f7ar7!3lwc+!k2Nzap&<#1EC@pr7=UWh*{hIO*) z;7ULBi|Er8AiGp`dNL%+ESbn!$?w3!SdEOa)WM*=L`629a!PY)61_R$$5YOT&J_MW z9y1-*TNcg~k{ef1a?Nj=iW@JZ5z<+JkwHY;Nzv}7qYXmD1KlxfMsN z$IEGjPpsLdUavpmzI`n5T0*zWGf!e%_d#=u$)=_l&8MZxA*Ba7f-Gy2tB?`GXZrD#}TYb)^tK30v7k-|=V69N;Y8 zraEURSmAt6s!6y1Hu#;!_Qe@a14p)^0{=L5>Fq}2$Z)Lz&75=k?(SvZ85zMP{ve(t zzCU_CDs{pSoTuJ5lqcRt1Sa}05+;d$u}+vLPXzKTR3G(4N2^vdIah7s+mB6Zf2Lqx zuo{sE-c=$TQ%+V}HD-f%^U&7l&G-ZR?E&dpg=Q}=v%mrZk{Mn_2l-3p_mX^_wX`8R zY-{*sUFk)X0^*z+m>mV;`J0wDZ-(A{VTUt8jofXKER6E9A@HBfJ#d?f;neEyo2Bw+ zYEE2o(VL6oYjQZHVju55uBm0fNM*zk6yHp#@iD=Ph_CCK&uM((+l5xxsatzUlBPlx zkMbx~T)!-A2Io3C#XM{vO0tW-%{&(2%J(`3{b+g7Ir`@Je8Js*EiD$eND~eMf}a=y zg5X}i_Ivjb8!PvJ?;rZ|YaN8)n3!?#4JHB-y0N5tP(y-VxmOc+v^e8#@)ryL@{4`q z$MCUr*@WoIl|74BEBGS^F=|=31t{8z{wrkdpO-3$C#?Ld7U~e#=k36v34YuNZ+dew-_!5_8y+t|W*u85o^AFS~S?ER z!%JJ9(WvK7pDxDQ4stA4aATKIfV|jEzBN&k% z+jZvo(x`Y;bF+>`pcLZqQmm-20c%(re}rfu6dVIespFxFN#%Iug%ngVDhh^7>QJ>D z(U;%>6|q7n)V-20->RDJrQ(`kLAOT%fs!RK4{i0bn~7oPfUPthZuH|E75d8l8wAu3 z1CT{5p=RHUeJ@N9o1l)cE+kiQZ0N!LqF$M3JRS+7*3Ri))5gV7j+L_iKG}`F-8INN zvM_5Lj(&*DI7OsEeUx@WE_+MpS3*Vc7?cb-g&mBHK^Zb#>jE>cnau)#S~9ro6&F{V zjT_?U@0d0f`MSF}aqAmPVJO1R+gI^1+_K}N7MKn`j-|1FwU4WqpXIQH>saa)yefE` zlU$iWV@j9eMW40?8Bk&x!4a-=`tq&KTaw^atggUgfp7A0NBN3Tz9f}LZrH9Hy|gCj zl&p^zoi3wI+PyM#3S^ikh?U+wGTL&`3hRK5urPVg!DLHZXwV6y^&CpCUUlWk*`~DI zA|da=>l{y4*0a>>ey~GYz@0!-%f!z6?J*U#K!kpJI~wNan~n4cQK5{SWLocxqXH|R z4mA`=d2Jtx{u>oPQ@t;EY#Tz6PV~yb`etUc#vTtL<;y?j%#wybQyAa|-s4ZbQ)2Qb zC7)!jK~!P2Ut1`y=1bZ^RVMX_sOt{i!k?Y>l2V;~-@Ry!ijRlnW2nv}BVRWXPHtmm zOppg_PJ1qYC8sDO9OQ(Q$Mp$&8?4&NALSyYW5{MKIKjX{u)!}-X^qiF9~6Qsg}%c% z{M^GL;#dB83$4>^pSdI9+3DkL@CF@F;pHnvU<#R(9{c*xT>Y^zAZ8xe7=RpPNc96& z+iDN4NW3Ni?ZLASPL!u)xem5tpW}Ae!wP9oUW(`7p0%s`I4cQlEO4J0txTX-o6wTEBolTMzzY z#oi}a=nS$xuj~eFU&L(8NY7)Ks3Q(n9V}A)>0ZD5QXQH}VO>ahUS(ZqQ5$^99e-6G z^eu$q$-rH=3K9rCwxVoELV*ZNHt+9nPEof6#BY^LyEGwWBP)I0cjszSKc;@8a9ku zvRmllqMUyw^@e9vmR+Zy0oQxKoP*nM7&C(sJ%-|isxz|(Jx)Xjf)}^(NAcYik1PZ@ zy6%~g{`srvhOa8Cz-zZWdLPLm>HG+X?#Dv&K>)G;kaZJFSf9YMHCCZ{6IMk1l5fZX zWJiUKbt&;pFOgkMmmTZsmJQzap5+LzZ5w3o_Jj%1fCdck8(<#_+MmK3J30M--~Vaj zX*!CIbG&HHES0xyJKhv?dpPqVT5LvKKp#@}QVvWpT@j?36Bn_N?UM{R|Ne|@vTc|lA|{4MNIBnCE1;|N#*i(@OA(j&lOv@v zp*l~0Kn+*FS^YL;kIO%_vS&v}FxaLtOHQW=kfrg(GnD)@v= zfI(i0BWH|m3}q-!#Uvko!x6udb(28cKmkgZs`y2Wl<}x9@|#H3P*v#~as^SmUBkd6 zk;s^hKsoFnLf-~|1tdO|BO0&s38zB|EWG21Z^1Hhb={hHIzLrnbc<_%7X|TA9f8mb zf`m#*IN=$_l$)yt6``j&CL6 zF=Tvg9{IgW|4j*Pr~q@PPxA*BM-llH;>o$7bj*Bje=iIrAG0?t5(7fx)Li}2_z_Uh zfvtTna6eM4M9vPej|uR!>;!yQwA}0;AD9xkh`l~?o_s*6Ne_wlywe+gQ+^dyb-)5@ z3q>_QeSEol;Y~M_UC*TSw60g?(?*|K=(G3_yc@MbBA&SNt8bR3hzX}HZd=Bm|w+BrK8p|{&!&V@QNjFw_;-hvu= z|1HBa#vQHrS$DbizAw*3?DksTBHO`5b9}7wwyuf9SB>U3Mml_#HdZKM`pEwF8ox_y zZvSmv)ujdh2+XM_3$X%egFHD;*3qlVe&!J;H-Dk!%eO!4><0y93{<5sI8VvWgV#Qq zs*@`R93J3CvL;f+erxW3n)}wbQv5iNQ=6CJn_!tgMK)G~X#jCnlae)Uad3U$ILA*a zPj+qMhxAmDv+7TBE4q&++`6XKn!MKSM3~zd7B01n!)FdQSAH;#u&{;|b7ZX8uW9yv z#kb2ad}cEu=|WwDX(T7WKsM%?V;J3#%~p@oDyb8ZA3ZOLiA(h~us71mS>wSMQ-Mt) z1T^&Mpc<{12aC=p0xipJWW?H^nr91(9#v^`5*OU0L>u0oXbjI8;##0w9gt14<6=Ec zs_vP~&0fU6hR-XuxNT?@GJI+{e`BThaPFy$z8B~BJ=hY#7et<;t!L$?#`~3lt{^Ut2x^tp?xqy7KyjQ{D3 zo8F8#zGB7dIgmdQj$Md*m16>tn>A}3LREBHf%Pa?cwCF;{q9Rc^tZG2vuPh&TGlT; z7h6u-&k4)RDdI|&8KL$epdwfYe}?Z-RL+;}(N)GvF-mh;QbM7q8j&n61}VQrB7ZI! zZ%&yUE>ipDXDq99cA?2+?8;o2n2?N(G<}iZk5yzM19*$q_p*ZGOkG&J7T zsv<2o=}J#=M#kVvt({xPVS}p8v2|JpKf$c4y(>vYW#awX-7S;v-3ruXc-q&D_R_W< z!KO=Od+3IRmE^dz;A*OmmN{(c$w*E})uV;ZcdaR`6qaomV^KaQz&oxD_W5 zY3(&tbZy;xsvD~pqb*zPNYn$Ut%3~RtNQk8veS}5dScr@P>fnX92D`AL&_T!Shc1{ zPx>sgenOLiH_}w-8m@L^KG-pHHp_Tc02)3|$OW9O#~r5M+VgfG?1y4r``^p2Fva5K*%7yyNwn zilpt7t9^OBT7iYGc8R8*3!@{fZ?B6YP548D!0xWei;fVtPCZ zjQIB1b%G&U^FzU7=qZkfnMb2e3LQMMKbgJ-N?FyTa@AOr>T2lEK>o}NqIuF$+b&qr zcvE3K5pFvtMJrRPu}aw-Wn36wEFC+3Y&TZepapM*UgxH*r%ABwBeW>JwpL;2qKGbw zo=0X?9jus<%NT=RK0^Otb*`L;U^`@*RGRctcdEXGbddq-XiQFPgje9U-^!2g9Ch>D zcr27LiL@a!S={ykAKa*Dl(Ii&eQ%40+{Up``ZgaVBrO=pXSQ4(GDd{Q9`o)3O^swx z7(TTn4ZXkCMU10v1odPt0L8*oT~DoQ3cA<5h=fz$@@&KT*#>$-Wa`*0^FGrO*AfD{ z>0%sh44ZPMnD1bw;&+Q4R^sa)nOsg`&y2_=B7KU5Q^HLT ztxrNag{K&6j#_)cC|y+<=v^qEnrD(O{X~aWR^QUE=}}21i{utcl51y3)R$mK2WQ>x zHR1Z(YM((W`CeB4rYbaF{x7~wn&_Hvu4S#dRAHG7W?5)FDLGf^>z6WwLiJx?THZ!G zw*Jom9ukTP;-BM}%fpAs8&D7s%D`+F(0cD&`r?j2J9Th1)bMmNcX{&bHliZ`Hvsc# zi#Zf<=UD_Gz^&Al0war~h0i zIR6vGpJ!1y!JO$uKq|Ra3#XOS~^@Io7Svqh4_HPWP z8aM`2;I{mC{x|?8_Z~)78yo{_uvyODi8j!h?9uK(UD!K1nxjkhBx zh8@)6Wk1u8c>u=Z9){cv90O{xw@UFP3p@k_D#hJsu6@8Upcc#4CliJM(V*Xp#xxKd z18VUL!)lIi0EXZm=1~MV2GruPeJqzO0Hbsd!}l5-18OmY!AQg^Xr|EKf@44}{xNBh z|Ep|J??uCq1&#r=SSr4QiNMIo#jIi%oJk}150kxQ)0cwH*z-ZmWQ1^mk zKrJqD9n41pFp2j%QNJN@45-BrD<7wb08H9FO#3)E2GnBr&dU%kpxasio^}1*`(e+3 zV?Zq~#uUk<1~7^DF#cb`F`yQ6BhxrD0+~Vt1~z|3v#Y6 zWpjxKjsdkevxv6N2^5n;0*(Q-SedQ#IF>s3D7*LBLH;D@Dfgz+J>)o;uRs+X?T8w#PS?3RmSaD!SL zpu5291(Z$Iz2^+6#^4xGiw$%qJ6iw@9@gDVDOiAGKrMDqUX%pKh}wcXZQ3Q^8&|!TI^(@|KSk8#NWd} z`hjCWE$)^@B4-0KRd#PEKpO;(0k!x*Lsym?6cZZ`jsdk8t)ibH55Pzf-Sy@=1{A{s zYVlX${`C$3V|WiUlK_qZwYa?@`jZSWFma-~8_jqsI0n?>=Dgr(e*jZ|52Km`jsdke z$?1yF1*q`FdqV+)VsH$o#RS3i2i5>4=^m!K92^5`F@Mj+vo-)@i*dJX)Zc?+KrIew z#ckvSF#9NXG4db5F`yRvDH)*(0T}Lk!|U2ca15x$oIH@KWB_LSUNj7!z%if}GiX-L zZUA>p=X;Yk6sKrL3oQ8*0-Fe&#i{?p(XP>b_gV6tL?B8~^>|fLc8M z{X{wszz73p9sb6^E`eh}Ew%`&Zd+li*VU43*SfOw}GZ2Grts z2(5WnpufSnH$xk63XTD_xXS;B<~7iXVw2pBhWQ2*!v|{d4LtO`AAsQk^aJiOe_SRo zP+)^LP>IE%`3(?(Jjve+1`iRG!UrnxP_gea9e{Bpy_+XpG;j>4#BZr_4Szi=Yr5A@ z)Z>6-KqaQF@9qE9`MKW1XcK~CKqX#=vNt~fN*LAz&k5AL<1agpk)5$^oaZm2h?MEh87_dAX~XWUH#38lKK}8sL1|W z0a7DCJWcoVHLmb498i-V8Z(*T0`Y|2i)U8tUpSyDQ(wMBEd}Cnx)%?v?!RzAU8c87 z85RWMDZSS~kqkjOe4xer-79-=9SDa67y$lV%rDJBF>I`$GGA_m!ngsPLZIjRo0D$) zFC0*tA()!TTmVk~J&yddf8l`Y+=h$Rq69q4>n6Lq%zWbZo8xL_Zg0-=`y*(cGm`~3JtFyATZXTfQ9cruf*X0B(*YjHaAmu z1vaHvf)eh&M)5z4R|wExw*pZ0@4jN&Ka>V6PztE{cTaNuL)oOgO94ICd3Oo%?!m}^ zfZKHc8{qHYK-bjop2_+L_=)K*@Xr%kcLV!-JN-Wt2na<^Xo!28>+dH2dvo%i$%T0S zNd8}2mG7qhdqdryse1+fNd3?Dy1Rh8yPp0*mfo4{4a~_i%kFk literal 220726 zcmeEuV{~QRwry0gRk3Z`wr$&1B^BFt#kO6slZsVIDz@#n^L^*ObMJfiy#J@&w}0%_ z+SHh9?zKiAz0WbXf;1=?DiAmjBoGh~A)+l6d&q^!DF={z|iKIPzGFSzZv z?R|7Ux0m`%YcMwFs~6}zwah+#J$blDQEy3P$>H{9q4qOByJduxZAc7c@Xy#iythfh z3v#u;W6Kh0_^ORbrl=AWja7wn)`z!rximiQL=4|`*ZsRS_9DSz1$*Z({C8fmSpz>Bez1y$#EWDy??%WZmt*2=u&q{=bf=Lwqk6_ z;=ikTeMpymyL=@gS1O+@wl=BA=>JnKU_eGIYVD@9nuoA&%MfPgGx9d^`ecAImH9X! z7_(`w_n6FyED?j6KpeO`LdXd%5rdpi5U^WH$hjSc97JR#L&#d3hNY|!O<6vKs%9Kf z!T4n{jmTOkp0)Q?t!N}e!9-50q7qYdF^b4qES|OCuNunweN;{7h)Pb;MVy-hG||N@ zB5S#L){>D7WfNM8dURAxn25?RqKg4U*8ZM!--)aRFR8iEcp=we`R00N!AhHG&=Z|O^=9m?YXepXhQPwY_YFbBB zvWhNd5LwH{Hx-X)DVtO=iUP|i11Y10G3fe3Dx-%n*a9wJ!x+8+E*N19(f)^iNY=XM zY9Ti#YlP{ko_URyr?&KyZ50(a`Sh|IP_%3KY8`G@E1*2OFKsy0-ri*kCOR;h<4gL% zp&3_Kr-Qrb39D|`brwG5wJ#hqtZAD*D|>as>tpv#4Vi&;RvtHx9j0=y2nRxs&j^5b z_~Qc-qPH7z ziYQb-mf2i~TA%b=Ybyj&qLWzksYIVYkxltY#T|1r)n4B69bZJ{c76~Y>Bn~rS8=t$ z0NyqoOAd`>Ck(AyDTH!To#Z{-kWDOwNtVGW2}o{d(0snf&ZkZ`cG()saWDJPB4X;e zVv(sh&BwSEq2n9Ye6_qHlHOY1v7@lD7b0U&JaVnK+`|j&86_n#(%=lx?ER-xjxUX! zg`&YxAHS4L0+y}lF>Mfei}0e!wy z9yavu_D@EF{d-a=c%gF<>>Sgm}N zy!u^X#kL89_ZQ71pOpl+EII5(x8|zB!Ey13)rli~`jgTt5>+g+tC4#C#;TC0HxkI5 z(D=K}HO&TlRwdeP0TD?W@x=<6D*h?om+2$t{BHWhU2o7Y14koX^Ipt0O-dh%)uPXY zDx#Sb1I+McAaGaePu`ON!%`EnSORL3OH03@ZFeV)a_V-C1P5%_((s(27jR zSPSy_{j%-Uwr3v_j@EhI=9$I0mFyHom|}UplQ2zK)_xvOh~!c<#4Im^ZrJqDA3U!u zYaWhna*yR^P4M563rD5=1ZJx8XPfTV&Qfes+y4}8K=7+6wG{0tTMRkqQ}4Z*RCRvS z+{k0-cpEQT5ui3V4V!uyo&Ei79p~iK1x@U_TA+oHEtB5JR*b41D_-JG6wwMZsuHhn zS2KlAVP&5OhS=xC1p;@?D*Mc_TP<3kS_J(_`+Fxf9&`Tf@?6`A6)2L1K zzBTvASa~7bay3m>e;&q<(1xt&au}Tc5HHJ}O2bC4YYuc{tw#2kGrKdnWobIE-e;M) zpGIYZ4j-|eISxD1KkM4FxxEV-C$Zn6#2*dQq81;zUxe-BH-69KvI~NtNTK?Wx z`VI@Qq*U%3InS@3JQMTUg>=AdnIIDWtlYf~ZlH6+Sche0p)+q9Cy(v*wj^WE6pbb7 zM5U}Boav)V=2V&P-Dd0+H^!g;d`%VAV+^;6?G~1=tP1otC{ox;j0>hqbm$b|**sJ( zkG+R1$=7dL6*a6@|47pW{mm#uaJ6Na+o-t}C|m@B=%IbXyS<$@ZFT%beE0DDn|MH4 zmzjf%atkxegW>#|_+WAf78AlO7Gt4vc4sVx^H`K_AelIj`-O~j1m)n6SzEfV-h?Yo zT3wM)MC|0XaFC2GrL;y1by(&q)|;8~T@lF&jT8i~v9y1^W`5LbO*!?KQ8UTaaSY{% zq)8^%io&Qq@V}|}2 zs6<0?eJZEC<+O{-ZqIKy zazSDmN2rAA=JJ)1|5mB6EfR3m_yNx~l(Ic<=$K*3M791%DUF*_q|=wC7{^5;u@pXJ z7qP+Ej!FmyE2OQsUMsyN=pdpE+#-!6bQzOSS4`ll8RxbzR3IhrAXyZRERC$nw1`?n z7dh)$yp7!^iMsycLMa8A#)j__MJo!W?Jf3>8PdlyI=8Qs)lMVljcF_ue_Ssin|R=H zMJpLFNa9H}ME3;-xP|z~Y-ElLvV50%moJ86wzDHZ8@;FhccRKRo> zb)=9%rW`BEwY`!^!J<4sE>oRNfJ@87p@e=OaRuO+LiDZ?73U{m#TM=N$!|Xw zq>0xF{!BwAG?sz7)(D7tPgIa6GbGBdoZp?j!5LRjomBB>+N+aUm!ZaXjI9s)Zt0e1 zcuJvw2ZLH@dg`4-4AzOu;@W{H3I$BhE8hO25$Bdd1~O(8@USSy4pNHaA*jtFNFRO2 z`vMKjy~&{MrZkjAw6OD)lzH=#Bbm1`NTwGszH5AjhA<$-6`0lFRc1fy@z7$C(U_`oA(IAF}bP39bN2q;5$QomPU zeUril!Mo*XjS}{PI8~lSWT-!(m{C=w1Rb0;#Vf9$8dL2VTF`-Te#u^3k{P_a zyTVXNLR86UOjdQ<1|35PXc3JfB(+c=wy57AaHJ?6X`LHVv;t?fA}D`=_+qL6YD#Zt zC9#Du|A&L3qD$xqWB!oh1VcMw^hZc|{8B<)pi+K4_^6Pys}CeDzGJ9C;>l2;N+4Oubn%DuRygx`Jh4g>H`u3DQ0sNn;GKS)5>P^H7xVP5B}6`^()|upQS`qTr84 z6c1uKdz@@U?HAp(8uhP{731`NAf-+PanoGXF;X&W2M>uy;V(DAhU*FIz5w*8Z;wf;1(1 zn?6FOaF6xiQi(i%zD82n3H!R^p))mITUhAAi~B?FO_JB{ z<;gcbS5wX`XMMjF_?@!MQiKB^ff^sDq0llf1voDsG$Li-xB zY{OO-at4_wahw}*lULvw%EsZxV|+x;`J|aBv@GOxlaeDigZnW7zZDa3weG?lzAY1| zAO?lN34sb)EO(gxG2>)|#0ASU4*VsE2+jrx3T9{!$Y6jdX z$}4FB@9l`JgFESl3&$(oP*zEpOq)4|uC!8LWmK3w9-&^N|;QX$&KVhUf+g7 z=#HvePvDNq>mK@>(dHau1h;=b#{akDsen84(O2)5q@cAT67Qa46ve5XWuYyH=P5Gh z?~&2Y#ac}wacnhkTwOi}T zY_M*k?rmATYWz~4(5fr72;R!&U$qVFPQEgz+BbY~I-|}JHjYjO7cAA#FV$aKZxddt zKt!WWM3V$5Z*MCc9%d6B#+;bV?wZ4-8*^9WpX&Ltx#S?1A!`^5b+-n`6ICe;=u~I;#~Nn?IcNp-VR}*~h;s7}Sot`y53Wk$IPzPM6T$ z@0>X)8R}#1SWjH&sXD)+Z_@Mmrr9@n)>R?G1Lw7%*=1u(3DMXG8?ns>9vT+Th%rLc zn8}_RfK~JpEyM@SW>JuN`w%3V!3wiS?`|vJL?d@`3q&2Jfxa~-2lCFK;s+{EblQYK zEm;8#NV(0Pfua%*j+eOBz-hbIUg%~q#<+o>gXP>Nk@@tD7Lu^99uJ8MkU>ngtmVdI z8otW3uYXX;WFZmj74iRsq4LZv^zbqx{i^XSr{Np&P(EkU=zRG&@w`#ctgHOeDg9UD2(t{jvr~?;bZsC#FjIcnrLYd4&l_@yuTt8L zc0^UzaY2t(1%8(6b|$+8#A1oTH~Zt{MS9<7l(3>ynx!C9hPwvACX3}_XM&5^N?q+O zq71o)&eqKBxn=jRH=5mc*Epg`CW;_;CCv-`;5`FF3FI%?I_^IZwF(PA(0cuCzHZt)U;sMfx^sgW*2C`Bpf5WKg{dkzw+qIiKTF}UsFha?7r9EA+3*u zr6i4;K9Fi1MXq1?uMvcx*VLp&3t7;oI(kGj$ft)zq89e+N$9KFf^*RS>0 zmrJxPe1HI~Sk3G$5R=FiIg*+kD_M@gFOX;f@*<1vBU}lI-^;3-FSEYGf2_H@tJ?5? z6pcB#RNw|Uth zVshK_@h2FY&ty;G8z!(iUO~(_i3?chgsX3~?6A1{kg_<3TZ)1*H`Qf$J~oceH>uT9(alm# zLQ*PCngk*Q)pZ3M9&0%l{4t>2bljYdh;9!1v8*8}zQ6Zt_WSv#^4P^KB#}n6^B9{~TtCLl8P8{7u9aswKU!IAz#e8*0+q?9{L)jWHD z0fU}dd4Yp=UnLbw$9pQ%`s?j(c+ZJD$F8LR{p{dkVNDt-V&QJ-=#K04sEtz1Pv{#L zzu$*(81s*v}430<;2ZV`eT%y8|gCcK{1+m`23ZMry|~gd~|Wz^GZv35A~%qF|ml zuT`F-HI`b6qM#qvY`2I9>8fmIrMbLtGuU9{Sq^NLLmU@((Bx*ix{LVZ>CQB|4g!kH$bq2))A>--W=lX6e}t+h30@eZ z9~P0CdeFUp@WNRIrrQW%$Ng<$VzwnK?TeSCYWhOKwLv|Ut$>tRD>3vfgEV+otmcnY z^b}3ra>QisNwKjmbNXW%;D*~l0wwpZ7weOjBXKq!4ZdzjjXTbT*o#BUmh=uNw!T$c zDqO>2m!R-#^9jv!(QnW0Pt47YYZJ$cbEPgp7xCw0hma^=ygWp4w>}NG01Ou^o$!-Cgy057NV)uN&LV2SYNRfHhQ3-{SJki zn%%~w{3YEnS&7FQtrgjVRD{pXoo~RwC>`kzSl7R;TQquLD`|CxgYZrOntv|q8U`!e z8`}y~(O@RUuYPK)s~Er?&)G(0h!qTGQqpdS^q$Y4-8DG=^&0>hM@OUE7XwUw&YpII zar{J;vuY3i1k}5rDwxuiR>YHcYIYI1OvL`}Nnh~q=;7ZBkN7u0X$Sy#L<-o!_!ogP z+kcNophT63kgn8CT6Z3{IH2fmGPcfEf5DOPAlz!02eOgh&Gh5L<%53ryiRgb+lv$*1znjkYe zM(mlNslfm^@@N{Lx2-gA)hSfXKvF8q7zNLT1bu<*r$JAMEZfqi#qtZ#$V-EGvm<3c zmzjG-$})57T6bxk!4{Y(N_fY}!?5J@&}18`ZwqKgU@^zRrFms)?Koh$`sk4P#3Ri| zu#qFln{Q8Vjk!#|gzHNmh#~uBXxx}=ml0zdWa0O8m8Z}r-AHOW26?(}waKo*A944` z0)>VIxU(?*lXqWZLuSZp+*odH_!!4DOj2*4r_J_kcyi<%xUh;-Ih(+^gU|`6(b4ec zdLQS8>7Wv~v+$Kp*C&~uZKK}D(vfom1<^EezuyIx9Sl|W-+o1u4uH=CL%0`$?UR!U z3OG_;4Gg@ZHiMb|%4&F|xnjGh$pcw~zF^ebJSHs3Z+fPVMwh5ZPd`Qu)V$f9_Vy1L zA_?99@&I?dqrw5-3}GnAUbrhJsLDV@+kf?Csa`nh1*IcbVfF&N@n-ms@gdZ<_Cd5= z!(56p(a&mekb#t6w2Ap6lJUF~-zQ^W!)OB&3TYzAv8;V$AW?A%5w#_9^j~fM=b zf#-r9V$FifLP^AK>#iRTNpy3KIQl2rh5{nB+v`=Q`*e7Ce9wzVS3dM@{3dr{ynnSy zeWzw_j^kTL%~Hki$!$@0W=@V@?9xH5K0SZ;u=&Y?zIyJ|!{$3K{m#=hi{n~{)wktb z^JMyliT?Ij z>Y9)H;p>?f-k%-auPKImuavXJtUyqz99pVUYG@1?0V%ZGvM2;nG7nUsI(g8Gq*TAy zNvVHvXp1Is!9nxcu?H9EIy#9wPH7)8RC_~pySBlRW84IOZx{jSsmey&KZz+6pMn(L z8#}ZiYHGHsS~zI85C&+k;TE)LAa89|BZ@0soEItHswqljkIr+T&&Wlscc0ekH{Ppn z#W-V3F@3>gKAeTWEKXf5QMO`dI9EDwdK9R#(v1M>a!}aL`t{hXq;--bP9b~^_R!BH zurxqidsqFQtd@gE!hIFU5Z2%P4Vv(T?t=iK{7dvw%E3#l@#V@tkjrrA&PGW z2&q~|wTkvb6``+_B&oXG7>ge0@_&-Ww4R<>#txT{3a1w?N}hzzb~qA1+iZt@PB(zZ zG=a<749Rt_C+zEtfR+JD6SUzpcF~X00_%oF)Pba8f_$At1j8yJ=xZ@bienQt)-Qw$ z);t8z<&tgI>gC0M*>dv|7A#-FhE_B{5vLJxw@(Vlk5N<3ECE&ewrKgT0vgr?y=3)S zDrctbT_V5Rtwb>y1#6N1t02R0%nltYRdYBv4}FP zv@@f!h|;3rwddsDk>&I~77RlJP$mCgvmEyS8&y!q34^{vRxA+BSIt{3>@+#z7#R-F zvz1gopW|YKsQmsF{SzhZAk%Nij|{<^bS4Fx+C_VtB!Y39b}rc>mGu4Hc7qxqzciyI zx9^eiIYi{tybFfw+Rba*oI>tEE)^ZShwc0&025tC2C=d;=Zy-8!d&*QISwe z&T>qJ=jRWK_bvbK|K&=Hk!#tk*y$=Bww1v3%O1O~8CSN>+aV%j!ED`Fs|vUdQK?n< zyHVltqvwj1@K@yL4RTCV3;REbeJz{GP#>ErN&%R*u4hC9i3R&>_u?iZ6x@k+FFi1c zCIgpMmk=I;MfQnFuv3+{ASXRYDY=HeI%b_ns^R)Oa|?lKkEG{=ZTi*K{2p9Te4dPR z;RTW8v`vC$Z4_5N8}#7)Ed3^2ga^FIK-`Z=1pOz-{A4@B^7t=xo2d7%h(6{u=QH+I z3+iH|AE$6sz0Zsqo0(pDcVqT`;B|FNy`<(FdSOD#*W`4DFO~cOUw70?_b;Zce5^`N z+mCrVA?d+YJBzW8eiY^AJIRJeS}=@U8*%(xZ=m;j@Q*az5l}-nW#GB!c63d19RGPw zKy&<(AR~PUtyUQ1_pP_d1%LZI#CE+GoAUxWmeOH@@XIzO>3DwrNT?*Di=>c^akd)y zO-zNtVFqz{cf$r=7;eln=J9iqf z2_2q0>g3Nt=r}vM$=$xob1`M?#K{S{DtT$A!JFPekk!QTLpV6l-<0F`o5)QX)K|xk zdD#3olkdN}Wl>s4RXA@RmfSfZxmI91smJhRjKc3Z(^0lnx9>PReuQ_0Y{NK4x@K&I zps3_eTR1%J&zUx~N5(u`7rhTy7A{5ihGaED$P4O;>)#~Fe_zz%3u^QMV?9PlPQent z!*1CcvI<85cby*VN6~w*^l?s23Cf;)M zOANazc?*rZ#}{-5Ia9P;8Bly1N_Xh!ksNr`#`4Xn!xeI8(uZVvSFp4U9oZxc{j5mT zT>##t#uVbE#PrLh5Pe_8c_%};n^WDd{jg5DK??G6Y-bSVAPSRSvE;g*dZ_jV|GoOtrJE~8$e6dMarB=uqmzx z!>pQ8L8ere9HTXBosG!T3em7(lJ0aw zNf}_SION1^Bu}5sAsJIkXi}QS(nO9ec||H*<0>`*e*nx@$I&wG@r-PG2W~G`tEEC* zs)bt70J%wNja7R4D#^p@MkF}NvmpNg(^+mi;%h9tBWVK(9>P=qQig8&EO8KpxgM7W zwPVmDO}M$*Ot10@Qb1C7>%B;?ThZ-2Nep5x>D2_4Reik5Dq~R#V*XDO(@HX=lfPz$ zk?6$XA~RZi9uATi7wMB3=E^6%ovs=s33n)CDL@YGm5}33r&qDln@D=)F~(&5?T?{U zjn?Os866j(HIb()^OJR~w+*FG5EK_ltSz@SX+Ii1v;F=dZ2sG*WNy_Cjx_&o{NVT- zKV)P7Qpu8^@o6?CPvhVakf2*egM6+G3(8xm3rNpR__>>Lyg=^0jeZN?mjp+Nq^%O==NM=G~l64H; z)cfk;(N|4xvT0ymGaJBPEzlo2q|c(fqJ%9Cm?39)HZ1)*WE1eh z97ZY_st^!*B?LR6#{>1{yx|=ZerTFY+v9vb=vPDiN#)HmL8pdF1nC+j0_j^^k^WZ? zj3P=|$rPSHH^bBWmx3b;tAW)lQhDBnuh-WsC^7xN1M5riotz4O&}hV`Y`yj^*Bjd+ zv^X5d8zwb4o1lPV>kfanHCDnh)ucW|4t$*QEYO~5oZMhA@UsSAP7zG}FcnB<1+^K+ z_!X9*=m+$zO&*+sZ4V{GHRf9KNsD=6+oG^71IEehv$E-dU`ClSBxrYpNAT2nRp~TX?-8vA@q{q_s)KqoMc!Qh zhL5Iyz(=Om_4|F6=)C@>^xFogXApQ9zF_~gqu6_Km0QnedpM0l4HdQYOgqB7K3ah#5 z6!)nse#LZ#45cLScVHq`1*9ZYcO%qhYV8F~h zgBs2xNc!~Pn!-eS&`J(1Ba~IwAF`7{nP46uWu!FpDv`uIJD)?r0F^$pE>mN%pGK5N zR!Tya=oZYd9W|sh3zArxyp|}MFzJIPDRv?j3t#wba;ab^36C&epMGl=F_8HqKl$|T z)qtvOw*wj8vW-i9ln8TJ!S^VU7>vTau#DGIup>b&JF{9eASMrSZu~b+xRY6W7~zE{ zz)e>k%1oKWHyTrnw(d5|C+W5GSbjR*L=T(z0TdM%c`ja|v{~nb()nFKstDH=^Jt>* zVWoG6*)U>duLdG$89ntVS-Kk@-ww(f58kz<2j4Y6f;WR6@&$4KaLE0fc!n&1s~1I< zSD10Ly|Ya&Gr9bABG*n%X}sR4Hk?e8;6bw&D+kJ@JepHTo-rz!} zyn5KfgrCA!gFr>M_pls?#9tKUa)KS=BWL|AIZCg!PRJci$|!(ngHboqPBrgh6TJXL zbaAG-SjoLp2*Pe={q-z!MJ}_+meU;xkxM&ou}wC-&XiVte#onzd)cy4alTi+q0h~j zqe?g~frFG}I3fc6E@<|5-!EBW48M7s3XcP?Pli&u*=%GS%Q9%!OKG*ZHW_Bw1U#T5 zu>}ttK{Pm4qFMr{D|P6dYmy}D4VsJEyq<(Rh(gWVKU5R6N1leCO4*WM{R^LohqyLees zcV)snh7P}Ro{Xu&G#EWHDJqgj*n_X1JXh;G&MPEQe*V zjV045(N^$jvT{%1mRUhze$lg4XtXPnguOxTKXBgqx96Z=D;5P6HM4pTJMYJyFGpxW zXM{DcmP<^ugyd_*q#nm%GKyXd+m|M@!;MIA?&#-cP{npL%_U!ijWc*r~@dg*!e|7%S^LFIJ!+Wpt zMyl3v=J@N8E9|%WWPQe6561(3&$*DY{XtE~+3O>C6J#*zF=9RHDky5|#YCt3z1_6b zGPa19cg27nsy8I<0G?3vvM|LCeaa$CO6{1c@0ORy4Woc?C^v$C)bWm}GFQRW0(WG@Q6sA46 zBCeV@Nk_avr>-9ETv#;&QCbxbzsA1%ERLr@A<)sN>I$K>W&0~yp0g8*=V2}%acj~- zAW`-r`i!?NE2pwY0f-_nQM;NgnIFKNh^qOTE>d;$y>P8bq8_uF$k#<8TC14kkE@6v zspH_0wX7_9I6E*%=od>$T4g6EZh&8{=E%MP*o#6Ta2+^250hw<-YzkMuSpwq%#-+q zsoHo22E|CLJe$Ln|04m_&4?^2l*rOtWrpJ`>l9;=XAA(_!pY6-Ujbepj;cDr%iKiD z%RxMeJzOiLjZG_lfVsR>(%sSIGrl)Ko>h)g=9k~J8{^qfcxPCz4oR|82TZ|g53e+W z1h3%LkPEwJ9lUD~%`OWd{ zFYY8uwy61O$b$3}bS$?Cp=Fe|Et$fHBS>--2h-;nekO%{BFHY$nn|^m8p%}@)l^|- zVw_T?qjQ3u`|lH+YL7du?3g$J>Ja!XE9rx$IRPr{I{{dUa$@xN(5Zh5vOUU8;g!8{X z_9^-}$?+X*uss?S<@qw;E@}z1k1Vb{?I~9ELb9G^6`#Ur(9K4w-s|?(o2$C{QPQqL zo9>rnXdVm{PLOYi&(CCLnEbMBwG(TJg=e4%>e3=ThqKS|HFRO)v6%P2i+MRi}n(F6uZZ{$HaOp-Q50IRv zNxz|;!8uWf3z1~A`YFZT(2)Yx_%9U?oB)@?EfrS+R}C{^D(mc0gvCqC@2inj#B~^< zv;&;C$XOm`Sx@k*FdxKPpRF+@TZzga?p5VQfIVWn?+X-ORKEi{5cG81bM;dla4 zd;Bhig{@XtJ`VP;8tTPEY}q(M4*!L%<)|=JI0CmQW@lH0U8n@!3+uAW7~%C)i-2%< z#Y@b7_Uv2-SZqji#7-6>--d$KzHlWqU(9z)Pgg%m1?z2 zR_K(-9}komQGvGpB^K!gs!3Jdl{>$VR)O~zo(ZG6agVc; zAWq(4jf5)#oup1ZJTWH1t0^HKrr z!YTE7^>P-5ycOrs-YnjZ3%7xECkQwsZLgsBs9a|4y+;ds~Ng} z7H`Wb#a*HaTP%)lW(DppBMuFx6|pEe!Lb4@m>Vvb4Mh5oFKTfe8V4+J=oz8`w+I&t zYJ_W^LC3F^KaGEuQ}D%Z_+G0!vLDl}b^mxh05Iu4a+&@^F#DVGq@ey6!R#+cf+Vgt z!}kZ;*N@|iVp`pEYFy9Bl`9#4ci=p2wx{<~vyTm?Ry$bgzwvxM%A-<~PrV9l*TD75 zrKj)d&h~u|>j9(%=(=+7`FynSXUCQt#8dSI8MW}rVd;~{59e>7R$Spv?bK|#SJSne zJgmEY>lES@vV($yd?E!%W;T3jcmI^kSYf;cPYG4Rd4sF~)Td8>WXm2PjbYQ`3u*BM zSOF9;=jg9@*xH|*M`T`qP3nyg6b{l=i9ewI$(8OkTKvoxAdWr4=t<4#=iL{F2c{;n zeowGoz~{5$gNO0kk!alnNN{&2^PA>B{0Vjtl9Asyr-EJpGTZjFJ=T$YP+>U4cO7D3 z3wZ^0{8`brA-A^A4sV!+6(U^oD_k}r!?*m_yvsx0q47rGsK~%iBt{zxza?ISDB$MR7{j;@{&h3mCa9)_hEac z2`4Wv9aTd?P|olO14&G(^C7x=?M|ATV8I&z0i2x>#H~R)#632_F`IhisZJ zB_C@64DltoaA0mq*rqLbJi&u!520({yV#{2*_0i?dD5x@N?176Dvwz^(Ly@2=IxM<@ee%DV36y~P^AZ-0~loIeCT(g1YqPf?1q3{aL3bj$;DZ3C*F_T1;2j=eE&9rn)|9zt1|#xvH^7GUx5qbfAF0(f`8;CIJ#A-hswZ=M1*pa0&z#ucMeE#m5Tk!=$sh&S?#Sy1Jx7^1F!6L&`@`K=y)6Z(D>&?OMyVb-PIL`YzSR2xm zLhOmZrvB4w@LzUiT9ZtuYvEL`#cK>(#pYtkM0bnN&ZO%?OsC+HfH!)6V#4yS>|MvN z#7rOD>^XGeJgl`WZ4Rzg19oNJdAg&vN=n*ka_F~0i)rL~hQ?1~=?^Y8x5-Vfh8KqC z=9YRwZ#=kqz*O%>Q(w+3uOE5RPsfUBBQGNveO|lWWt()nE?O$)ROglBrA0x}B&oO% zoD7glIUYV#U5nJ)cWG?YZGCmN$eHKrN6^6Z(aE$hL45b1cwy{li{V!VTJtir(?ID z1uz+1ylM9I()S?y1!hG!VG9DHlIxj0rkjR_5kT?tB+L+VeMvrR7J^LSwPHydO2Tv7 z7?FXCB9tNBtqdtzN}N|&6uxH>p)J9F1lq%JrwWG|j_MYUDb;%EXR)lp5K?O#v^ktQ z;RFL3l%)DZ6t;OE^URl3RjS`{I>FotWfBs7EJ}O#g;4Vx0hqI8aWZ>9Hb8HP2*XqD z_p2q=7J@!^Xt=mK+cg!E+qD>4X97cKWvg{%FNcu+#KAu$RTzLH$cR!&s@=LLa#a;V z?QjU;b}ODqsana?_2G0I*~w>ok1;;Xi$yH9QX&0X2d~cvx-%8zmJhR?)lTP>yqXyK zJ=EJYOh+b+y!{W-wu8JAnp#5HZBC(HLK|BI)Rjo8?n+3TuXhWQAVW`i!T|zO>pZ}s z5VF^`s#$x)zzGw>KrKBNJC7lc!WAdRBeZ(0NXK$jD$Id0f8lI$s|cckK0@f^h%P)$rXiASCGUx z;B<<->VzFke=T2aMH-^KORvvPeW}33v+|X{sRLa%08@i$wvJ@@sR{`yQzYy}?^CKh3D~Up zXBPVZP#PqK%E;*kK&sRK2MuES2T}pV7TAyrh*MnH_2CqoCD{ND(M1{!e?y8z*A6uk zQgkBCoWd-w({*vmDc})VwSM$(Klt7YM`!xwMlJfI(b_4I!Wknx`dvsfOvCm3CcM6( zYKmt@NUdKYpS6i1?8M@WY1^tb@BbDRu&@cYI#@MK&`@(0wXM|N0OX{xMR0krj1M#e zvIlIGm?RnLkVQoU;e+zpg7dz@^ggOIG;K$73;YFD+L4QRmJ#a#%JY?rwy~BAAVzeB z4lh8W@kae6rUh`>(j(sDPGkAm{>;JD+#ygGHAIxXQO#akMg-&#lS@Yk34%f^;V#)9 zvKR^EA@)HZ{^lyre3HB815(qqr`fgJU^jbA{Y|A(w-D~)2sBqP=Uei=Z5;3UR}{CS z4VbYw+5A>zvL-1v$dhJ?y-BzH1tvUFa(v0(-7ZPPVD*zMghCQ)YB2BRdJjteXnQ;2 z1K$QqPvJnwf{EH|ReS~H5$t2D^>M=%{K@pG{>&o)5kGYew&g=Lm9u#yPW{72$O$`k zLFeVGcF=;CtXB>=o$kS=IQZ3t7Ps(GTBVv!k$=iLVTY(ocsO?R?jGjr_^N+3Pl!a` zS;&I#7;PXYkg4OoF%vDJtOhaZD~~YtoNnzJXqJg%kN)q(cV565kCzR)KM%D{u3E0p z5}{lIKTtpblxXx~hep~_taAVmuMi3R#7i!8RCKZ282a7`3TiWqA+Y*E35JR<6>#-u zppE89GxDNV;n#lwt^Xv}NgT5~z^b@J>h(KBlOf1PEX%H~r5c$;X5oT_d}?(}^B$?= zNDZ94xUmQ8@12`=8+sp=8+b6Pm2y4z^yCk7!m5=yQ|F(=$TxSYhQ9|l*Y8n2VnJW^ z3;_XJGMN3Lwc9;&!=LvgJ!FI(r-!_gMI*-}o&e)4c;_ATv)zYtXjO|T2> z8Kg-Db%Wbf^}P$ccR^UglIT6`a)H8^dkU36UTD(SbewlFq}wHfCyJmwV}DxvRbO1$== zBe~d6pH;QKyw4q9>S2-JOO^8Z*FHzTEXhQFP89kzkRnhXOxS3wz;8cW>T9>ZuHT~w z_R`S%BuSW+3zh)r(5Ii1PlY3f;$JeTy`5i?BD zRaY%W8+GMrVy=xu&4kHEDx#PeXgt3^s5#M5L}Vps#))Na078Tcg;SUi#02eDZK^e} zTZonpOXjLG%COVQuk#oop%hxiuuCDvTI)<(5H>1FT}|RLn5t>b+g0it%@@%V!2nPD zK_vnBXA2B@njs2Uk>g?!m%RKMB8jxRQ3e!Rc1fj(G7%F46=Jt@**XbX6&oi##_q3> z&ND`dUMjtT#iEHx$CoUCJGLq>LZMIPnh+hA^(Dy}lKtR}a7~MR)p}HQ*?tc!BsWS> zAVb4+NsCO$e3hUyQ2KopM`Mf{L;fL>mLh6mkR&Mzj=P_~N2V!tbjfmOy>*fiAZd&F ziN-8c@sWS^GifXBJ33zKa~s?lVUpSib*M@jW%vr1qfU^AO^{qE*a)gB9SPUzv_|d4OXS$PmaZN#^sq`_DE>&(R2*7+d%r=dFvCH@VTnWI&>udL9WG z#s8x2Eu-qlwl2_M!Gl|HIJg9NcXtT{3Be&qkl+y9?cnZi!Gi}0?wa84?#?UH-M9OD zZ`}KS_a8Dw)uC!v9kSP2bIm!|D&a)!wgwh}*)b<)_VUb5sqIE+nvF0tW_aB*%~@2} zF>EnHikQ+(^2{XQzMHlKLY3QMyG#yHRp|{O%q`k#2g=K=#zsNX(ekjN%Ge_UI>Yz( z($(RsY4{`ovb!W+b0Ld=MJmpRAoD4x4>W&9s*SVai2z25$rjn)k&4cr7l>3#e?+Rr zPs~v#QD=@fs(e3U)1+oDmi(mcK3@@hun{sqb5L^XG$rnySwr z>^r3=8TsjULFh@qW_4x^4r>N?qxJuYi;j(9XHYh|Uq(X3E}@2ARiuh_|(wmf=7Y5?0u$##&L-Tn|`x7n89 z={>A3)P0vF%}2ELW8FF|!gA^S663j36vQ{2g`y{A+~Tzw@9je>m3qS@C)lXRkI!5&QCm zf0H?)8floMfe_Ld7Vak$NbwOLk_Ls4bSKGv?ATtlnMH*63DC;_h0Fm)Djg(%G{^rK zVva0N-B-TuynV^+ZPj6CakTYRo0Af`0Z$5Bk&R#a{JJe{@xyRK>%ndLbU|lQ8i$VU zX5_+Rr-iO<-JU@fSG8BG;Jx+2$dyN6btpAY(_>@Z@Vk0g+NY@IX$~XzfGA{53e)5E z&Pyf4xV?{sjwTsOq9SDeNbn3Qg%l)Ot%(4i!!^`t+aGnb1f4(lT&hsW6_guA1plx` zwX}jG@>M^0kDOG87=~tFlJZAH%;S5|R-`FhyXOGKt_^~bl$rl+PNq8Fa2HDXta}@( z&%KfVT?!-~Bs$jX)p)s(n5gUa7^bB+eqr~cIiqskND$!9y`Q;;6!{h1|7ZnYsdDPHPllvj>j9+UCbmx?%G5HLil9j^5 z2IMK`)B$auJ`yFM?VAO(eId`?M;o>zCQ8 z_vAU3C7iyzm7#bL5Mdr~cGjxxuFCUibTS|2n$`No@-483>Euow^h{cs6o6pav2SJc zlF9cw0b0tBDNN=HrOq)1P$Px=t+C@{!EtE@oxBEX81yv**!Ws;*C_m95I@=E9E37D z9he_iZ|HZ|r-n__83b{S>8nbNgKn@a=~weGZAtXg>Qu?Weum>A7H@YUj+Io4A8_MER-oM>XeDb?4XKj_zQpv@a_=7y1 zTb1B|%TQk!N*gAgn?2;xkZ!AvGI1Ml!PtMqjpI2jWjd@hNwcUPshnxqE_zJkMTecBx1m+Hx08Eei*L7Qjch3iRxV2gMB||U?Gr&?G zCRQ*t2!Y>M`CMbvAAxDkD?kz5)!0e1&l?6NiYTBPvS1A_U>J9HN06zzP76`}>5LmE zb4ve_uizMQSn%(^xPJ{~T__-OOAhR&QU7B%{ZlF}ADQwjl?F(lQAh0osLA4_C1w+a zZf3Q+Tfdko-&QhLrOA&MKeZT&Rz=%M`+kS|$;WzjYkcXf#NxWqjj#|;9Sk4hJm5ev zD$1aozz#oS$XFpnXHiUi|okeFKc7*Bv1G0{&XHvDyDfE@BZm(la z)mR~?_#`70frZ7e3-1rW0DIa@t&<-MocI2u=x}6LQzd_>U&dsg)8+i2?fB&_BF#Lr zkaF(ZlVZSXNh zKaVv5z#2JjQB#G5yLz1S=k>FRgG+;4C5C$NW7G<+u-v_n#Ci@fV?>*o03skFI7`ae z14IPDgC@G!Qx=Wd^zn*tBc|8Q`RMOq-v}Ey>t>6q&ot8_Hs5d8ct%xiz&<}s3W~GVB3iHnrGjwB!G_H{(5Ovt3kw9a(@@oiU{}4HveWE!rTz!36 zsT1PY5#^5Emw-i6i+=pxja^G>z*fQ2k29;H{tpjsE;>VsoQ?E{6`KGMz3H`gu`^P! zu`=wTf?Xk_znQXRvt^u?AStRYn9GM;J#=j@YCW*|7JCz?TQ`*@ld8kD6?zf^sKGV*bukU`T!L$W(N+BCre(9>m}d zk0HA|8p*hIWM=y`DD@LK^<8nswpIe6eJlkomrM{+daG^t`v^h8gC_^{eXeg7C%V+k z&3DYtAQszMl2YPFguD3DW&qelW>AB!Rp4xVEm7HT9DNE` z1Wmf}!zzWER&khYdo?YWB^OM%=?BbckfVgF*Kuds;J7KKIc{UfEp-kwKK=k1*x^T4 zN?}#(>jWQOEd#o|*yZY8YBK4N@N##JZ!ucQ;SZ{y*Jb*Rt!`Kn3M+H%)MR}crT0uI z6xEaXKZ<2x6g#D8+97+M532=-D5uin$%chJWye0zP#1mO zQIe5V?5%GEaB1bwYVmbzDrC~7yr~_nozznuNCFe3JY&wg^x-{uVrj3Q@>emN^D%Nh zNT>UUZ!JIhp1u0_<*7}6(U2bjbDR&T|2QM>^oVCzeaogp~nBx55t)Br%N^4^w~O?*hmB@MZhN`y8B`6}8fh>@;@ z$qM$`w~aHZn~E8gYp6ni@!<;1eo%-D9@QuMGqKB!aBBx*>gbG)$oY1yjxNT2He zT)6JF!DHlQZ60-4E#qM=QPI54czc2uKMy~kz%;{{W+Se(>}A9yflAI9g{IZGvU>eJ zwBf2RRBw<$*F!mcT&hA7Mvu`DELV*g80zBOPXqI_z4nE<9@aH;KXIE^=!b-L`$g!b zq)@kWO`4m~v4AJrmsa0zp-YeCT2w67#xsQJxiuR=^esjDY_u-o_2DosUSj5Zkcz%1 zTtoRW%mTv?YE2b7rIv^k<0SqPTvQtyE5Z0Lu>;72SNoZ!zKGyPV;*Wk!;ZH^Hl-69 z3&-byLLsd8+Z$Mt47%#NX}KpOU#g6J;Xg+Tf+Ck6fwVFFKJD_dtI6?uF+bGm_e43L zph5JRf;l6h4@vdRMq<~;t9S{WUmDqC(P1`YJ(zTT%^P& zy&@)V9$cK=(w2g@-|d!rx!;%vRuU@&$PmRA_Ai?7{fhD(4GtPa$#L;0GfIv<4*P3E7VUR;b?@ibBW9V3z7jbgI*tl2w{*WwTC2f54h% zJHg-vyZ2(?t2;f7xFBSad*?{a`on=auz^x%dLpjhl1`51@=rzz(T=!yB?G*Vk$^85 z(@bpa{+Yq}kkS>NY~}|JrjJ#q!0!0~nvN8HtzAJHHE1C9F1cnb!v(O)@$uxvElU=5 zJt%e|w}xB48_T`0=eeMJcFQ?dUA$L@lPDpLqPKm7%e_G0_B2s!^LqRUcYBb<#_r9Q z9*yknE|^?X7rI6@lti%XUQhEgtB(iW{%q<@o5-J`pL!|U)QYVL$v#-C9BY`lg2FoI zOncG9?~WSC6LmisQpE|Ev)Cg%K1{}dG*Q!B!TZ^(^5ptx6l)hIx4#{-erJIHn&fZe zQTSR1*rN3Q#}@Ucg7p6+e~Dk&LPa!oB$S`oa3j@*a$i3f8u6y&sz15)1h`A>kODgt z?%5#kTEfnRUf*{3vxJlkor?Omgmi}D_QZqxH?pRowi}`59TW zl%3?7!2*yqTL4+(UF=ACmXPu#v)84q)F2Sk1W$naDzmf2`LmennH+QxyK$1OuxxZu zm~~WOZ>`9A+;V9?BPu9Y|N2axuMQg&7u7)si76g}^=3~4zY(l-mHwNbZHh2+ok%&T zZ~TXX^aIJ79)PSxUZbggCexkq!UzD8KTaU|3zIpD5hGG4Jx9V{f*()>*b1s2#nrO~ z`)tDiwgQNJHE^vt(rfJFYxh$N6IDsg5p4^Mq>Ey)fej<>j5q0M>GCJ$@)Up26&!;% za}$9ks!AJm=?%^Gu-?36Tdl?tZrpt+XCd?+)gKmK_-*$vU6fn&3C|W@CBd|M6J-u0 zM+t>Gs@c-1#vs|#a|l9xLwol<;Q?kX-{h3DkYp#9I}?~I8-m@F(B{ZStpaoi)Q ziAdp;YXtV2BdpB;>^1+dX`Zr|5Jn^yNI$#2f8k;pm-Vj~et!lDy}BThx&M4b;KgCx z{b+wH8hoE(##2EUp95MT$0LBg{spMTk6HUL;ri?QpF_N?g_$JjqsDPV?&zKW;efVT zSFbM{R9X;7_l@;-V|mN#aW-4fX+eooR292^&&h!oo+kUTy5anCN;!0!?)e$C>(tA1Zw@=*DA>VWv2C=;oAUcfvMHtqCmhA=i4?pLm6_ z{Bu$85Dwf6DWm#{jX{Bxw#^oQ&L|&Cww$8{0I!!MGW^kaJR->t?;M! zECj@|GGoBrqkmi-r=zb3l)QKRgEl^Vf__NyJm2r(a!*sQCdy}B1#uufwL8bvFn!SR zA^Y9~o04^7z1OAG+oLU!QN`7J+}teJ03nt@iZb(Y5kV{6={ulIpKG^JM;f;;>GlOm z;`1Eovyq*lk#v{62OX*9z_T3G(sKqZtd2QFA|9wm|IC`aDhLgIu)?AbexrL4$e?Ju7;7;;_^>u^RsnjVS5?S* z4ICnl6l4Z|kc-Uf!PctT#7mmh1Tfv><=JJs&cPA$nSmR3PN6O1?6k3bHn$7RGBY? z^Kg(ud+7Y&)sr(Sa3d(=O!c^>;hOMXL&npvWfa9w2Qh zZ7$MxP&!FI)J8n@4DRQk=Fzuj)+qYxpfiPoohC$&GaE$e-<-v6jLK)ll z>m07FQ98t@V#N-=k;9;)Lk_r_JyKLjDeQ*|R3$znvJgNW!W}8YA}F?BaQ(OVwlrZ0 z*q#W0?dkYMr_9Zo4=6`xpB;(Z9%n*4acIGsJ(9h1VWC|gqTtTMz}XqhwK7_;i8MGn7o_%YYK zoCKdmB&=5;VE{^7j7d+un8alenwIlZ%by@ygi$&{TnB zQPl5a>e%|Moq7~!j9W6`PwtoX*)e^}@_wgH{tpEs%@>}OU1!z!9~wnpBM1j$J!eNo zDTk#?jK3EJIiiTLawAQ$6iN9jpV#vPhKQ}q3DU{Sbxb|)uv0>p__8KCJd>cLo{%0( zJ%M@I`eXzd;Up|zYZ|IbbE5DKWAQ=4srq7>nWY9Ft^oji`@wk(t#o)s>1akBQ55qq z$OV~`Ac@k>ZPpz0Cp) z3XA?QDC{DOAfKZjwODE~q#^*hdSeSyc3pBl4c;@k@%6rJv9t2CK$P==BVS}u5BaRR zoFS-@gG6p<{%%~Nw)wlH_3_&MTHr6eow6eCdVncPV{2uV5SV4ao-heryv9(fCL?RH zQnKimKam>$81=D(D`Z?rWo$J)YR?U~xEOj(_Qz*%eO;j0q7ve*JOht?w)AHd1(lWs zNAi3l*q~Z7KYmwg3Gl{9iiUZkb><`U>2 z$OWXvrsGx*PJj`q#Ut(fi#LVW9^l^2BrN^+Yfc^Gtb?_(TfEBH*EVd;5~#sVV&sr| z$4&*coO~HBz&3X?IDQdh5i8+Z&3J4PSB4$Bf$?gq`nb6O^F8bgWUh<)GE5(izCa9Y zec#ay#r2}jLXMzJ-%%LHeF>`>)O6(c+u=#eygF+@eI3rIRSr*Qvx^fhqc^5&D70djz-}vgpkm~x^(T;y5~50tJ3alj9^f5FD$DfQCDB5NOa~|r>*26- zVTrH!Q{{Zv2$zAaj-f|2>?g3*!T!#@aI;N?2ymGjRGf*S1GY#}6-A_?jCcHuFsRQ2 z;3f}9QDLQ$p+U(JN0LJ2t)ys4sWdal#Id=a`w0RP(2tz~F((vHPYU^-i=L?e>~bWG zDF8KNz;kBi2aF}?kjmA$ehnRb)-i;XdV5)CHhq4i_@QbM?Q+9G|2E@NNwMcsYLn+- z%B|g_93w2LI7`b_K_A}%Vl;v2S*93^yWH8$fw?;{HY8|W7W?6=*W+QgIj&+rKat(o zq;J`YStx;6ba2-_Q_{?gL~*G?g?!p8FC|&PQZ@P6QWY-N#zxL!(AqTx*R`%!cs;Hl z!I#J%VKgTSk{_Y$dV~4?Bii}g>ZLMVeWWk~u(u`9c~XL}dM2=i+ZJA39tlR}E5Y1J zW;WBi2*{T#9GQlG(a#!<6gi$@_cr?KRjRT9UcOl32*_aY@x&rPVDQhB22Q}s&yLBw zI=%15^{kUxhSi-=>2(~kL$!qT_pBM05pV+T8vPyROqz6%%3B1ePzMQ37ax;YA08j8 z#lI^W+p^VR`uy=}ux#TN)leG2if6q#r090aXDzx+lAdJcEb@w4JLz67(ZQp)E4pX2 z_8yfEZ<|W7q(lYOl8r$4y8P@?F)hM}*FZSpCW?y*N7^;sAQBLK|x z^%DXWheUK*E?wjH9auTwwRATU#fpd-H%!(vuu(dQ<9O(^^cxupiu?FVc9e~(SU~+g z@$m<;0%y@()a}18wF8}g&Uoe=UV{E>YRB@Y^lB~y5O@Y0A$q`O-Mtma4-T%T*A=NB ztvYuu>$RiTs0z#d2##+B=zQp~kQBOxmLIhqH#5eLek|xopLYP1!xCHcAGjwGJK7E@ z2wqQh$%BAl(P#F!#x*R!u;?h>W{LjuEZ5Q8y@41kKMf7@HL=&y2&yPiRqnnKzC1+({Vy!?}C6 zHXR^t=6msLWCG=#JrKo@q_~K$`*B})@HXd+`^yUH?s)}>FoJ@KSEa%2w#io~D0+-O zis^%PE8Dj%@v|h=TAI$aGHV|>hM2V&dtKyzljD1j^E=+H05?Q~e(u(am8>}wlbymf; z5Bmv}n-PHS-%RK`_Dkq4axz5;k9y|!TaZwz(%oLHncLsLI5SeTqJxE>o|KW)_|M4| zB!|VDdhD8+MOdGHTl@Y-RQ^MK|E;eIt|IuSzUmK4i9|94)8G24WuyS2BSvn~Lq?RX zvkTj1qN}E@f~AtJyMFbOfswT}6#Ey~Z_rOofKL};xPN4BYeY#=dF^IbH-S=N|g2dPZ53n-RQY~6yD%Af9oFog?Me{dksiX@@5dLPSnAw_K}z8WICS8$-+b-;B>Ov%X7 z-{rx=rvWNYlqP5mS_`IkRrpMK7V~CTZW}h1U&Q%`-2SmRfua#J8M`x+Obl$+$0im{ zO1Ep41kQCq9(m$V3=cFMuLa=%?GzSg(u>tluJqmyt*sKM66P;SG1b5XBTaqsHY*`q zL?}3P201i-%E=;dFl3*8gsq)CUw3REb+(4CAvTBYO2z4RwZn#B~S!^_x1siAiv`PD$wZ}qZrAbfRWRDyiDgD`g zzaLo(1cTUoR1x7OpS7J`IRx_%;7zc!5Ggi2&Fy{CwEW|&cdus8gnY_=6BfIFX+qEG zKXC1TO@^Mbl@e0`1S>I${~oOVlyd3XqySmh@7V@Ru!gP4nNhSBm}M~>>T|QYe>QK- z!SWABya7>SA#8c#%TRSL!!vt34|>y!bTbl#l#*R2Q9bzi2xF!8=l7P}ugOQ=&SKVR zAdifB<2wl6-J3V6x*F0Bm%;jVuNPL;4KZ<)u7Y3d*EV~{shCSMxbL!alx@~*dxF_t z`I7tqhrGP-lUwRgGN!@Rr>=`@uH+XxOV$orQp;wClCOGa3*H^7BV?v{CsZoNu%G2i zrdYNAX@Oc^lYPB~irIKkuamF?1KGOqhE7q1sVt1P48>@^$35*4T9L_^YTWUW(?BYW z-3zN6pvPZVMoHOy@Hc&XF8tQjr@?OLBV7o=19HR+9Q`LzCNgHE&gNvDj1Kzk@Lx1ihlN>~P6d-iP1NV~@yuE-b)$IF)kc9bUg6-A# zfCJ@|JnZSACAy#Ku<=l&dcz+6jQTn8-yD#dq!sH~CQN^Qn3ES!bHU!hWDLR+dQi+Y zhmvzeU#;ElD6+_}=SNh;TlB>b3Sx*3FD@#p1r~{46&xJa%#~(jc*>_Az`yQ=zq5f!T6HMDeuv&0JI-*xr~=gu zP8~4O)7~eIJ;9N=-UA$uCQnI$m{q6&I6_PVime$iz<$>gdtgXVX{#3k+#&!cq>__8 zxqC<1gNH{~!0WE0(jb6+mZT=?5xSRQidd+2WD@Yam{azD}=8`Z+!%I^0TWpd&{J8G8=)1tDm7sJ|XRnkKV@S7L`mIUNySD9T$N{5^ z0(y*#7ouwCu0EuIAzubyU{C`#X7ncUnp9S#OE2_)MFexUw0@ zj8Fm|95g4_IuxOR_g-*;o*6C)?e0zu@NzmZ)}}}~tY!fJi3yL$GEiP@X1yz5sH9AX zG3o)>PZVwsCFI8j6ynM?wbGn?)u3#;B?~qMUgVHNUM%`KriiwZ^klyk>GRUMs@W{j zX^^*bVJ70x6?>r_^g$;`v^=^);%v&wM=09B6H=r{!EZkdE#AG!fyH8P7*~Z;t{nFO zQ(J;-S?-Le!OkzS3{@0K#eT?C2nJPIf-@4`=+rzT3~sDcW&f#g&O}T?wOcCvI^U~ z#-N&KRu2QT{rCr>OzEv;XA9$Tw!4sB-?n(w^HI03vTsd8iC7}2y_?&>#n-Tx4zJ)@ z?2yT;$;B49z)k^(373IJzMUjemATpCP^2?ge-RU87iS@!i3wdc7Gp`ll)v}^VuJP3 z&@(ZC10W_$ibhjuJvLj#<)^$n6#yr)92Ks-S_!7)e7Fy%`b|ujhGil8&?@icjgwf# zy2J6*#02V2ZbO&>2KTtXlLB#9cOcTclGF2d>NGgC;uw2BLa(ty$%a)^((@_?RKh8TOJ z6+bM^p*UJ|txhOlS6Rkz9rS=pyOJB5P(WpkYlho=9eviR21VMjExqz69!0``dCBx$ zdR0;xR}2K*SV>hdz%4d(32+l6gd`?kcr#w2ekBJfJmEtw?2*2g>|ND+in8{?+;?V^ zLl=}^BWV$Y@BLgT_QEQIYbLIBvLiUVVomVxKl7TT1qFO&RKPlB7S`;8%|1w7XqU10 z_O*ux#^sBd0`qit~ zA{W*w?+(|hk{><~EIh8w2s#C>JsvwZ7GV?b?tX4M8dKzVQ!R66-}C&m?|E;x*YSbZ zt6^dI%Cu0pH%}=vN->M~%kFjmATLA(ZKL3h1s3q}ACB4C*jR83;xHn@Y9z7I$~e8- zT5)K#cyQ*da0s+ebn=9e=Jqrw+D%mgH;QFmtH%JN!i zfjXhO$w1~Zi=y9ROM7BAcQthU$M#h)bD(zFcTx)0MRemUAR4hi?aQ!qzu1GX!CbRS z1UFa(Lo!6MW)Hmep@V-7^|7YcWr>L*<|jIgHpxdZ&N2%gLkjcGtf!Lpw4%rN={|=N zgs&{i{2Iw=8|Mv_(YamSm>BEX?pRcU(&As z1k36-Qb`^S{Z}`^NgsD)-MzjzUd@>3_m=pML1LyFs+9~I$?C7(0bfF*2WiFhOyAEK`sSTiU_#{+pFI=UJ=&3~@?h3LQeI z_i+RKV_l=!*=DZtK_VZ0-fMd6r0S$C8v3o5y)S1Z**L^PnISX zc5?lgGwp5ex_e`pIuLBM$m@9AWZ*_(fGOmGsvvzJ+YZ*NPdy+PB%^}}PE#E_3N4!7>%R#HfKATh8PQxEb!` zt4@F*>me;33M*1x@H@!Pgb;#k4ql8kXJMZ{v;X2Ke_^KPx_WJ!$o0KKeK!W@cKDn9 zcc`7WQ|H~N2+BuFW1A=C8)KIf^um!w$d6NwyZEw?!o8G`ag(I@E8Ic<34|2vF_huY z`yCCdm4O00|8@l~bP-P0=9&CQET*-buxvN<9i0=J72IK)=5$G{$LN~Iw*&OC4tSvG?*b@@4L~?8wKth>@VE*v_hqS|omM@FYq4(BDQa?~OY--VgpL zuR|rh{IKndp`w>QGtZ>N)OAdT<6ra=-46{2v0|ts{1=y8nec35KdUhelMT9FbfL`G#TRfEic;q)MJmYwlQn8vSOJpwjx=_ICW|x_wap# zT7M40ur7?f%Br2D5;DlSePLlp>7^mEge!Jlt9(Q(;`;OgpYU-X8bn`A@l=J1M zTQ)B^^T!vbH=R;vj#B4VGTZpR^O_gCCVVx@#l_@>@syKL>t}({n+kE;_!84SN5I7{ zrdVot{BncbzBB_X({#;#gGB7=eIp?82_dh-X+kRk%ySrg`kH%M=dh@kh4SS`@ppTP za8lCDS7JAzQnCJWc>!b^CL!4^`O(aa%oJD)7%*h*!*6@TLY2BkV zG7|4N3WC;(`n*0mA{xkCNoSM9IDarfEE;e(6@TpH_mVS}ZY>)-l)*FtD>Q2zj`M1D zolLF^%4L9}EhaO8um7Y=2Y_$WZ-=~)JRTnA4Bzdf8ubVJy(IzAVVRaayT__~;=fbq ze@&%GZylHMtP;KcA5rX2wdFtgSWvidq|`=#i7k(60gC8!ckgEo=@O5t2zjY&iQ;VW zWeCI8XFk^9r3&;LIsEcQgcT+Uh`qvMm-?d7$fFWzZ%9LFO^hrajVvhEZR?xIg%1Vi z)#iBB5U4z=S<|zvVPvB3D1+hEM|hkks2PI&C0l~!D)5RPBvr(u3AUm^&7x3QlK_i- z!nU6Xb3tbM7esav3HEtP{FOo9iet#Y_lH^)8S^e%2 z?!%gWylh8*%B?gkyJfG&+o-G1nYuD1G=%~!y}^7l_bc@S0hU&ChTPr`q}MB{YSV$R zCe&|n!G1-uqH!<$nO=gM^w9{UE(H!>awv!rjHvc-TrSHcb&g2a1Hnu#GBOha;@vhH zYGe>Sd^M8kr}TLw@3J%0pqvOk`VjX3kGOgo?<#)iRk-$QrjaLQmM0r-5|?eM)KqR9 zWI@?a)5iz*e{-Tswcb6O_BMxPK~0iTsHnWhFIS=CVdMRCw2{liuDr)SEu)GXH{=>DjOd8_;q^}Q5-8>n!|}jD!HE;7t_7m8{D5b zyi`9ve!F$>yuQ71Zb*NlNM3xeh84KrvU<%Iy&r0F&-%E=BBx56mdx_I5?E zLuXTpO2{OKP(MMgCX8$8JHtMu1bd+Il2$;vAQsZX6uxwcrTN0wA3LV0wVfiRq~CSS zKvMMP!!@p|kVmX}cxBL1BA8flBpCXl762h2q&?tXQ>((B7|Jc&^7yw_P70LUkU@B~ z>S36ak9k7Cd$d}U2*Sr$Dia$Z2w=3CWj&v5H+*0q$$H~lD%i2E=82yFw)~B7S4HJ0 zXEe13ZW|2rEt998bWbFcctYREw8)ZJ)tlu4QH={EHDQd`a8f;yEM;jjT{inW#1(D8 zI@FnJToHUgL~v4jIdYcyh#uCdk}uCZJ}4t(Ra~7_V@LP(xp^Q3yw?D`Z_bo)P3g%CbR6__WrbE-T5thAPmuT z)zk!=0^LM7Lx}_(?D}3u40OUaRyM^jG1WE6wJFY%8UjyYB_C)QZO8tFhoyYmF1)Af zmt0BE>+srQ=}jpM^_anVvuHoMMx8b0O3sLzluQdSUMlc|n}7jqw=q7|wZ>&)=L3A! zZZs1)Y`{EvaO+yfiJh6px{}Dw51Pr`L!_@8gQN(yTU?B#8iU1TD(PEV5=>KxHV%eN zh}s?58W~yAT5uBDsyxBSV76FsTEIc=WoC<*sZrM+$xLJvxHeDx3lE zuI%}oir$DP1HC?-khVE^u+*lCwtCFdhVwYa55!RUa!PrENYjV{b@o02#S#lJ;XZXw zOgbEyz5RICiSwp2@Y%t8yDu!D31G5M7K7IcdB(>_i znudbS&dqwOf2Vjys(mu|^sUS*ru*@lCW zDEd~h2Fg-iY;}@7+UyBn8*jAR&cL5+O4*;TK{Q;t8 zUq^>_sv*;K?EVR&e!d*-lwQZ+i!}Mpak;LR^nIxhz))Qx6o)g3AXxWN-;V^*V7g?y z2`fE=;q_CzXOlMpwFp8K)&X5Y%kP>DuT_$s>X8cTkDw|0;2ICl^RipRw_bi=!RPOk zMR+<+z3@GxJO*^ve<>^eX(B8w6RZ34A5*vfAi1nRPu=o_E5=E9Xx z5x92oZAn1zL5uH*R+E9TEg~{urGCV**7@73HnyqN^E*3_+nbB~wY&2Ki<23^;c?66 z>DAW2&OMh>iDK5QjbcuBg0hijZD-^Pal*>T8@HL#x`Bj;&n~Y1Jiy$>3%DCho)?&_ z_|*idEx*nv_QT1VXsywIn+S*U1G9w#mAdt*S8Onqy_5$6qv9hoB_6T>v#eZCQCZJs zeo3^8dcEhtDL}oK>j`bOIg@maA3xjk5Dpju&)9d$S=NXa#sTfZGN4@;{<~es84}di z{m*tGdz)Xbrxmvk+rSCw?^T6=QnH5QXo_oD7X0PL4M z7Zr*Ne3RRrnI-D%N1u<{gd*cz{J)Kb)6%c)J7wQ|ZHuJs&KkV1c8$-12H-d?DM@ zxM_HNQc3NiE8WRrW%J84fO)WZLU*Zj2*t1(7(IeLSUV|bEyO5QT71UHa2jNcQ9<(s zu-*k)iMpZCgifJEJJ{oi?C@&Mh@+}{N79ILs~GmcNRiL;3|>HQ@Kbc*HhUy6_T(fu ziJ=QenlC1#&XUda@f{;r)8N&E&@TqRbX<=^?Hnm!*p_iN5noV@B1+^eh=qtZ9+bv3#d%T>g*1*!ivnA>Rh3L)*#9MZ4H{UBcWnl)cgW&xe|PG zsFYl18QrzElisZXR*@N<GXmxjN0_Q8$Kdn(qheVuPz6^}YSC3I1^``06=uo{OcAxxi(6mnCd!-Oh6-+A zC`;yj<(Mj*s%tth*(F$Uu+}okMk7|x0(lz(Xhi}KXQSQ6{<(BZIl<3c33MVyJ6=BK z{>wlHibwhVX}oin5#_Z1^R@BhUfDk!?0wSN5$KC$zDYJdtbJ}*#wF_v6A%0Y%lX$- ze1|EA9w+}lxaI#xw;XlUi3h|ri>W^?jGyD$pPE2`nvNloE2aL7TMlwQg?YuJNVd0V z7PH0Z`jZKY5gi1TYSotk1>c^QH=mWQrXeG*b{59ew!y{Y!YRp=LVfIO6u7i)wLemcursn`v-${aUK5xfs`F!(|_ z))4B}aln;-9J&FP>g(*m9bR-cY*)Z169pi!3HNVVQDH6G7T)3JB|1yOm?CMi?lBS=r)Y*r^#%}{B(JF!V zs;IYsqK+jNiD6`&e# z*)f}REAGN>b)1e56nsH-O>3#os9kH{2qZWh=3DpY-wMWKe)05a+m~oE0XCh_V$>ue`RwB5^bmgG&+c^qSg|_Hp#vTNV5p z;3!S{r|)A(tom~>`)f$c?_f4XOn$KcmHNHF52=?qVGTN-vIjPbGkXsXtr?MbGYR@B zGol6|LkB%KH`89XZ?RGe+@9KTQU*rm9yac__UbFvY(j=?RMXxNx7~B=+9d4RSI`Q6 zTm9CCM3nI|MpXGq@K$jCR=B%X9 z9Mh6D>>hAV0Ml`@$os-jVd&H`#Qj0Tjc@5ayPj%0^P)r?oR+Y-)1a&q{w9{(>Nh4WXA=iy(iM8M9GL*W?88JH zcbQ$Ux1FW;L|$pW@UPZhzc8KCY=OJK5HfSC(I~|E*$%VWX-BrK6f_OmRMD437VG}Y3oNp^9>j8$9pfz zyj!|Ov>+E)n)f{ddkI!Te_fF~k^*?`GFnG-pFGEMb#cOXaiK)as7eQvPzFNmLd-QO z@z~PzDkAyS4ConyH7?)_kXP;MY?hT>t7&XWp!|#(MICQS+|^hFxSJeRdw~)m&g#z&hqZjer(n??ZcEMJ17vZ^us;d*9W{t$a& zO%AXU<@e{jWP1tk(&7T$NPuMK!swz{N(U4ZLv!kWM#e?(nq1QQM_l(w5Ch!Fq3(O< z#~$|hnlRfFMco=E-1Gg8gW^Jwn93@4E;;gC8Q8=a$5gA|GB(s1Q-I4sqOe1QOYKoi z7_ej6wCG|C>IMdm+Wx(8{9~Sz7(h}*1n`{P`7fQ(zs&Q0c1HbQQy>HR9!1sU_krO<7?K=LEhgctZ35J4;M<(Iz>!9k@1eNbWjkr&m>1$NKx994b%@MVS z?LF0mghXR$Dex50ny--su>kx`@#Avr58IT|6W@Kk_4}tXtil%k)xX=;?!JEoBq&qA z+C(P>!G~E!ZA%l^mSpb``#6cgF z5;(S9r6M5k&Idn3s-j?~P|EB? z^(3OfE1cw02AP3X&reyKG69zAo`&kORsMEj#*!(y{DW&o&w3@=iu8{q!alY%Vt8AZ zx4zX1ul$+Ct&{m4Ff?fE+1(t;U_OUhxCVwMlxgTB`)g}p-9;>xN=WieQX_k~NHIn? zS9x2m!7Gi9(NB?aHUjF@v`Fwe91qyck!z%oHAJI|$Y7dg#3;xpC9W1RXIju<4v`vIj;Zo0vz5`DT^2=!ifL5| zda*(`Z;!HvS`opG@9$DbTuJ|Ii2~{#5j#}f+eHM~?!Tji$=f>`Sri3vds(T$r`Gx` zE>M447VK5azo1ujf}vSG+C&!TUW^5v(DaEVG~T=DZ?wp`#P!e zdiUrA0pKiy0M0VK(<8br*O&Zs9!cxZ`-uH_O6uiS;A4VSn2#`RB+0}Hy|M#Z0U<9u z^;rOy7aVs9#?wK5r6b<>mEM83XgOC?ulg77MTNzQ`^m-9E+GmhPqcR-S3MLtK*86p z;0i7Hu7HA16I$@CuqFaJ9+uaK>FeO=pCa$micG1l6B!MC`SQpA)b}87?w;aWPf6wEX#cJ6b>TzxJyOci zof}>wFnOTvmG7sg0m|RYNCERhN)ACxqZ=k}%NwBFQ#cBJi}U;eZub7(D(4M(Mv)dV z1|Z}`Bv=bQyx59H-#{#Rj5L6*56n-N2`GxakoH5a^3=yUId9US0;lr#L`=qMs>ojd`-3etfgDq))CSe|Dl!W{06N>@FA>jIjesMuoV{af6N^+0KW>TJNlwZ}lcw-3~N6xd1;uH`KKD}QTyktIzaaPK#+3>E0TM940PhlJJekmcAymT=xKLhTN|H@(tzm<3LmU=$93|5h8V zvL?s~T>8>X;Q0~htKAAoF`CV;rd5`fIKb@i=pHNgnH-g7sTd$AE{8TK0HW#AU*aC5 zevH3A9t#-|S@|;(-c7IGSX}-cp4D(exwnb`=={>Pb9B6Cw`jJmxDYW zElv!dU4*6~6s=P!y`_L?l2vfdCjo+E69svK6%FMnC{e6&s7btpyMOvvQFlnrA|Zb48YT=pEuS z>NtA6($9jQQ4YkZ+M4rjW0z|o%UQYy9XR?b^C!Rw24G17ajK1l-B59l3w+8il0VZB zzBp=UcEURpe}Row0?nu*S7_l`>g~Yy6KYFM*D7YzW==(a%D-{@{e( z>rP!8ACE@E{lep0&-u32o7rYE6m8o#Z9~I#K+Cep^w^2q8@YS!=-S2S^78Zw;&Ju7 z`f}T4eE?`#DoxL=UJ0qJ7MAesv6@A&nng>fVu%F!%m)D^00X+e%Dn7IaV2r#z~%rY zxRPbT&!q7!1AwmALlI0>D{csXME3>O9fU$*=U1X8#FAV233&8~d0~yqP%4o7!)&Di z@*WF6-X*a-w950(YAx`+@q*i;pAf&Jk==TgRH?o}thejnWrjJj?)tnvk8BqS^y>XP zm^f%13u{n>O09h8&u$J`54DC*+grozD{>E zNJn*F{70sBfPobf6gLVD&E71OAQfebk0M0YDH`I7Y~$qnZR|)}rN2hD=-{O0aR5y( zCQ%;$YTiDKAbsBql#jXgE-53Qj)Xm8jL5w#e?DK97>9Ef#o>D}N))mTJ>6P{Y9p4V zyb@7Tv4*9og&HWGTad3uP)SVcJc5cU^kXQ?+ZTK|B5^r%G4^;)>3%tTgn%xijI%Jd z@acu3!Ur?Myl(Xv)#@HI|DKX1RKdacbV$<+J}%_uEF|$$2WBG;G?KI?bC4 zuV7(k%?T(KJ5pE6HvCJ;1Hl&pN*;gy)NTJj-=v;pEPuv)&xRt2au`&~^Er~@SX5=c z4H%Q@yOHEKfT&#^>2*T2F$*ddvhOt7R2cQx0CLq1 zj2$k!i37dYpIwJ}bXyPzN=MNQUCa))%;^fr^LN^r19_p4!>+>sqB>0JZUjV(T-gR_ z@#d)fi54o$CGnTe1#fZ$t5%Eo57AKpH>SDy9MI8vagvs`1>2c`0|?qL@xnvQlLTfn zxEzEs+zG#{_7=?)JzbHAw2Y+o_%u|e_weC-ZbXxDT?1VSiwc)}x=b7fDG+N8goQM| z43Jc47ju9r7U`Q|;3N1l>Kltd!u)I3hk_X(c&S=IK?C?ZxnKHHVpki1;*ARUV!BC` z!}XC0?NLqQ$%HtmNtM$)(#)3K7y!9&UYsvbA1POs2Dm;apyC}5h1JLFlq6|IbR13; zDhIHJ#6wc(>82kvJmoMLawb5dQz>cp(3XyIq>iMWN=ftm2K~1D`%Eg@+Jqyi-%zG^ z0QV;eZenE^ZF-ZGwE9Ql`akCB2LoFgfAjyL;QbFeHPd3;j9ecO!a=F^X9!2kYdot- z*L^<9$Dt+S;a}tY*V7g`MLzfDmW-CNX>HN;a#0Y325pP;q>%uAbRtE-kIoHW>ipEv z6B|ziupg(9ewqCtj|BM9XGpY%c0aLwX~qtl72TJFwUd7hdTalRCwqagJ&Z?g(nM00 zh=GQ99*g5GhD1{S%Cg*X3sAsO{8hkx+_nB)z@0Z?P1^t=9A)`}H7XIH;SAmnJhld% z4N+VsB&1I~pI&r(rJP+VQd2jKY9+A%0gcwJ!gpNhK@k{vbH|H;*>YAu1qa)ll~X5| z1M$T*Fg_$U*?e@o%Q0(+$A70dl!+y|h0l@mT<2>2*{@MbT3kUMCoRnU9M76lUN5>y92$mm%W8-az1ZZ3E`@3yxOJXqW?$-bcj-v`C7G zBhH1arj0xq#IhTm(S!!zo2Q(+2n$NTSpVI<_z$DHTv$Br|1hfOo3jHC#5tHXZ9j9i zGpnQl85>u3fxk4ome!jWEzh(H^bA_bGg%Mof*bXO4Ir$odLO-CRIn~S``G49c&}FO zopR;&?&9X!zBPSlSheQzSIO-jmzyVv0$C}hPnXY&<;=yi9y^!qy4yEisgk77wr4TW z_Vk6eJ#b$@czU{E@t{4?pS0?Ii+EpXGLgNe}lA z#T<)g`n)5VUH!J~TN1i(57f}_bG2^BJ`I`dc>CUGKl9`0`v5h{0gyx#^nR zV3RoG7?@;yYwfKBKrj>Soga}%2eoLwa#UlUHrIJ{(zgx0h0vt)26?<}(zg%{LN!wS zIQbw+GD}17%1NlHTJU!~({Rk;4ZmHYiIn>uDKT$$=Z#DapJ3mU&?Dc~3huCnX6M1L z7>%RwrG9_+O?eL1wwcJ41;vyBV#oDm*ofH0p=C=iNNO$HFpJv|Efvzsu?$#yz1K=u%MKB4dP0HV zg!jI9a|!MMr)Sxkvk+5z?V-zQ19Uk*8zTf0Jr*v8n<|z#&cmLb$e@D3d%hLc1y(Ft6q3D(qNj-QPZ2vQzPf?aiN>3{MD{PPF@$iM^ zojqpx`M3DBPmEY+5-Zh_-@;teuy3y#Qdj!MgPd@!Eqdjh%!!1Vo_Qzl=l|FWVh8xy zvzYphd3B1# z2c~+7dVt$xRpGX*Ic(B=nkf1_O}l_zb+6Dmc6A&CsDlHymOZ>5d_kd^qJTOWwpDMQ z>K6#$9p<<+YN6_&Jyad+Z|}bS+EX3XscSp?gQT3E^MZd+8@V}=+nSl71-{RoxU$td# zvN8NavUVv{8;k>K%H#VYMqI9C9uA+FRN9<&sm8|($NLFo{vHi+k_22H!d|5t4gGJWu%4F=kk2+4VfKeW~87MebDogae3=NgB8` z7aNyRc&YCATN`}Lk@Nj9{pIm+=5n^tMENCs_mJU2?xJ3)UHas5IIq={DU9~3pA(Gb zyxx~MAx~I;YlFiGxH;x?KYW{wKG|zVj#DVgn59MrUz{A3{`3Ml8u0hUz#%(z=+iTz zqe4r|PjJ=452dA~{1w1e={qx+KeZP?0SeM3I+#Xh#Qg#GqBZ^PF9Hl%G8!1Z20Ij( zQPGsQP`C=BuUo*2BzLT_=@Hr>fhIeOj0xIKipX5Hg7bl3formWQTUVLmAvg=Mt>HP zqme+z9S{dsVNqPL5w+e=1O(q9kO8{x>wf^SI2zbm4tO4*W9b%hmThdoSyb39iQ7lc)ORQN+SykD}6Aa zv!G+@rOFo7iy1)#nZXoIIh*$<_w^@6ZTki-KUfye=TyPa_3E6WXI|gbCm9npbPW$tnu19f6 zVwPH}3RF3iP8HD1tK8p=+Ha!_*~=V|LTUxBiTL zMJT^j|MZ*9ijI0iFV%5!a$0#v+>Dq0OUceRU&u5 z|L6CdJA-NHC4tn5722Qjpa!HLkOy^>e(cD7q8>7jB>_^-sde3*Jz&(4~Sb+Px-#=GC%0kMKxG2t8uW^ z3y7HYrpri&x+KE{QUlz{DfesPE2_!av}!kT@s= z+{?MW?m+Vyh*G=j$mwP)y{3#2AXWdQ(#r`s3!$RQDzoB0V+W#q6;M z2cTB^6W7Cx@5^rTN91Ca;FyvJ2cUJgZfUsGO9!FV;QNj1tJ_@%oz4H02~Yl^RtE#R zATYoPQ^WmV(_%RPhJ`~Htp_JN70@WD-3c?A=Ct3TOm}Up>lxB$ zb3Wh!lsH=Jz~}HcDOywE~q64eeO$Q zp=rf7#4!8L@&F{P!C}*su>||J zqi`6G$^kVanwqK83*RTVd;WSwmvt?%;%Bkerf8)$wH}LEy23F?D%{=ar#f<#Ke1Sr zyFm`3nvmy>Cn zj?y7{oqh0=!;TRN`9ml#OWFkz(g*_WsDWN1`(rdsQN4)51qAtAXOStTC%28)v%04O&z{L9 z9EhBpZ6bU35u-1hutfs#oQ}_2hL!CmkHxGt6@7-I;(VOzG$%W|+h&Sv+)`MSeY_*v zdznTRK8&+HdslKfRbs{)5V23Wk~Q_A zAXA_gy%Uv66K=s7Z5*Uro`f}kM59SLa=PP??n@9v)e5#ZS4C*CY#v#|=jygP9gO}1 z8(kbpU}jlHf$}DV@QWBCoXryfOj!~p+E9OIWJF3h(j6Cja!>eApdX!HqFGbPAV-)` z|5dQVuj#8ZO$^Fk#!ddNKRK;1c*Ciqd8*iGQ{i0WaUR|edmqxYAciD{=;0=N3i1mM zqE^{^Pvc8R8_lPqgpF7b;Ex&0|DJh|9!}pDIbJYJt{(OGrK=d1C<4sU58Op5bqJnk z%|G^4fYo1x!$usCTmI^kxzLJA2}hEQfcK>klPTiiqU~DzzFqB(v3w(~pFtZUl+>Re zG5#2y{zf-LI8ZbXJKVwACmR}S9$!MI4u7BYIgcp?fv09V-fyxxf{MWk&o((+S2ge^ zmpq>#Y(iQwEPYg$xj@u`oUqbWRebBHwcsMuXyd?3l{{EUmKtWoi8@B*e}RSXz4) zm4CQ~++=hqiKAd;i56zjJ-0rjGF3eYsRRo!(OT~uaeMD+#4azQ&XY;O{Q97E+ph)GN@bgv=FWW)CA@Q?(L0v;frDhJlquPqqhd?r3Cx84J}D~`MKaCvCZWQi@(%0}Mh z(bc#Wk*W)g!OwdJG`XjPnE}MV-UIXYp%KGnZtsD4dkf3tS4l&zIZPvV^DRIUyvHvr zoyXUjZRZhdocnPy!kM~_jp`r9d<`p6zPwOM4DY@r4O{!X;aLDpg7*_WE)hkIWqsxa zHgoOEyrjJN*{p-u79VRw`1-=qas=UDi|gJ6Y)H36LQ+6J?`bajUrF%FKv0M%GIAWa z2RXF2Xz@1ZjJ#fF8ZRu*1f|^G@Y?`Hm={d}&7z|V*R^b`1^sOL(pU6F)BP=y9Ol$W0S}z1=iU=&P7W6~&H5F!G zg@s{FhrfbJqQ-Yb0z_-nQSF7S+$SMQ3TraLU(kEKyq1&ht&9^dDX-W5kYLM_mfipy z^gyHT<;O2!Q8U1rK<} ztEBbwwN<)2t2Lvf!dahpGofpTTOzhnoUKFC>zPJ{Sp>q3K&la=DV zIJ`n{G~s8#G&0qjl8}40>!UfjH%+Zxf~UI|kDq{I`OWF`9059GOSrezH{tNOxwT(yX??rzklQ?39p-&}z_a)!HmJ#N9jMyaXdF(4H z-44=+k%NVO`*MKvmt+Hy6ymo0+E*iob3r7~4=Rn_ArjDpx6|Uk`1>E(` z@y?wtlHyn2O=D3+1p4|x=7$R>GvH@$7#sAH$Y$y?tYnVlS3N@X(wP#MZ>Ow{U=SWL zBz;DKgR5ws|3c~`-34p9g-O3tRlgXAeEWuuG#0LtlpDBVg0VQ{e&cyV7(=ycEQO^x zRybk)uWkLQ@S-fnj=27OL%Ht31G>_@-h5OtuTZR1HKG7r;JsimBINUm=Pj{eX@qK8 z$T828#Nie8MClEhnX5^3&FNaH(9)i3s5x-T2WfYqOw$a6Vt1~5!b2HPrXiG4f>$g^ zrd6-Z%Tb7b{VwJ1-**0g%mTZg5FkqmEU^CnJKvV`Z(8^tq4P6G?EgpTys56V8jsun z5IX zq(H!?yQK%U=_&!?2$+NVHezkol6FeJZMt<$-W~BfkE`*@t7I^`Wj`&ukJBqoGf#Mh zsC^p|>m=+MlpX3{1g!HX zJObh?C;*(0h%{8MV0VbSNniBaADk4v0;Vk5tp?io{cE9s+ut~$@l3HYM6|y-8vx_X z;FTBS?@8A!~#~*m1JHb+tN86E5~_SGczHtI@?Du)Fo-LDo%aE@@{@Hw;Rz zD5coFchGa)Pjx~~MN;r<=&ptx1X@Kf>?-$2RXqo6rbSwBYylo4dQhrJyy^HE52Qb+ zOo|&n@UqkD=QBHVVLQupMZxX+tVnT=0Ionh$}iL^voBIo*qgSP9XDp9Yv{Cn4UymB z7x82+3|gxAk|~ymMTsM~aXip&5$g5<_{EbqA__#<})9-uv@EG5i{5}3v>};>`Q$-p>Te#^4$l_M}V6|0b)(0{S^ZT4N@rSf=IX98XH&UN?H@QZBIxqzQC_9M9(*=wrZBq)H}>CZHJe4>Ht5!&J{9(1Sc=^2{c{tv!%!E!TY7 zFM+k`FaP&HW=)kVnNWeQsiFU6P5oE&!QcG=U~r0a6B|p*3TsQtre^E#2M|GA1?l5K z{j$~Mx&yAl<=p|=0d7aX+X1N_AlwgFgE$FwAi5)&@E z&{~a}eRxHH=z}L_c#pHWso#|ChOu#dF^NqUbuJ71sAnz5bTc_O;*=WmO$02JEU8K+ z-=RN`gW`oMG09zMo4;ZBX$puwfUC}0};`Ry3g904Tf2s7?gck}}(J%=w8sJ#Rv3klosiK6v;Xn(lcW<>9}5&VwNjMBBNj zFP~n$X?amWW?!Eiyq+HB4=~!IUpj{-IaJ@=(1*T=9lq?JZEvoZZcB(=q{G??=PY`( zEo1Cux%EL!FbRkR63(hTimf^;@E$8N<(@?a7;T3DqfH6uZpYDmh@&TSZ7b=N>8bk= zNTnOyPM4k(w)Mp{$S*WoAzC0`19=3AF?PNs;+L4?$>GR&9EMnirRv_Vo{V(XaYAV) zyRuk+KQ{m!$tN`ofFcVnUlH270ZXcJmvywoVQGNq92ty5fF!T$UN6#>-u-mKgwdARr3%Q=E;{L$p>g5~ncRHCN zTbVYI?4$bTn_Gojkghlpwp@|T=_e#^k@B`jSX6x)OI=z-SYhs*o|N;dA<3H|=W)@I7O53@ z8zB1_f)5L`z0o+>_?djwd^G6QMGQJJ@x^?e{1ibTOlO6Yzg5j2L00ui#lC9>E}d;M zMarRu6b2OdSGn>_jWT!h3T=0H?lE2D3V|_V!k}4fx>K2i4shfReO(;tj%%eKx<~yB z$U80Z_KYtP^1_bgBYV~T9F%K}T9U5}&)Fztr0A_)4$zs#+5~1qDdL54gax23Kv-5l zPG2lQ>~cz699-VEpJX#s!6q9#>~eHZ<3ztvDSpD<3~i&*08SLCGQD&5#V}OWMI_;E+KuDU#e?7;(^NUlG9B+wiv#zH78<%7|K6u5~gi;Ls zR7&`JuJaXA9FbJToqc(+@g4EszJ$n?B$S%RWaa9dj9e7-(MLE&P|@^Y&WQP!1LzH7=VA@UegP4}>F? znjliiz&(0236RbSfkuX#Evu`YR@(3!MDQN=kJ`Z$J`d$30OUxPK>vLnmZ<8o3{z(y4bM|@PQUC>WiDBt0{ zk^@;OVd4`HS@bP5XRRUgIv_)K`gAb>8ONv^{|%y>G~gx#4JnsxpoK3YJy&L%W6|7k z(_9v5zep8B+r|E#Ly)-H`k~UT!Ty=M)<7WTHpZs}l;Xk0u2M}icTNo5ONf&^pTkYJ_y^^uM^3Q+t@2%K_+ z456?{I~M?omDtU{_Y-A_icp4lK&7AOdp~xc&_~5zbEW}zp#fJYjN;tfbPz*DZ=B`~ z<&pJBZyQ;9242$stE;8?&qA0dt)9 zOxv9kgeyWuQA$~UV%3-iK(*VwyB2@A6Du{8cc4Z{VeJ8cuS{CH&;k(R_J1M7Zz3}* zRv@QblpES0wl-YHTTC14G4wSViiGv%Odw19ItBB95j+$n&L;xXPa;1*3U10By0g%~ zNWmP&IFAyq_klYC_NC0#kR-b$OK~BQCd>iCIhDRz8(%$`OK-0J3V(>U?ZcUw)F3hT z_i>I}T2}T6DFI#iUOK;re2bpS}J0_J+f2W&ok(p$|y{Px(8pxbZ7%TjC!; zO2jt@ojb>cn@XD>{s2tr`nBZh}MdAiFfb$pC9_DN_b8#T~|JP&vQ;BGXj zf8%ay0NhQG-Ut*4fb%!*hL|1L)0Ig+-D#I#k7e@FtCJtsgmvD}4dD1PZQo=6LD~A| zx>VtJ7xIz$*sE5S`;7U&;cSw~qc@86Pe@b_d%;q1oQ!0~5RAWgl=@H}rJIm6=2PB) zTs~iDo$M-<_AXOsdv;=MG8f9DY+*QXOkrL>?tV)1nVx@`9)701=8?4_t{d6vv7J%w zh~m*(L-@s%aE}ui`pdY{ARkwR*I%J?eJStqCwdftxjwQH%LXu0OK~PQgS%AS2YB~3 zDeG+*OR>a!S5+6@_QEKUi9J;O?H}TiVA(93A$fOq9sAC&ozc_;g4qh(6j;*Wz-#<= zKc{_2MR2cmbb(xQ&m-QmU$!X)1l549Lk2G?qc;3r@dPad)=b5X7>;LH0KJ0v{mrr*DmtrUxwT%L72|CqFZ3 zZ=Dn*?Nd)B82pyZQd#YkA=?8-(r`u`o57G{S6-z~w<(R2EJ*`&8pvpX234qJmQV7@ zwm$QC5t^MdA$psN1f{hEbD$~l7E<0PK^&XUO@=!X!vPxNq)fu_??CdRQR4I)s#cxK zmk;ZV$t7LDs+mfdH=NpKQ0ANd+g)q%kxIHO?|WZ86w)l>+<|G+H{tm)Bn0pRg;@?Xlvzucz! zQ9#)kxX5@aqT@{)`gRTzORKa(rB1C>vvRn{A*9BIWcH=6*6luNT4@)m0UViZ&mu`C z$;)$n>QP2st&QwFK!5NDvEky2o?JZzEG* z1p}2`NN_5Q6xI9)Upuc;QS^EYPWNW^j3*}S>|kXmHKcMLbMLb+pga#Y=+2^l7{ z#3rlAYr7n$dS9O0#gQ1|6m_xogPD!_4bM+mGls>LG6p@@HjezE07yL^w`$qAGKRM# z!FBH*^cF5f18Ate=)G-==)b>6x)D8r)F;*aGX?~nCN&bi5B zB~dKEL>A=4!3>DVvdH(^0dQlli_(MzsZ})-T)`vdbC)`aznJv(3n#@M9fm1mx`jN3 zIekR`=|1Rd$Rpo(?=h>kcplsTtis3`&r2mY9FLkg49X1o^=F(= ze6oQJP&G=|VK=|0IjVe-{#9pIwhwNtSbb~6#YH66lr2PB^n$21qoyb`i;{&SZ+HD0<;vGJ*F3wcS6A1Im$fhK?9R=c-KAPUhP=j)#lUvs3R(hlD{ejwxZFQ3Rp@J-FmT3WaIEN!d`G$lVE#=oLi z*^qy_gWzkMwx`FV@lpI~RhEf<{U~Rk@fNA?_eXKA1&sNGLtHnIMt5EqMy_AWz!^gl z-#i3^Vm6IC)%h|koox26Dym2{!&tI5BMDej*qtJ%SWd#M_1@wuPCnTz+g(}}c#A?a z${tof!dT!wXuxI7%Ty~|`%#@OG*Y!I(7=IiWx?u-%*68y5lyJD>Hv6q*`Y-Cp)}4V z5-NU~P$AnfaER$7-!4j8{R%jwAY52=3Vqd?ME03<+%-~eIPN-QqBSGBPFmP-rH*Xt zD3?e_2Yl`@ec7|zh;F+x&vNneSBmFPnO;;~r+4ge$~PX=pe$5!FGN*|bY8c3W-KxP z97s`ns*s~!d;?}a3siMsa%$5eU7416x5i<54vDoAGCkMcqQ#%Otsc468^1*gR}NiR z2f6sl-zF3{?(|1cd5De>RnS`#>VwUj7_opnbNF~c_uGSKChEKhaJNwhGmyhA=$(- zTA4W@7D=^jrLS774~*^9ZCIZjSTv5mG$S4|fD4#PEOMw|WUDP(3j3ks+8iiY!xJWO zVLdhD5;V>Lq7NMh_gCfQNXdwsT(LPBp!VPcyj{BmEYtct^piPhr!xihG7Kfv&$BMD z1)7K<3DF&-Fd(Tg+{$e&;>K9E^Na|(@H2#;^qxWMJWE#wwA9I?TGK2D9M5c8$$k82 zlRu$udfyomaC8LuAl*NzEIN4`+jr3+Us<(8YcdPJHf<4BUL=3Q%in^487dMhmfG&n zx(5;AN<+wO1_EkECqF0tkbK#~FzT4X3he1PJ3iC5u4usQ{L;oGG)%Hm3cH+6a@vR! zAF^wAJzE3zbgxeRRr}lA{pG8?VW!Rt46R!ZH!CT48eAHvnf!|v6*LZ0-{ix(@8>uw zh90>Iky%_q2tMw6O*a7q!w>#=xo&Xb2TBYjoqqZVctJD{BmH0C0_~;cFWRX1qW2`` zNoVOpkA*zIzHb)V=Q#WaKb1S{eT2iTynyiyCZNDnj%HVwt;Flg##=5*!b$zfMYuJNTjY{HVTB*^I=+^J|Es*Nfrt-b|n1DD|go|A`e z68JfjN5+km*XtJ~BGbeT6He6g^^L7ciEngn922nKD&SY@ITl@^eE8}YwE0VX812)q zEhO;M^k&qLAOoByznAEi?;yYH_fJ(S z#Av%q6RnbgE4?Jb{GKAtp1l2W4vTI&D^A+Gvj$j-2f5gmL4GF!Fsnqiu^=jz*MYq# zxgo}V{P4lU>n~PF^8ZCW?uUNeSXfaDhc2`SNnCFN5k!Ibx<&9yD z33}!4nrR4n>5Q2u(()!-JrL95;)!1|r&S*w4Eh2w(PAhk-@YuBl-iR>5>!W)q`Ib| z+yj0&5CP%y##E%qY83JmfC3anj^~kIS77m-io&U&qrAq8Fes>20UM_%!}*|4RSz3A z^BqpAA*b54lv;osXf+$$+zHSV%m_-X`7D&f_Q2aak46;~ymGODi0FcVcohv0BZ{G%&O~>ACl>2a{X*k=RAgkE##(cwq z*Fj0Bm2vnjFLXZLM4y2b{6tBZ@H)ID_-7j zYk7HpQ-G-byxzj#QUDG5eaRLro9+2bN?ipqKcme_K;$3C5RSzvFDH7Mp??JBTx)U`2-#!f}SJHeZzcdb3C$W zOgDa#Ek`@@<@WkpEY4@w%GBT;Vu>N9hMx&em`wwnm!85TmA$unmz(EXm#vPITSvzi zZlRTXJd;~XL`Jrylbh44S0|8x%j>!mrJ5@UPw)7`Um;-;8n?y800Kw@a;&k^`eR~} z;cf|g(R;S(b&G!6j_dX~+7pl?HWB>_HK3b}x3X_1?=WZ7h4A7wRQ|Zod9%!o$tt0b z{F;KS{7ax4p^e`~y?AR6)uIO6am`FCTE8cAZItE@(^j-lPetuMe3>H%gdexv(+lHv zAo_doh%6)ghEb4YYn3jI*mp~kq^R|@Fwxd3-@<1qR_Ywq-ckf648~A?aG=y zUR>47Dj$&FR0Q1EB?tI;VdrIz&qt}&Vx+aXjxi!SI6;Uk#Ya|&XuH`V$=091ZAh;A z7X!y7gs^4T2QXI{cUT?bZZEFV!iqcx{A8cM%EClDl%*&<8%7grwHTASe<2k2WazvY zg+_x`@`_2S7$;+5jBs6#!@Mb?3C;Q`yDnoFJGq|F8fpGPx@A1sM2cVZ!1sY@8U{#+ zZvbATudh1W=+j(T*&NPn0|cWWu0ui@F7Ow7Jhb>NQ4eY9nCLER@w$jsG;1pE$a>k0 zU!nwj@Djp+EMso^)(nv&FLYMHNNS>IJo|?|3ZPO~$hfD`H_$ZsE%4#A$Z6Uy?u^*+ z1^RW;jmZ`8-Ev%gild2yB)6T=@u!Oqn1GP`g$h~SA~~@>YQPK5=5E@fXa=i-!Eqm3 zDFlbQT-0!Jv7Lj}Hv}W7C{qsS%U)c5SnP5W;>>uz7|I{m(@96_Sg_KAgVF<0jG)zQ zS3+>EZjYcXN_!$66Ak>K@Q_2EB;N0CFht5%Os8}sZUj=|91vvSFilTfNs$lvhhWu; z3RQQy0`zYwvC|sP2KHoj%RocA2S$RiB`@C@`pa|_D=N1U{j?S-m|s|M%VbN;%8Xx>WGaT z#*cdb>_aGgK0`^S;VswK3MZRNZ<6Hd`}K4YoVBT3r1GT9Pj~;oUW--89-b!f)QSBs zPo4ia{~0W$t)IBoXhjY**^BJKs7?HIZWc;-B~44uo6nN^we;)q?hx>4yQyHeIG6># zd7duG4zzO{v3Co)M10Dm)g#JsUrXh`aSx4}U+(Sh#W-%^(Vw&5!^G6nU+!tBpy>J( z#Ax$$;SjHN;s@Q_?S+&?ahjbh%sc;W*lc0yKeO11hNUW|d zj6=GQ9roV)5Rv9&#LVW@?)lNvIB2UyH_5FgwIXp~omK(wtz!ywVjtRTVL9ZWPc(WK zWhO%Z{gV3P=g;|E5xvs=2>H87Vhz7jv#M6!Q@!o-%sZHF1kp;z=Q{A}ZA8G{e=pDf z$UFQSH+6<|oLr(ZInBk*ZrV?uWz%uK=)N2P+w)OFqu25cp$>s$PIYCRH8O5TNc;hG z^G_x|f4*bB=F^?)YKHDv`&p?p?u{eWNkf$@CH^u!??CWchgRT=kivQ0cndkab@~wW z@nB5^gs!){o1HbBofKJ9yc9~6>1lU{^gofaJ^obaQ=n7%pddT=RhXb%QEct^UjoRR zo^*{glD{hK0D8HuriD+uhqrN&?QRnIq{X%Iu|@ zv#}@%yjfy0YTMiSVVhXlGf?<1^@2L7|{up#`TH=VOwLsq7K|Gk*!gHS{uS#FGKk#t9YoS0gJZ^vNe>uZh%pEw!o~!&{}j%TIrF_D za{K>7-CIUg+3jDTibzR!cQ?|~9nvY?EiFnT-67pAC7ptVv`9*aNH<7#c-KbHdEfuN z=bZcb{lajp=h@HRICSo{=5Iz-2znO`x-_&S%u`u-Nm{IC?crGDdMfB%a@vnUeG?ec z&^g18^5P8xgdK>Vgc@p!Ixyx!=Wq-7iaY4zb(piWf>*&ov)e>4)}9YTo|e8Lelg{N z(9Q$2rW5%1WCv+Dx%s{tXKPR%H!mI|O)#T@e6PCxIPF=-k_1^UXIyEje&`fjrr5F{ z+#e@&WS3++X+OYhi~Fwf7pwM>JNCqao`z&|fkH!Z6d;zO9KA3nz9=?*Cubsqd5H9K zLLkqyPdSlsYEvWDaAnSIw=hv6Hj>J>t05-ILo$?#nICg3k@1JFahxL4&?>*>n6GBDv42rBEPa-)}O4hj1%T=s*5RMA}s8oz1X4rIbqdZ1D&*0 z0i4#^$v>(31vKNh1+H=W1ftf6qYF*Iha#?^EnuXf-+Mm{O`=J85kNovyy7R1^a0v) zm;QEETRghT0ZJ0hb@E^;lIT7f{wMoSp^lj&_YOy?oarsk`3Eg38qtQn&8ZrrcY!! zrSU;YICPGZ#OYY^IrOewFVAU#VaMG*uK>oRPO!2iZ`;%rDDD2Ioq$H)=1>Fy8p;;v z8vcv4f#Z*TOvfISjrT6l?D4(uM!|u#^b;+yRJN6KI6vfeP*G^~61wtlkw;w1Y(0$JdHqL)>S8G?7^FE;I+))&7mf#~i{}>x6 zLdBASH?N(jd-9eLnb#mm2xWuJjAqp37RbdYIc_8_0PX+fS|w}@BRt(`3`B-t3^eqw z>L_Df7`$qxHZ&0u$9NiSlzx7O#e&lUXn&_A%S)N(wlP{skM+w6YEGgkd32dO;uNWb zky{^sIcWNf;&^v(`h@I9@%bgw#gKk;UYqs@67W?t_(aX`gd(OD$EEnR=aY~~^*3HX z`%i>l&18p7y<#BBKbKM~r#s+48s+FSe?v!%)3!5j0imIAWnzSBn&XdvdyMH3l32Xq z_6jQ#nFQ`T^g9D+_)#zWH;>ZAMPj>T;?c5o-W)UyEGF2Njcq53c#0#T@^lkJox#a0 zGTO~OiMrLV>}_F#uilkE%=w=A@U>~zmJXTH@<=FLl-H{6>nq)89EpYAzaM{+|M;M( zzQSVi!Bgr#RKd8fK(!-j(y`sFzrCJiD^1~>nh!oD@XHHTFkfyo3FzMhyXa+j4<>Dp7=Yk4riJkdk~tzp6oX&HL&sY;t8~Z3 zW#@CMMTfkYGZPub48J;e+q~!J>SoII&*vt#5F#ZJHQNUb-MjpG9O?R4bbs%yDB2188^x}pn5gt^BT>AGPFxal z=%C_Q*6;DGh!VAA^)ad=nW4&GSw%+=eu`rRdBJxoK_lv+C=N;IoUAf>Wx|=lrhfzP zD>&Ak6JS7_dsFF)*>Q*VrQ}XR`U+`F8sqjDcCR<99eh9-9%3nk_Sb1}`M2cI-d0rb zLObV9zCDXJ!{(AGJA$8a+s>}%_@c|Gnn;qv7s}fyYAed$#|KkRL-Fa+>GOY zt|mbBahy~qNE}5_v32n#OwqoFA_(VbilZFkNuoB8#fIlhG)3EBt#d>$A;^=ak*RcK z&R9~ZmaeX%jNySLFj~d5^Oi)DNwm|&_oCCH{1NbrVtduG5?fMI%VfN-6DmqOddm2z zKS5lOfi-p?Pht!_ zMEbkc<_HEvxOa&Z&+K|Ra04{91m^!nul{3{Avp_4Td@GVo&N`T|ECt~M-Nj;ztCIb zyD-#gpStehVw6tf&J0m+m4KSFRmwH$PoND3(qdicI?WK8*;pmoKo#YOO7Y{VUg&GR zWdot4Jb1~;Z}qt<4b5G!c88t2x1avP?nDT7!&gB@2*O~5kf04_ww|e+RT)dQ+uU?A z%d7(-xw+ks$hgn{HbQv7rmF&b2^k@XtL_qmb41PF{W*dGoFh&^j72}mR2kPRs+^x* z@k&8wFh6lK59t7QWBd!d<$}`f`?F%{a(3k)C1-N+sGV7XLZ6?|d+W$5yPJ38OkYG+ z?jnM7#HEHBl{b9!6x_?zUcz61FiEg~ z2iF&rL^~B=#2o@c2DP`gVv=BkWy?zp2Gh~QB#2yk=^bo3WTI@41 z8GL%Tmq&Zm!jrR)++qHV9_pU74Hj<&*m6(mP-z`E#c>UIrZQT`S0uijAO7thdFj8f z8)R67Wk91>JSc`oxkVCJZa|p_f7Nq$UVA)$VRw~653xaY8Zk@K&fzNoqSq|LZJI3C zUo}2#ZERT`Wf9L>pSqrs0RHO6rb+PEh12Do?OlQPZPnh^&B5vZ;nNHj#muK!soRx& z!T4EX@4O~bt=D{#Z>B0>Ke2r}-7#tqWEl}AV*sMxx_~HX>w5cv*|e4|&{Hk?&a3V; zdQG9?VGEos<+vZ~%iJmy5qGCzUvghjMtxXy|ubb9NS25uvLKf^NB=mh{TwlhI9^X-_AiB1*)Q zzK#*ylp_6rk4v^SRhUAJze%&#i(&*mgg|<^uka)XtF@FQT|1nwVN-lS_9?fsua2Oa zau_Q?kQ z7}2d5Wypt$zw{i1S*fw$6)?$^J2DHfS!q#DzlfDe?_BMn^`U3`q%5Zs`)WlOe|5B4 zy19xnfhP&Mui8ZGH5-yH8wEo_;f`n@(atDGQlf;Y!i8pTLA3uTBg1%37#hazaiT`0 zr=bAGo5mSqUoj%F!NBy#w2$|hPSn!K@ZIH@k$+%{eX~w){T5%29}ki1T$*i9Ml||- zAfH%=@@xR?&SAjr{9CZ`Y+L||%}eUrY4Ssh@?3r|>=i%nKKE%i^3 z1f~toZFy7oLFqki88j-#bg9?_WTXHUMWdpErFa3lrnu6YN8;=vjH~wAKhiMdN9lNE zPF_z97sU#YPU<>%oG4*RYYW;xd*7!mJP(_WhEK@x9iD%SE+VTfl#+MiYf(>-aMV4L zOC5)duy57h$>63-q_#M{d5fcVR3CpZpOT2a3&|MWOpWTpBO>OO%QOhph_K055T(B+}oKMt>HX>>=qqorz7 zC7;%$QF=HUEpnwWZu7o==oT+Fl0~^3o`Gc>hiLrwAYuVBhzP5sJ@U}~zK}Dv%w6}Z z>!P3zmEsBeWZ7D-lePPS19dI2-CI+RKPTg>;{a8ePcgV#czF&yM_+|wTbv+^kIkK}ywt z;z9NbiF>lvG>j7w7qGwV^Ox))KJlBKKPhIALHEG})e_^mqQ1{KY(u7+^D6QUEw|ap zD&A2!-#O3v-=TO9Rp|+CxDoZZ?9S~>DZbvrwU{{)(8s>r(XHA|(p-6UcR{djmdaw& z8`cnex@S7_rt@_vomRoG7bhz^!#lZy_Fid<1e7u%*D>Td{wPS$YGJT(Hon2#WbGZ5 zv!eZiTJeS=qF66tl#s9~Yx8p6oUL`TGFrp&BcgY7W@qDb!WF%I&2ci>T52>M6}o)M z5r*(udla)&Sqnh{TVhj%kJ`mA)JQB2#!o_3N;>hqXB-TdS@!dcO#*UsIYfeFXq=1! zR^7xS`6#={^PZ<8?{$R^e!9mQ8c&Zvv+&6;**2)H%5ADJ`)BsCwRctKgof{VQBcW? zz$CmUr+!6;qc*%6e}6MMnGC{pTD4kN0P~vPc8bG%s6I&u46-gX;#0Q@JY!U`IwQ2S z3}fc9R)tZ|1?qA;Mmr8{sAom1*#4PJq~X?`#?M}{;bQXm&{7Pew{b|?|?`a%nQXwT_CX=rr|s=_MNmRCCc zYz_Py&G(Plg5sPW@dN_o8u=f{^~Y}Z7jgmqU>zGE7Z%k$a@p=>LZB<+-5y6@f%iGl zqef}BzOc`*yDJNg7sDrqq&6o#b!a7hj*FMLhe5@n9BG7YH`9{)SW zQ!f;;g!hJ?#lXV*x2D~6%h-8HLc*K95V{#CV8Yj2`dX`K@Y5!PwyTp&Vmyi$q5QGv{SOsf3o-kgKGV*rnetK1p zArbZKs*@9n;A1;U;1gVhozL18>ljoD?#anP|!d>*$4=PJF2goMiZe| zT6um+uQYX}_Zw(mCajDn|6DtxDh!Jm7BkG8I}*OK2m)wa ziJ*5Mq2Gkh(d0@mJhveB$0ca@lt~ zJXGC=wauf(u5xw` zlsW!SBB9l|P^dMbP{PIh0?iWwW4)?r+x-IQD@k+k8Kr5nbL`I6Of9iF@#SFPjh@mL zNg_efO9+eU?e*iQ?!8dux5z76EPze*dlMhzH;@ZQL~p1-tls`j@eS zbOAOkdIUO9Z6en)qqcZf>J8-lYJbYy+XGIJ|!cykvY7Ifp1fVBf#_E8yi5p-HDTb1}Snua2uK9aC|jR7-ck zSbE|e#mr)I4B~To?QskzV3t)+F!X#6dcq-QSppD1P%L2~nQGdwNICJzi`z){_1ozX z$?3S@T;b{)$2od=ZlrOq2$ipXc|q(!40vM~m;W+Wz?psr#tNUPjpS2G zA2hp1EJYVyvAJ6*SO$iDd`2^neb;dd?UR!v#9nCQRhXxtnyeAW%y(k_f#-d3`pk^; zo+=>T<%bD_h8K;EIaGG*8wnA_yc2w zGsIW{ItJugl&v=s`9Z}_-%;wlS5~Btp~;@{%Qcg%4vrqK=kQ=2+()BH;1qx3zgWiia9lVZ8Z(Gr0N`14!}QzS-cGe|z;UKjeFDiGn z!w7zwB%CEjtCi?b7~uBx_OfHQd+Nd7f=dwgb6o7#3#zI28!1SZFKnV=BP3X}=T-t# zN;LyKEVOPr;#iUVSq*(n>I!3PWbXs?Hifn^R*W!H2vaiSjP%$yw|l}YrOrggFa(l6uqZ9 z5_u82-Ent9jh}63BRUlbFb->pI|R6e?ifvxAR(R;hi#?HIqTZ*3aW@hI7vH?X)Vb| z{)d^glQ~G=={5`N1jFH?SryR=BhpR2_Td#=_ti?JFF_v?<$d;mjl*)J73_~Tn(NL< zSC!i^{Yk;hp-Cri6f6Sf~FC3Ms2;jQ<|G@P>hPk9 z*d4Ac-+sCjNy{kXc>@PmH|V&g8yA>khNU?U)3n5S1G+!Q+Y4uc>eLvOeCYXD4+f0c7FN?@sJ$fXlj+ysY9p61046&McU`&zkP>2n@EHlUT zlRB z?9{2zy<^FkSl<)jp%bW%2}vI6M>*Rjx}DVaGEqBX(a%QDR}{X| zA15e#^8*~Gsl?)KI-0Of!$lsmZ0SFf-cO>{O<1vFB`%EH>cl<&)wyCOP4E$#67(k)$3V0>bIi_2?TJ*_|b@a$-B z>~tsTl6zu3X?&xACV=@>Xhu!$k}{S? z-&ntj>ym~fBL{6S*WUgF(B38f(hwxT#XdkWHjEGbDE!PggEt(*#i#29F1wYk*W~+Z=&Ank6vxTnzV^pc_na57 zCIU(W>$+hgL$w7iL*#xG1J89~b=nG($9tAuaHhpsMeRI&q7fD{q}x4U3)^2a3~=*N z_Z_e6al$KYx=o9pp4e!_Mw#S8xV+ug>$9VRyv)iul%NdOgVbArA-D4?M%f0J8nWkO7UPpRhdGU5eOupxpW^;tz+}JGrTda{NM^7eh{BG0xG8ol zR1^KE%}!c;3VNuVr&_>`F(xBI7~~yF3aAzE#-V9QQh@7@HF95zxB~+ca-rFEIUR zOS7+Yt0&q(ewfq1`7@oMgr~lAC2Uq2r8$_T3|MDeId-OzgT|;Cfmacp&R9Ys8YSTC z_l^-;23((!mwB%H$f%uEF4+sOjVmeSt8^T~Qa1)!jkJ;8zJRCuE-1{VQtGaIK0A^S z(DX(|0dE$MNA+Vho4l(}!u{Nw^M7Ii!vqwg%sTG{C@HSLw)Cut15?7`e?*!zki zgldB^DZq^NG)@G`eoOLM%()In`3FZl`9e2k@8spfIqsI*uI?u181iT*%YZj36T2iI z%^;~^k2B<+E5T8ybo>fi6mELr=wW!h<`x@A{#Bk~`URE!U5r869Y*h!`?yNbJc8HFU%H&q zWIYI~2S8B0PP5vZ5Ny}4a;8|-a<;_c$eqSkP@87(Y)q1NM&t~-?|emY6vPxYEL zX0lB6TX}+3XE$CA72C=c-VeV)bQ=b%)*4C^f z7yV5By6bVZLPuo$EdMW6+qc2LOiqQ`GV|vn=cdL!X8aPx2&4=q4BRGshEcR7m|XVe z%&3Cdh$V#Z!_Sx*o6p37XNJ+DOw)NWOBHlWEFmD|rU8T|cp+MUBk@iBaj^0H=P?PTh64y!U;>NuM8b)IZ-9J`MfypM?ZrGI$}ZG00oaaWY^EQ$K|<2#f~1-3hgqhxbGRAipNj162gS=5#%nj zbLF;qhuJu{@Csh`FihDLtPgu7%CI+hz8m(ia$J1U>#(XScfD#{eC3=aVH{bRO~#Z? z7w0Qt%NJ&q0b{hHWp7 zihL`=3NMopAziHD0o3ix(&vcqtvO$cIOACwgR$gP70NSlEZYbEAACjJAkS_%cywN` z$ji15o-bwR3q2L!%Z7&=-;kGl);GnW(u5f*qAamTqd#kEh#Np#;5ABXDqt(~juBJ6 zRuK{Gv#mnFg9pW0-UV-yyU~`=W<3(*A;4WH3!}>lO8&EGnYH~GE|S&X{c#8DUR*ey zTM_edYOs0S!($~~xdr3_G0ZW+%T!6?lJM1>qFf|H;^paw26#$x*ZFRnZ`~}@^p*aJ z+GaMtjbw-aA8`Ipy^TDumXN*o-{Q!P{)!_PUJkO0cXg@+Q8_mjXO)`wd+(q0>Eh57 zKiKrb?evyF@M#_t(35GZ7W3&Z0X><~-QE04peL(`=*fmOKDv~%tV~xYLbT1t$gLdr z+U8P|IRb^9O6fixDpPa@`e&Y$@$1AvcKGcVappSRd~X79nTsFY)?>90S>ErxU)JA( zz4s$ys(gpw2i?+DM{e_0Vw&jNKWKQ(EbSNNmc9mYEZxdeLu`%Q%ur6Av3WW8W(RT*n2l(xdi@-8DsNHzVMBBDulT2brZf( zvv}Xy*aT3Fz;yBh0!vc2Q52cSvv$Z^SKk z;-W0HZqG|GPnP*(y2Xo8G{=3tI_P2oY2>lAo2J@+q7XTmCN%7*SI8%dIhNtLbU77> znyfxuj?EZStN}0Gyvz>G#U@OeNvd_Y@Ee!?gh#J`<8lt1invx{EMsFE0`2)ULae^9 zW(ILBrcr|^$^Y4N&)cO5gZQz>hYwCO{V&5S-@j$K!pD}7XGs-rmzitWXD$~_VQ0`f z((iT>L?S-h-4*5*k{?@p)tVkXKi6NeyBG63bFgA#1CouqF*DZfLwo$vGmC{qs7*nr zm1SXd#(pNNH`v}sVT@m4IMc}>>}EPrWQ8q+@M!ke;jiS|DH163 zfhb{Klm-fGf~MwpNN~>z!9!#NxytWs79%wMZUi4Oi z7>?5XwrKPjJb{lof)98Z7Ak^3pkW*`boE`)Xj2^b-8OiWkVDu{1%)F`Hi@J_k_^(w zQa3E(It)B&O7JzF zq-in#6m;=gAZ{GrNJ32ZMNy{l_Q7U$@@ZdrF|(7qbgX+#(R5??qgdl@*0;3gUe(n3 z%;+Mq`Rk1IJr;qmRNdo72+9LjrjgQmjKQ(v83&%m&P5%M;*7WDkl8qQ;*__IdE@iX zzSM;XBdfpAr7IX(MOCd4#Cy-2C?>NVt@{N2qI78{w=g-ZkF3Dl>!~aiShtQD(e@K6 zgDmExr7DRtg0-fY5jzzVyxjY>ZLk(AmYR>kL{Du`;OS71jIfT{J@8$!i<~!K=4vF@ z*eex>w6vqh5Lp>~h;Ruf>9OYZ9Iv8w!CGBJ`(S!-cd4TH;Aw&Ff;rWe*w>~|j_F|9 zg0Kot@H>v$)F(H5I(@um@YfjjAG3#kpO49a0bqLdzek&M{xLrOpRt`GX?%7}i8fYQ z9GChhLB1Yn2HbnW!7UIRkQK+{s6h)Z_V0hcW89CfmSE8($Z0~4Bkc%zBd4A_mv}KX ze9GAS@8I1~0?)Rq3nMorcZ>fRyvtBG8moOVJ~wibI`)+$))rSv8C#bA8OSpe2)qy8 zEdspv@8DfB@3D{{5ny_F&wC4*$esb-TLbXk#*|uzwR`aeY1l`CvGGq|jXU%nQ05T` z`K-tw6eK9uApzAd+d@Gb91fWo&ZzBO94jRf;JwRzHPvofW4_#UgjH0oW>oG%Ij@a& z>jMW0P6p5$EC*R8qT=?rSr{BzZ@C7QJe0&S0llK&VV^O%0EL(kr;elboZi!SppBBgXXL4kG% zDkM$_OT_nNbI-_-hShAhub55Cu{Myj`j_-~f8RwzNN*5cMt<<1 zPG-9o-t-Yw%O)q{gk_T@y13o!kJfzJfTiYdU%%s>8DGgUxZi2p-5GHCsBV zo#lM4d7C7zcd;jU3&XUiT!?&7Wa&RVxfo9UWoqS+O1TgGWGh6z4Ecgg;7JyH-pig! zy0G+MBT1Z!B#ht1{p~RYIUgc_78&#Tu>{5{J4}5KmAXOxG;T1 zxUR~>+&~_W``gnmq1ayb+=EuLc{eYIoYujqsMxpkyK!O zjAh%`uX7(h=hK@wAB5+PyI9N9sA(?K!m%wAsU~dJQ{A093-qx)O?-`ItKR$Ea~Vbm(z!|!|05;H zIsENN3Oe`X*<-RGPF)q?A%DZF$^a&aiY-(HQ|TJs?_SCf2I0L^d*w=s>5eEiQTKa- z_ybW)goWF0%;ZAn^ zxU4fAwi&xfOs+Dyk1sz1!e&wgi_j0Ygiv9paFsaXv9MZ+L0bIyP*Gwe9Tz=rW9!f9 zy(>cP|E}BujD$jmFlJ!G=&OgLRyjiXG1E)!wlT9ID1JFuF6Tp-ojeV9ETxh1duSi_zILh4v*&Np;k^6=h!vMibgu)Z)#% zqGN$^M+60Jc3IjZ+Bf4rm{hx!YRN>aIyhG`f0E?|0H!FZtnfuISX4o?S5a6}|4N(l zCGY!yN7%Y|n-7j{h}x?Ujznq-?L0P;@Djvp=08-`v=DoFC1g7UrX5RzLMJgXQhiyu zFIp|qwVj#p?_hmeF}s6Ia%WlP+(#>)RVL8Owxy_cxlMjddWeV0yfsc+_K#S_@uUZrzySx*kZfjZn@Z0z!TD_1%-Nk!<71xPQ$mYmsepDpW2lM(DCtzl zJ7$wRKVQtUh{w;jWTIPol=tM%1%a9`4njCTg`oe5(D?aVI0X{eWH$fzh$GHF-m<^+ z6(G2B!3ZL+D7lwcO#Yl@qkd7vR-HjTGybd9L`*RMyQ#$DqaOYZfnJv5Pc4|6_p;U{ zNESIn);fvheOH(Mw|tG{_BY|tB%omrdyk-nLHv5_FvyQvRGoIJP~gy|3xjA9tdQu4Zap?M}jhkCtb2bl_$XH z4DGx(x|TSFbw>~hgA(V@gS+WBHOQ2sDvT;8t0Hc z>L0!HpB2JL<#R509yWoBvVPAXw0ZmwtF)xV%8#JAzKM}W#V|fuwoH8H+dyWx!w>0n zc&vqOq3rz$v1pc^G%AApc3)fga3qGdaWVbci?Q%v=wSZ;#n*N~_*(R}2akJwA0S9a zx@~eQ;U@^5NCk|Zoz;yY^w-p=P~E6OXHj3R>ao8kitcpyK{6Dq=iz?Ms4zDg-+kfj zN_6`{UJtvs#;1xl{LX~Gt%VBmnBR=d$9B2*T5$c3C z|6+#Fn+*Ck(bW^PW5r|y>K4wFpnEuab#Dbvbi}^S@Aw*J71Wg-Q^eTf3ubvw*quKi z+qBrI}JDmsurYhyC z?88eu@1^@b5{_lMAi!Yk(Nc3HRPtQ(DW~$+tv6Wa8{E{R{|g_FDtT^;EfT#=UaVAN zaS=Z5j1ptp>dV5@Bt0D%bw>O^Q}4GQtk7=QOmq)zx_;yA&llKA3#JiTDW64Y;o3{F zZOLR=t)S;;YPl<3NJ;3|V~0ok8G)JF$?C9LQ*@t-cLAp3g7!-xgrL)4fP~njA23Pd z-anM58^vIV@iT(WO+LwID$>x7=~MA9z+BQYK~Z646vd3otVNiR#d@mMG!joPP=!c` zTTcd1cQ)91Z^M_-s|W$S{u;cVBscj$t)miUaG6E$pNOFvxafA$07F~;2ZsI!i&ro^ zIH#-ED*tJBG?Ak(f)r17wr{(fQ68mq9um*(Quq_DAAXiMS&b1V45#_(?UT|=U{vL#;Bu9b2o4fsX06MTn1r`ouTRTGVtfJ57a-$;?qyKFkmId2+1Mx zlS%*VklJvFHEc0NGi)u$ZhA|rQyeo}`n*|t?L)WmWytO2fKWv-&vbkJ13HZ)S2XPK z3WMCw%uY5Sqi9O=e6u2c85SguoBus|T<=fvxcuLf$L|gx$>S{?^3^x0VT${${kIl9 z+>ySRp-I9NrJ&yNqiL#NAXzAmPKH{2HrQW&yv1q<8AZ$9hEk0pP-h`gkX%>y^!#OR^-lc=r#K_L5 zk!txW-^3-<>6=jB*)4FwK0k}nT>I=yU0BTqp9#ayVtp;H_J|mZ^R1KwpXW2!EOwDr z?EVc2I)m^vlU$g~5a~1`!MWJ;hC*x-=(k$%b z4RyL~yGlPfv+PKg@AOetPyK9>#VyFu9AR1z&>Z1XWJ#SqOn-&Xoku*^{FWl!#e*|f zLIf_Eys<3_Erup<2y=c%`kEItBUC)#60ZdT)saMAjtaF=efJXjTlvrH51Vq(#!qOb zH`PPn_W0QngjY4HHZa6p2HHP1N=r{4o5YY&y*d#$gL3YDX;D_fU)2K}d9paglu0<( ztw7}@s-vhz&3nt)KF~GBQ)ZFqnfK!JH!Qm;(oP)=w5T5S-GDAl!@T1QdFzET8iS&W08a>jRz@OE3nWW0?tKRnI*1b&K0FzZmP z$Ms-QtRJg>qtV4k&6`UbW?Yi`b~4t!7%39e0JA5coKi}IB&&7;U4l^X`nNz?=KnXNFlmr?Ui2Vw&;k;GaqOx{W+ z>!&khg^4Yt9^{?!4O6Qp^4B(oxKF+q2ERkc@xQjCDsz?$Brm%(!pXbm9FtXj8vCWzLc2FosE z=ea1OO=B+CsKEZBd|qTOGVx&0^bZH^;OKZtD?%J`4rDuU&-r~ylfDu0ip8N93>TiUm{2)v@B+D{f zfxwsrqIz_pv-nfiI=-DsG1ZBf*OVVvC-lseeqqyM{^BOj^!Yv>p`hbj#_iYI@jwOq zb8q<88l3aZ=*exqyjY*pyZFT$-1L2cmdUFb79Z%c!{pW2N`y@Br$y^X^Rlqp-r=)# zSeX)IR{8^ia)(><+%4B#-32ZXsllc{H}GW7V(ltwobL>fcKgg9({$Z;Vlok+VJ z1WS`d&2&$`bku}gR=B~x<8A_^-vL#!!uayRTJQ8CTuhkO34Ta!K{&Ot+}PO} z(IbRIR?|m(rkR2#{8{pL(Rx!;@(b~or#GGDkE3~NlGaU^wqhJ!?=FcrO?uDW-JDK( zc_T8U-%84i5&!tLJybsrUvwaG@YG(f=fe{^S9B*B7DmQ}uhKzo4h+ZH8QEb06g+=F69t`|+KO}Z%&R;~RUlUOzZ9$6_j3*U%Dnl-Su6>B%anXpnTX=9G`Q=>I z)l)6D%Nv?<6icXR^~}8qbvMb((wk!S+UQG+4E|vBTk+J<+kmE*=gwr)ik9OoVcBXC zQHeRZD)DM#3u(Q(8NzkJIZqyT?jAxT2)r@>7(}0%`o=qZK->-1B}ZCBbU5P>b4&nJ z?~4kW%Lj5=I^~2xXaVkg(j3hoID)p80%m9eYO+=fO9TTBj8olreu-j;>sfz~oBqd8 zgC0drPS*fDzF_}%@c846(gXdmm_hqAdqOW-X+q;-f)VuK3-I*WK%KBbgT1*(?W881m0`P#pKd{u>|9{Nk7 z(*i2-BSk7D9^s0!#lpYIK}`e5oMlHnG^zjhoW+J*hXX?N$jz3F;- z^YDj7K4-_sJ9;V~w%H>Rg={8iA*d}r<%;-Oo^u*nu4nhP4Mka;C9d)fWr0U`A)tyY zN+!n4D!yBlzxAg0wL#+xZfvJ~5rjAg6_D{u0r5s@`E{)sl?0+M0dLg3LBC~QuQO7B zN6WmmTNROUu=g#I$r0&r4PWenh{OhISA7pXubO<&NpDvrBg#WQVQI{KI=tB?Bq%R; zxao&a2SL5zJQ{b}9O*bEEX2LtdqR2A%y+Wai(yV)W*N zNS1I^FRo1NHTvxitM;)w!9@JaYD}S0oER+B%xQ`ibWIH;UL|OE`;=>}CR>UO)*VyZ zmpBkpNT-7(D0=}vI$G4#6Hz;d#P{Wgi@vLc4Il?u}IrK0#ar)(C zCj`k6urx{=cP7Z!Ef3#~OOA=8OAgYt(gh%AU0L=lx}fXZBfSW4V#Y24&#tkES6Ws6 z>SCQpMYw@Umy&4mqej2oFjt^Epa4A)Mu<;VwP5lFJMyM`A7A+;4|NGrXFd(e^RX-s z>@DsfPUI=WPG#0z9&q@)NwIqDG)ykgTj{=x?<#bH0JE|ONWx3@G4$0;iK{3h&Th_w z*iBw@qhJ)DcRDW@1CQ%2k8vqgzG z7oU;5lfCXZ=IL74I5!~eg^$b2_KsLNO4nmkg#E_LUt#LF-Oa=|iLt`p@BNXDWcczzPP3o!T z_?sSzLGd{)5JT41*uNWLXFw!x)%x5S%@Sok$TZpe#f*p-l-dU0;ESVnQx*GVb0CbR za@D``1krhA^im`K@f|@%)Wa9ciIy=DMq3Mf*HIR#6>$~o_Bi;DG(<-{l$>(e4dbOUseRy%_j`YN2AfgzzNUro@?k9 zJ}iAal>88q~_N_4O!yqk@B!-ei_g7eXLY3uIG4 zlYR3M%T`2r=;0SJN-DEVOJ>J)t_~H|iza>;=q#{I9Czt;^yvREhTlMiA&BG!nN%as zUhn!rDh!Q$@({jNqhN|7Jn?CJ{W|b4!v?+i=t0z zlGle>b2q_^q=TPBwS%2h&0BNk?t09M(Lx&wZIg<#>v}0;uipG}Oi!{Bgthj_o9krl z#uqYv=e5)E{K6QXq>V_ejfl%W*ogf$SQ4R_@Cb9;X;YfiRwzZD^?H2Adb6ASdh&<4 zJN^l+DVVDWY$_Km7TR2NlW$r$UegB5^=1=;EM&cQmfF?RJ-qPj1v}X5bD}S*o7iX3 z!n3?TvX+YU_Hn|qvt~Mq@#xG(UCN|p*uRPpkhm4UlB%Jww4v=GS3!GblOOMUdl-Qp zRy&@Ql1SHtA66Bj*2VQ+EqWscFo#L9wsCYnt--yb%I)3J@!Li}+`#}vpT5qy0C)ZR z)PfEBU6{jLN!g|B6Y!8`HKX(rTcqB)u=oJwr%t84p<-+~TC^I;yd?^ympB|pux(r7 zl{qh>O)Ofdn{7tpDztbKN@QELK7`!vvMxCw`ui0opP171PIEk|&MPiiO|J_(k+U%K zf{r4rIp9A9n97Kbm-f^4rxw*dEw-v0EE2ENfU)^|K>yjyo&*dDd|1uA5R*XGiEIxx z!LFZI1=AZ&TacqhzhqHH4ie0-mXZUZmjDP`J*X}YKDsT9eTykiiBEyrOBi9M2zbb; zSMPb%s9@;upChi5M)9%*ww+$^All`SeQvx|s2^A`6*1l_9mX1(%O4-`=0ceElnHTyBfT0{f;-mb>^{=` zO1|HNeT1^*F-@qx{S}&eHEdVx6FXqudzZhqQlgs5_&D7I2Sl1@1igXEdS$tiW#IDf zkqa!O#wTbjX5@E`52XGz@Y56iJV^a(FO7y%5TyQ<22%gZ-CTaKzj=W#5;2b+ISQ4y z)EMq_;JFU!UpLsFCz8Y~;crb;cZ5rzzn92dau9r?$jb@K_YsX0B#A8auH9}ZIxfX} z4zXM4I3E(-s>pihiC3}=WkZ#c_?~7IC&`xS0d0KbkRCJq6Z>tNNbAX%$V$?EnhM(| z@iH+5q^t@(uG6+D%Tl-TRmnm&|t?C9!oso6{f$in`eOE*WwHwBEu zEI)IY!?(N|n{RFfgak^n;=6s!hQ{WzhQ~nvYt8>d-CM?0wRUaa(k+b(q&uZk8tE

F(}M2|=W!8%aq8>F)0EoeSN2dp-Aa-Ou}Ve?6IN&2vrGZ>({SF^>O{U#8Q< z`!s&0;gU3XT*YX)RsBaFk+`Z_*TE{+UJ(i&O@V&Dk|`0OWZm9K|ITf)cyYnK=N2nc zdfT4`>!DWS>~U#;iu^5Kiv3%@LTC2KqYEr-^dVx;10FAbkxD+0@N+DWCa&$TZ;OuU z%ye99<$fa)PNF>rGS6|V!QF|(!TpEkkkiYL_d9&eQ~ks!!IlUG-PekR3J8in*}3oB z(9epOl|VGmvgQcnVDHy~*fx$}0Y=h0p_vFQM6Hk7-ARJuM5*+=yAb*)tlDS#42%-!Db|nMY;{3JhynxMu`li&lgCf% zCS`X6yk2@pVGF4r>T}q7rlwuw%)UG7NH2lGNcF4IncQtQvP8x>QkgtzRElLF|3n1x zPq2G-?$+xXaQ=y)FVtq{YT}+&aJfYOHQkCc2LJ-7+jZ=Nofd0d0jI_I#CHyds}Tyd zGe>eu@fTKir|EKW$`ui1R!`QBO0F-i;%zZ7+$ra?0Hz+eWo_#MJ;XXvwI=!g z8I<)PEAd5S{7<8HWa83ijuc6C#;12r`G#Nqj)={aOe8T_uJgfC2UoM$9dY$;pe0n*cQe+-(_hbH6%1WMiDT+biAC z)FKR~G3AAg6)`KTIntqjIPO!lWZ&bD>auPUA`2uB#1FinaU@lk_hfl_xHqxDAKXH0 zPrb`ut>)iCXL!Hh^&JZ8q9hK+18eq3Z4;3BjOqCIxdbZtpb!!%*K7e3>z|iLlh^Lo zae==)M$kzj;i$(5S~iz7Q_Prrdk=$tcxZ9^o$szJR)`(HhAgJ!G+(M3BksY%{tAh7 zt13uZuKR}ci7-TyRe+HJ}FS5;+t?{{G z=9WNHdT{ook#xN}yO;I4XkT$wiz@qAS-!j$3d^r1NDBig8nl$sWsLPiT`6KpZ-lM!HVhZ>RhDE@yII1*+81?i~ zZKRH0I!X^#8!@|@MPPl*!=P2300QZKZ$bh%kSgAPU(G2t2 z^4P)=jN`R-$4}YScYkSXs3aqsfKnYS7jrFKVS8=|4|P5*F;k3 zpl2i|Kn;SK>AzP$|5gJ1(>e)01*qJw71b2MhLX`UQOq5Pe|Jt`<5U`j!rQy_?uNHb zu3a%u+>L<7HO^z>TH0t}PRrNFb8(0TXk1%K;(f1y%uel%et&tGBwl*aWDGQ}Yn$3X zF>4*%rcHwz*HNF23gaFd*PFX?%t}qNdB^$05?(^CfXP8+5tE^+-IpwKKKSW0!aQ{m zify)A9w zEIZC0 z-x4WCU)6U;ul3=MCRLMa^ECcreruz6TOrmWwb{34bYrjuMDNZjO6rvkDsEZHpTEuj zfx#g+$%vR(P8!@R=-%dPwgX93olLHWQScRtu+2NMFFNAT97+hV%zmxTu)cmBYKBM} z#H4KrrTASi>H}%V{wO>iIh9E?A79#B_Oa!8$_u7EII98>X)sjoBGQC|N5@l-_{LgR?$U@?bSA-Xj(!)&)wGyt@SJ8 zfBus-l&3Aq%`xEz>J;ukm4C`Cg1|0dZ~11CQ;GK(B$H6Rzn=_xm3Atg)_rIm;>EKu zX?NGNec=-p&qGj1e!z~k#tdJ!F2a$M@sev-Qu)7}OZqPqm(~>qtrywtkG8sPxyCd0uMu&dii?%njawZ91 zEHCtYk1D>1J8O8+R?_?K1YhI>5K-^$Q75Ih5I5w7)F%44cRA@lMPEJ_*}9RLz*c^? zt*t=OHNK;&5)5 zClx2y1=4$JqqfwQT?Gp6z40TMXOFSP*oRY$XC#@XL< z_uWV4k4Qy%z9PG9EK&jXKx-zH z+2{@hA2u<*!Y5k16T_RV-S6Vq;!tQ~I>vmFgQDZyWekL9Uiq6N4sXKp_3Kg#W2}0K zmW}n6C?MM9rgicu1|bJ=kTah+V;Xx>2VW`3=4PEev0^$S3H|Ds#cv;|& zR?5Uc5J(MtH1Og^gE&!p4(e3L)v6#-9O!b=0FUSk3BQVR!;_ns-nuOjjMc31;5q=% z7=k*5wbLj{!~(jB>24@K%MG8Kx=Uc`4z6*GXSe}&8O$bTlISk;`%a@&zt{K*QJppf zfA5IkkHz2bc>rKufL#I)V_PKCBOGl-L?dg;5ume(5RHS*!TX^F@5hv%QLbGFwF6nK z3TurSe&BW{A)+YFWrEb_q<&Dek%2UdxtdeUMEjij85L80t^EQ{mF@dMjMTQD~0?K z^Vx{U#}aA>d`FIRDZyL){Yc4s`KGQF(j!sXAOBClbM8g_{V&n?ED61Kk8zCm<5z*p zkIv6Qm5jK+2EGs_kN1c9YqK<7B_JYmVb78xTlt&LWEGGn!H+?<1DdWE+IXXFQ#dOk zk&f}d%|BL(LRR}ZkQ}D~-2y@|Hm75LcRbgsO)qO(@ui1G{rrix9t- zJKWtlaDxnhQaj?C_d%OLsl7GZ>y8OrYR3kb+L^g4%dI{FrS=t|)c&d2SD^4w1GYO> zn>NwO80Q4SWI?3BMmc~_Z4J!*qQumy05m5JUWRP2e~M`D-=R2~myl z=~r`d&u*StR*ikngQyT(YJV9-#T|5fs`g8{F#DumFZuNRSE>C~)51^L6zX3hFcUxo zmXNm`ik+)b!KV4y(2UwMb@Id z?%IeCb|8g%YBF)O21Ym1{X#c>+0bb#a2Xl6y~FS{d9eT<&qWopco;^gh26#kOBbX{ zBOQDK3+2I%4`;atE<`$;sPo<~*S8lp*Hw#^ zJ`Z18zaKuxp0A%QU;fOhsvkU`DCfCTx{%)-Tshv=KWPvc@!9bCu~F5=S9oCSeRbjJ z-Qf8wQYoP>PcrP}^%?!E!k@WrDe?Cq$z&@Gl+m{jwV`UnSy-weRH6jk@ucxpuhukW zm~^7Ms6@Fur6%?Gw`-%0jqf&St{=7=Q*>MP-W}iKekB*B0try?R0wQRE;dgtWZN+3 zUZ+muPT*`)s{lXHX$e#BAe>tAwSB!_b@l{cuAtGX>e!*sPNBaVtXNKxoU zMzT~XYwbi#PY4rJeD=2f(=aaqDd`JJe01*{#nKzZk8Vn|VI@du6^;uFi)~oXFryk? zMAjFUsCdCl6{uhVFHzew#+o1@HE>uyjTyNu1QF0-qQ z@`c7?+DUV91Gyu!;7P%I+sSA#*vIu!i^_1_bXI7Oq)n^^%VQ?|NMuwjhWw1CBE4)Z zNP*!%4$uz?aWemHJ~Q0)geQ)dGWEb6A*JFZcwP~ciNvw9cqUA;qreoRA)CKo%ObFk zi6z;U#LcF|2;}h>rU?j4L)v@=imPcIZ&oc3`C)C2NBD(=ck(SY6`!EAMzmF&Z@H+lpRTv>ViHTJl$=-p$W&P`21E37pSk_1w^0f=sa`TsS@jFF^ z10D1^`}>dHeg&S5n<*2@uSNT({UTyww=t9idwkMUx~|m0M+y$h8Ngx?Z-Eh8R$MTw zOE_Amh{lCE>>3GKS8HgJqMX*mkpjYU?uPKH+YE${g&!`i7EK8U#v+Zx)WEO5baKZA zMJIRR-Q7v=KJm(q5R*yeH+>mMD&eP~Pj( z*tH}8*g@_SIAHsqJq#@eUE^3rN=r%wK!mj5=g38M5|iZgZ6*O&buIbNRo6=Jqj9nN zy$NA%OyJRwph^OZ&#eF4S;Pg&{58Y@tMNgFKN=zJ2_8KODlYD@rX)|lNbk^*0?Mxs z=aPEY3w{vfM%}=2ixGOKh$@FS%U^E_d<{^i&H zN^fiRfQcf<|4v)x_#a}!m_w+I1_VTn3TNzp#D{uIJ5P}gAE`hO->#MM%`P;G9n&P)(Ex5hoP$21!1US}y zzj$=4#ReQ}d9h&Pl16vs%xW-zal{dLl>ecq5g`_TRMdQ>C;dxNBl?e`#?D)x!UXJC zYv%`ctR37%yzg0M_62>0kRKNZMV-EA&F%SdyC%xGkyK8YsK7I}s~VUz2wgluD)LpI zFmrkme{bmxn(4I47Rd{uR?jF*Kv8qu^L^y)4>+HMxJ4TDz4xpoPj&(4KvwWiw&nw} z{xSC;@RKcjpXZ;(Zb%34N{21xUYp`=xV@G+w0HEpl-=iNZnb78=<38)4<4audAHX_$J}aWZBBB!HyjZeK?PB;p1vM)#B97^uAZt}-S6>OlZ+Dq72lQ$L>|@WeR~_Ab2p6E=tp^j=wgWbURgZS0(0<5%Sz z@m%CH>I8qnz}I&w$O6y&yzzGP(Wd)y@b68>$E#u#g0OnR$ghahKNHCX3_6^R* z86EVl(LiYL54L!S49~lopFM{R^kyqv(%gChT#k^G(+kNRh{9qH=g_jQNQZr3K;0Ch zfc|m~E2+N(@@agMcttJs{xsThjtfoh+S6$FC?Rp<2TBL2a6 ze@$FsPgrSg1L6__)_<+_ar{>L&HXVZ9qgbE)cW3w{f}Co*JYF}ajd;Rj&HF4{jk7l z_WG(M+g2jYu#x7{7!s2{Ln4KZ3k)EFW*uZ252~dwGaN+pG{zIC)3c`@rG5Xmg?nnXR;Kn5HfFBX4T6ciEW(F-e^DKbC_j@1BAx3&KT7m8ck_; zv~qU7SJgp)N(CtP`TqYc_Qe3jzQMnXeICP?>x_4S@>>#3RX!M$GM+u!jq~kvwC>pj zw){1DboAa-^aOf!TC@U3HSItB2ATaqvm_}!7NDR@j@IR=@#{6wiliV*fdMhv0_QnM z8xBP@6Ena2sd1vs1pGZ+&39Pu5$~`zl)k5sT z>3Ui0R3v!3yvOZ^ouRJ}h-5tv7p8dMpUX^qh{`CdwKSAI8qemDvbsFy;&wN5Rml-U zdW>Nj-~?clXJnKCjPkL5de9dDqZ|TV5B4+7c*}dS$8<5yhAHn~B9Da$?!D4>m2!g%Exh)5!RJ88eLGYB}y8aEcQNb62cjR=$GWOyf7J}Ga zqd^L75i)@|!UfVVpV$ectiAbu`lzwq5T7jyjIl^}!f<)A;>|>3%kP9N@VpaNM(8D) z@*2n`gtk9pUoXKqc%Cjd73h-WpyY;8l*%EIT=wWlhY(YS5Enx6Q4i~e*bdBL6-iWe zoNGknT@n|hkQXF4M;<0B_G%ba4hH&sryFKt?&U@A<+Dq9{-o6;AyX`mLBz~m9}0B( z%IpWG04tN5VZywztlr1q`3H!Ir$ixk@(px}zQ<(wdt4TXr}P7U)A};3^0i&I@(tSw zxepOFJKu%*;-STCjE07n zx%wrAtVf=P#pZlJt&9z`v?#g7>J7+?_ha?5 zm@T$DJY+$TOPs7>BaFG1JN3GD@HxQbi8&Rb!#I>evtbT zcA91e);BLq7UkB!1~LIHjw<-4BIqiGWRjDFzJUQ;T_P2 z;3$aW&XAS&?RLoDc>3OPZGqB>%A71nE-dmJlZysKw%)MGK_tvMk%m;}q>Ei9Oj;#b ztor=(O)pR0e~f!JfoG70fr?)s$sq-rBVj^MgVS-j&JV0oHTJn}FyqgY!};Bg2d(b}PBE=QhSUf_zOSV`zeSxCDIq-)ESrd= z5aFgj6}GmVmi+-0a@$cL=(7Xz<_KU&iIXEPl6Za@LOYN}pqt=4e2_S{cYZ5A7NpP< zrcw;0P*g%JrSAu?#KYu2P9Fr%=$0;w#kxLgY}IbhVgF5`m_0e#yfKIC-Y- z+AX*3B^KG-p6ittvU@FxfWuT1%o32AnUOcKBoq-mZ%?6;TFtsj^&KY5|G{B_$cQ!1 z2N5ws+1)_ZoLJU=6RT*Q!5--LdQEVbsVJ4INe@_eEF1F_<96Ch#(a2D`pxt2`1b-5 zcYO^U|1=i0ZLn)9X6Rn+GR- zfroVG1b{Y<2`wonW~%IciDv0kS=%2SUU1eY0dRN`Ap!S{;nZWjhlXSZ_tjbWsl*g$ zbg^cGGK~4A?l$iiRNP{{m&L`yydBE6?es*_}}stIN@9X@6d!3AwXA`*bKOqohH2*v%&kC9!vQhz&o4+c!v}) z-XRbBVks9S`MSCMW#M*NVACaeA@V+Z2J_p2Uw8*UGb0tNfA9`qbqj!Z_@!={YiFfx zmB&cUQa{E``hhSg$29Xo%TiQz#pmmBiXgdl2;~4qkljL$OLK}xcJofpkMSw0DcZ<0 zch!}3mZ&&hX}gA$;9~Z~Codath=+GE1Y%dVcayp7!|&1-{SJqE_-@`O+;x}^wsHH{ z{WB_))b>st6;$&UBWYo>3Qx7UXl~l?FNzqC?8iI3us)Z?sRPz$yS>6;VD!xhfWC3v z2=Waik&NNWl=%dfCIb|)4qwN^RcqZoU_y~RvIYd6nPK>dD`sg?9w!d5_9#sz1SD~i zHGtj)ZiQk2)_3?6Ekqn1VgSJss!F-eh*ja)&whenQal40%~aAm;jv_H@A+pmc*w-s|!`4RfcE>+}fu!N}khb-lz zU4}wp^S=B9K1&Dc8?;goC)ry|54nz}H&VHz(P0xA89k~`MTr1yOC@RXk+u+x3Ls&5 z(L{H5{&`EJfOO#nSKuYm z=Dxyr*UN_bb%(lU6oNbvS>Rxp>r zfJCO5p)Y_+ph(G8CaD)wsoVSYw{0xs-Z^_2*KtVIJ_?CZlca@JBGt8?y55z1-EW>; zl)Tr>i3bKX3E45EBPNmi;vF9zY{6F-@R_F4qfi(8t!>FGr_+-{V$m>HkU-BuI_@8$ zi*hwJ2KW$qk9Y?KiQn3m7{BE?2<@~4eifr_5fV{%eIg~MJrTs9Dug@6j^%8N@cSqpFy+4sg(S@JQ7Ja;Mv(aekgIVf|W*I%}hP(ePA z^m|ZdYli*sOak+a5EzuHKcoZ?$~*@KW$eL&GCK9Zpv;8ed>=36+UCyaL0N3d5#$AkVs_RQaB=Vs*7_2f}S z-Di#LZCo$60AQ}T)Ny89kk==$1rdb$VwyYI`p63(nChovCXJNknWc+Zv>Kupkq~Ze zZor_7$%12A!S@NQ=)=~5E~?)8Pk#X(PEKm|{{}p8`~!H{TFEsL|216$20UnJ7O_Tb zX+Nidg;;*KL-GiCc-IX89=4UY$QR&zhaJ#Dpva*I?6A6*@1=5V;e5G-31c7wFJ%$( zkhaP;4TMr1f_Jz6$Qb@ZAvlsxLtXLe2Wp*SApBJhv6A-ZJ`UB$!ymCRJB(%ajuZJq zaC}zTWfk2VJ9a5$w|9+ zb@` z;OTtcsys?Q%tMV0bN#%8wZKRXzI4RX9%q;(*gzsS&W_t#Ton)qGW01ZBZT{ByKm5N zw5gJ{oV&nQUi#;%!x&g`Q}Vj0XFLGln=a;Z2S*=kjpEY*<`k>Ji2y3paP^(k!fnuN zg(k!URDZt?S8&wzmMJ_+p^v002)Qr+FhK)~s9#SxDu5}Al8(t5rElpIDC-ZmitGU* z<~0y8PYh`1`wVFWNJKM6@#X+_&iyj@Y6*`q77e_|;ONUW9nxrYFP7l6p7M7fJ&8@N zOMcDE#wz1}!UTu}>9wc};70);Uq8L)N=%+F+oj{jgUjf>z=0SXMZF|Cj@W&FuAiiQ z3&uIl9Q`+*$Ms!I+MfcEbo0N9UpW3&5B@W82**?mpcp^x(Ef8C4}XN^0CwpA*&WgN zacC5*-N+$)j!h{PfPR=-CfZhd6n*$!!#B3Nw#uy79bk`hUU^?X%`|r zV61HK8>lte6(`|V{Ngmp+-xttl}h`^?OXzPsG%{AG;%TJBU9+iwt06 z8%WX$p@UYN!+nnJm%UEPlaZunh*XNfUX+1q@42MHczc%Z(X*z(?D046*lcL;1iu82 zW=kyNT(bl0@zijDJx+5S`8CSN4tD=HZ>(Z6ToYjBN<6yW)`)N#!Kio(6Luv zbfhEmaJ>2T^_=smnJ^QK|8CX`&290fk;GW{7-sQJI0M}_In z4EdK)kq(PzVw`W=AHiVm38*cT=E;1oKILcgDGaf-`fqlb-3j)2zU=#5MY1#I+ioTc$Ily@#Z!m!YMiDq(1HW}dz z#BU~yCAmI^uQj(*4s4%ej4z zVOo584`ob-21ZO_bzuj5LW~}49&jh{#oQmeiKPuB{kf@0x`G47-&JDR>G!6jrVksM2vl0ojDPz(AEomq zr^IB1<`TT+-^{o$x@k~jao_AkoKFhrMhJ5qbflPd3iWYhMwiub@vEax?e^L<{l0^WAL9pytsqaR@mN@BJEDGtTJj-goDI|FdnA(qX;A1PaihIDw*P zCaG42DUh|_vdCeZJXg_8 z?T31yPae*kqf1XNN|aD8s1uIV){izt$Fe^y+4$@Gz@w;?!uUX!MJ(R}Dd@xT8R^L4 zzU#Ed)oVU~+LUEq!KU8(d?~%L{A! zii=gkgJYCTV;Moh3^iMX-S@>~;S%8>)&%ooyaKE@1q$)-c>CjwU80Ao0RylfjkRQS z8FZog#wd%^UM+3$1{%Ky9Vgnn;f>qXAE#Ql!Rm^CXr%-Kp2>u()4M1;~rxVt#NH_{c`&wNJXF zyoT2I>Zzj4)tWvDrhc{tUX1alo}_Q67$E#rUxQ8{04t(9CgIhVh2Yn8Qduz8bytc{ z89x0=>v%e0H8-ktWwV6z?+csbmT}@NK-f$H{r3*|-@3s+a?c@>fPadieHMKwx-bTY zFVhRA08p45Pz;4-fJBA6eFTLC`&)jcdu0763jSjKaDX}B?0;~;*8mQxXvNAeppNe12>SyT66GXOKk5rHrOX8p(q2uJ@ahSJo;7UhjJhaqGD3 zQ_Z86#zt|U#5e(v)itNd7*4r-`_0ItMPZ%w4QmJmxCNfbc^(etfLDGZK8!B0R9@jt zk(;2;mOVb&|2*rnp+BK65erMh*2!I35+(o3Nf-lg62<{q;03ne7C52jkL+)XgoYYY zHK3(l!c4l4++vm{<#C&Ltt&`S7h|l%S-1oAA^p5|H@zgfn*i#T80v=2ngMHf2Izwq zk@ufk;#@zC%zrnjOeWz8Gk@lmv*ump`RqTug#RS{#8duH(hq2{k&I+Yr(!lgRBrG1 zM?v;s(Y7O3R@Cjo`gV)!_rxOljm_27y*90BBRiK9owOQ|&gR5K*SVw5=Q|}Fq9XpN zWX|khGs0qV`3gqM#=|~^Ra&g?i4{MOe1;x2>s!pG?{};gt9pq{bAWoNI8YA-{Abd2 zjMs;~&&%-LbNefQSYq-axnq?9hj^4NMTz5&+;_t0XLCy@itx$NLMS)r{dHm4i*cJa zqYBXXO;4u}1!D5Yz}7c)R@V<_70#_X)PCNY>S?~hV;WIH1UHKP-S=^9OO(O7)TB6L zIV8mjv5NZPCrZ`pm^~c9`qZS@%Xc6y7?cg_!1w*qG*;i%6_7;>^erQdl8`g}teqmv zm#qn0OI^w0RL_cUuQNem@I8pp04H1n%n6t7;mf8@b9&lW7?#lOR-(&=P6NxHTygAWy8hAktGi_cCf#XKmEa}Q@OPO<3yl8PNxd>Z|V<7-?J zO6h)$vJfi^yAW!S96EsNNebq9KZG7nu}803KqZF(jQ9uxpb3ZAq=Bwe(IAtj7$W5o zPJ^G;=F#Q{SRyA22KvnBQz>phc%t-Y^X=7ml+pPB-(sfR;C(@{LeiaqDPd{uAuNpl z@+vg|6JiIJvowTba&rrUTAyP9dKcj8wHXycNtq<_S{3w2wN>S0ztHNFDyHu6dpGph zR=obWpfUwfR}QY%Sjc^dJ>BlKJqguHMv@}Z*xR87q8+y73II2QZE}hA3vKJv4dlNs z(2CuwstNu-0_|^E;eSBILBjAtB&stn-cVVU&3e84$GYbB@TIdb1`THkyyw-2?9;5( zGnMtV zu=vc2jPkw_psEqrEK3&xR5e0?s+PG?dlqhp*&9#*obr3bg)4)ZR8$duo$_bNUY!O3 zZ71`usacfY(J~6$Kkkdk3_L}n`wIU^6(7u=t{8Wm5}d!K&i&PPTIB~KZTw@TO$1K) zgzNwk7s-Ug2#mz_XHvv4f1m^+EnvAoE*j5D*V^8D7*J>eST2mz=g}YO*z<^?k#WW- z#Nxf~N|4}m4x`qqGMfgP+{z;6ekOw!OHn|IbHJ;u>E{b2@*H_uCQC@Sm zK`*9)OQtl}Urf8&Uix$BdO=RR6lv3ZvYW^jq;E8Aq@-^t&1R={6RnSgacdJb+l4gg zFpMks?&x=G!)SgP817_6B8ovi2ESR*%*$)v)!rFH4*JX{!~SRA>7YNVhFBIeuJ;Kr z1o<{~gh^l1Adz?d5<46BLvR+vaW_cbKV+y^ZjlLkFGE~#&qy#ks3K7R{!PgJYyh-I zk{sD$t{zs5yCrleW6pd2%Y>oB#KV>UsG0sYf+PiuAZe5Yo*F`--;Y^<%Er!e<KO;H^tfI^Bd5qSXP}BiH+;r7e@m3KZqKVF7kqquT;aYjQ&u@$JmKb)eITR7_x49{ zUFAmd`N`Gg=EHku)l2W0eGn&sx}cu)<3lvM+s1fk zhQHah{ly8wxks0{#Pz8pw_%hAlF}fEi$gpBnE`hzPCS3v%&+x+{$Mmbr;WgJ_!Y?( z{a_Bny`n^qyCmKRI=!**5EPZI7-iE~#k^OIDwfyX`Z}F?&th@(yk#={U_T~wYON`y za^Op;pOKCO;np@uCc)gdCSqsVjNsbuScv@dR?+Q#=9Xwc4~{rWv93RTet;Z1VaRe(wN1EZ4aU6g#~2fkPhM)ZzgoCyhT?20x%~G-Au<)9bRE0 zyc80>>1Iyv&{fe0lgws&w$9Snri0bs5ChV0b^5YthA|x{4`ss8Qy`n>=~($P{1uUC zeh4fSW*>5ZD;S+oX|}Q@2mIdL<(m>R>mw_cKjX)x^g3Z*m67(sK@bWH!XWEK>v6Yp z*G}|ju`sSAFO$GPq|G}<7RyDZyg4mn>h5W636ao2!IBg~8Dta*cZo+1O2!NeZ5j?S zib^b!z(b^EnO%XQ@Lxs=1U{*(2*ZLR$8p89z&{fp|C(k${XHH`J`i?a;Q!bBmh=Cj z7sK3qg@~><^+I?)-F#{lOtRGLE47lVxR`&*f$(`;3i}OoR!qdBucMud5(Ys-wXh4e zTps9`ucId5>o^mS3wWwm7Ad(jcbZrq&!60X?omw7wBiOl)iWz>ci-w@=xYpOe~LYD zgOkSt{B(|HEJOEEik-d{kV~#M5Ql|5)qyW;49razV`?3@ta9Ca@ym0!F0cN#=k9!K zHdBSWpk)Bo0e%jM<~6_NORFt0;l*O|V&qI@Pvt8kgH+p}suaI{9a$Ppz2_e?h7gR@ z#&;iVI>8`Z;yVcb{PB88DZuCE26=D+p01Kf;Dz#msMd1Z@lmRv%pHdO2@U4P<#V3Mj~cNCHE&}qJ@{=BEZbS>TUAlZLd_$EIbx$DGv921r$W`X9 z;Xt76C+=^)FxKKYHuC8A_>p=vp7({|-qq22e(w$aIUa>Xac-Fr&8qTII%`~4LPycm zs)5>oB3)6bE0<^V(()vPj7MzYajscjPwJdZ4p%Ir(C0LZrxXNm1)o7XVxytKbvxo= z_v9RMz~VdU3gUwh&TQwjC6GNxqCCRszp!u}cgt_JVPR|>|JnCf1XD6zRe^)A!~hO1 z;KF;I|LCnQ{@aCDgY1_JZ#IblGV`pKeTkV@^V`b4iF3yk?JOTo#@p%I;hWR5+8`ZN zkvU%Nu4t>d44;abO(LBai*1EeR;R{66W7bTx5qVEjPkxa{O9|6JmQg~iiV3%wdMi@ zrjM@9b?fG9-S}kEPf^ln45dtSV;FMDd~fFAJ|c|p?|sL+$m?(2_tL8ZTpsZNC*C?; zpl#LG8q`MZ_u#C~kEnMIsulHt-VyK7F&(&_V-3p@*v#?%3B`bQq96cyzS@7w8ZmqS zkQZ`flEcATtXqd87K*4;$}Ejd*6?1BIZPt_y0FO0v}h7OzKO{^K$6eCR0bQT4-Xhr z`fznf+4N~llhxlHG!-Z)HW@>^o<(!li1&~O#QxlSV?;d&Fpr3$&|A->%?B|*uH! z(aDL`9+8ft9UASJq7Zu#)N+3CW%iBtz)4* z^}F*^4w=>frjVhQ6*TRazv9(w68lNTwDh2j7<|)wM zA_OcSN<(Pe`d<%-NCH0*yal=`!N9dOylath!Iqh$y!7d=cF}U-p)-0+sE@oN+TR!B zwf}kX#Z;vfVGVGxznetI|8eEygg$Ve=SOeB59B1K-nG*51a9-+7}?(`DP6Y%kzM?M ziR}MFQ$)WQ>;UA`?@jX`r?~zoT&Vtbm;n6C-tj$bEM@mh0Hgbn|L5rbwE^qEe~j)k z0Cfxe|2DcWMUhAh%Revk_0X{ z`E%9A4S>3Z-U{7C?>@wW!q;0R#A3DAj{ZGBHm#OomHY*@nf_=|w}DbuAvGO-apm1L zPj5TtNteT|=!BJ*6ezdmFthK@pki9F&tHFOaq{ss^w&)A=QO%80T^j>Q9CAL+ z?n}opAt=FnY1~mpXM+}}VD-thAu~THeHjGLu;K+#Yg?`=d>0G@&#<<^V?1Iyc*9zl zQuif|F?E@5f0BJA9lPGJ( zZ-WcphomQRMOKLwtQSLwo9qsr^XV$N{Am5pF;-xV>p3$p#zip;XFBa1_en8ia$aS} z;+2_-JA{g*6i^4YBDKusPAcnBBfetm>bu(Hy1ibuZzPnTnb7-ra_4bwzgTL`{*#w) z_~G+st9ti_8=JeC)2i#6yQ}k)RgXK#`kQ=?;?w#1w!T5nR$jNVpN36c5BTPuPel(t z%Pv;jF&h6|o$;T&xIN$1YvW(ci4`sjphVop;KAtMliC=3{&CL9;wPu;jEmm9Fc((i zVFXt3cAN`YvB3c(^Y)3_u+N8M{pusST)Nlm}klqp~UX zcih1n1}ziNZftTc_Hi0glipzs8LwgO)rBhR`_)dyNMVP4#tF*}QIYvM>BHy(tmO8t}pO9Z_th3LH|iiL$?jBf=GxTbs@hG7ufWV9GGvBN+SAQZ zkWi6XR3_W%CXKo7WdqmDq|dq?s>Tn-0h>*XyqJD(j$xsX?Z&v$BE(#*w}%P*0f}?E zs7KMABa}0&5W_-GfvhK^cUTgz_wjhG6lIR#ppVTh-%L)k!KMqoI$CynmUi%vMloDq^O_>Xnf4vcL1(MHTW5uaN) zY0vE!o^P)C`YEg{vI9)OO~CiwfG};`WQcoLoI=%wPgy9*4Ads{y(l(IdEpr@n?>V0 zC(c3V`mEK>k^KneX=iJEbZ+vSZl={H<)qN=Ln8RBEBO#fl>sJ&CKQ+3yr>M9hTpr- zQ-bwbx#fotz!pKpWosmvo4M;*^yys3QBlJMR2$Gh*=FHmT(DzSaFR!jf*kUKX_Q;6HJsJ8rcGiYM8Uu(&plzVh}Ja!C;pEMtcbumasm) zp71O_>z&NdgbtX-YN)FlL}31lw9NU7v}~czGivfX}RP#{sAB@1NevA-}ncBv|KO>I9q^? zE9DAyZ)`eW(R{sAZGgy9JnmBp>!o__8AL%8APb(}&9o8KSn^r6jR1@*5yZE#l2%(k z+PE@b^0`?_vJk!)?9c9>As# z2eav;f3fM005&~}gaGtkYUrN@0csoaDo{amUv{- z&j5NM@UVo`m%%P5PGoXqA;0cGy)s{9Flbo^9ZLcLExSA8XMtJEv{bAS-=@_mg0H>` z?%*_1KcV@|yM`B%!-ZN+CX%ssk*YyjRbTd|=9K{MvOGH$ z-~8l|HDmPV>A7t);pJTN=HmNgE%dOd_08k$IBhKn|m)$L^f$aHPbBS2w(T1tO0r#yX?A?hre{!rlac6_etR>7ujcjn&N>jo7C15w&E zLE)`1fMXhd{!wmZVNVp*L&H#w?Y>hR;euSnmk(h|S6(=%ZM;hdN5}^yNnTi;A7*Mx zUdW4GngKE8V(tExH9V)I(jU?r8joU91Oj_f?ev8i&LG z)Th)rg4hXCVi3Ey`Z6dMSa5ww2z)QYpI%@>JKZI8K!JvsbYG2%3-QW^2xfGDwA6l z_~o!c`KtPR%9Um}jtE>rVo`WOy}G(g!Q!FS@&pd$?oDeM#PQ;hBK_^Qh>{UrJGBPa zj-fBF13Dc_int4y(?k#rvX%C9!-o!dmf4MR+ZAq7JnhTVE8) zCtqP&`$EqYJWPVli#xv+c8g8mnKY8F4gdrtE<^dJr-6rT4$!CWX zrpmtI4H1o8R+IrgRah#&)`>#G_ktd7LtU<5@?QS+v?BRrUMwRHGrOl| zdl7T7TXDgZ*gK<79h!ahqLM+k32r5<){=SP+kB%sFOFa$_`Pv!>EDYRnowPybinIR z6-=%j2SgN&;|Z(&KkB|Js;(^UHX*pXySoQ>cXxtYa1ZY8?iSpg03k?_-~Ua zhN|wa{%?1`*UMpyb+)X1So^c}%{jB-U`OYGX*Q0`g zRY#w65WGzMI&}jM*0HsxBwK6vaxXqaDoxg%#|#HEyPoVHlT;bBn%KZ)X3P}+^LnH2 z7~^EuO@(8=vx*^fs!SNboLU*L>#_#h0?gz7a0`$K*p9 z_wp5eym!6(H5`wV7TN~fy+NP8Rgw@cBt;qItYo;#|e_$I5bX2(&kFpA$bVB8Qy0;N3+FaT(J|Y6D?=5`8GqwUzzMnMI?lA$Bd`;({RphpsqyI)k+W)$}4=% zPDJ!10acEn;$z@T=7I5&dEC5a9vtL|ubD@{8jtM;j_z=lyzZ2tP5-ten-bBNB~;h8 zpVLEI`%w20Uwt%{9cuo}JeY@5^!WNpbvCCT)(<~d1M;9$KU@IR@UMTOhNBX>zdZn` zVWVWruKBb(Q6Td$UcrpL$w(=px7(I2mQ3fBIlEnAcl+J*yYVlmVYUB+8phS(xjdvi zk0+J!X9a0tqp%!u0^~t0Nq!I#;wtb0{d$6g@UbEKDy{_Yu75HS!bdV*u5&=IpL!E1 zGzAFY64v)fPd-zFmmPB>i;!%Wt?f84HrA1 z$q;hY&*t|xIt+@qqnTl`sl}f+KeDCFwR!OB<`Bpg4?Wp&TFs2g`cQk&Hi2F)o{$0b732@91_(;Jt#A-r4%O2Xc)I z__vrY{y_1&tyyBQqpT}cdb9~?RD96p_K*MQh@hZ=*CQqN4g>!#m{>^Yc3os?Q@om)UN z-^7s|BtCU(B!Y`z?rx?UX(-qYa2AGhxhkf|`blCC!#X+4*8(z=S!+aSYAoos@KpBk54-2dD z1I~zARfRu+CkLGTF`2Ovg{nShoD3m}TB{h_Paj{(0#Zm){FbiL{A6L5Ww(c|I z$K?!>S198y#Ws=S3Sh!R-6$mqm>Ktk1O4QNg^T0>C&iROYjR9NJ1wctt2TL$KJx)< z^2JR_p(UZHIS2@8RN$o9)}~K~VOg2Tym%^V)u~PocCJ>wYRuI0g^Y7VG?=Bq)MSwq z9u+_udC-;#;r*bk?VxbOHUt;o7JEKl*vMSW%l9U(EGLG196@k;okoeG_t4Afy}}Je zm5!KrEBpl1s+a9az^JFe6iU$vTEXx|+J|%Cr*UdzzQIbpBf@ELbY=IYCI!l#(Mxnq1>)5wn^jLd+-G4`yTx_c2bw8o0$Gj=$FZVi&YAi^>vX z5yY&%SUtX}ty{yt{HEo6EHb%{p1J)A*oE%e1$Lo-QThP=KIU=!RoX_kWqvI;tZN`g zbeXVKXH>E;z2-CqQ7lO@zB1q=Gh3tmk#_dvIx{{f!Q?%IW@v1u{)V;*A{1um-@fe!E5zPB8Z58-sV7^YwJNGM#vx8)G<*suRc<(bgTP`lU#t$JDcS z0_oGv`$7=zKy*SHU=Moo;pu{6uq)4dM4rs$7yv(7M?R6el5~Iqd(e-V6$CPE%%&*G z{Qk4QAK=n6PXMpEQ-;zLaLTGQjy*{@OWTT97WY4r)ehkPi5-XuT ziU(*9iT_9*tL%E>(y(va0T!Y>vqmE6r7B`cONaoEkka*_mcZ#)bgB;J^VR)C!fI4| z#$P>G@}K&E{+_=6OxqM71t1Z+?-Zw;#z~=Bt!-DBs@8{H6)8*z<6+sSr=A01c0c zggg>2jQQ_R2rGm{?&wNj{;cChxoG@fLUN#Ty{YJOf@<`nhRkw(9ym%QKA=()9u6Gc zPX;P<@=$;^Afgv2SQ62uVifq|s*u`XkOK+YL;1}%`>J}=H)doL*oF$zZD)DASYn&MkboJgWXQ$oV?qUvq{i+}`=kqPT zH+dkdKCbz^U$W2$nlyF405geW<3>F35jKb_V$s<(bUNbb7*1YtS8yD=DAu6*X1-c* zWZ*zeHul0&3mE`gNwYUe?v)_UBn%D8^BUU{SQm^4}9UjsSpZ7A|g?%1Wrq4 zlvyuTMQtF$a7SAy>nlIsM~|q}*nG_Ip|H=~Y2EofvT0LH>c0Kb(48s*CDv-vf_zlg zBj17Eh6HTgHs&ccwf1-bTep`N#RF;?U#vNRt=mdE`;8CkJ+&rq>QiDZ8+5I&4c+;g zKN?vw)z(PJHdrOkH5A9!-{mqkF*@nM^zNivquMULHEb?`zg!S=x)xDBM9<7KZQFB~ zDThatCJI`B05nX|5X#kXS`rm*qKy-Cv;0_s%6c6~u>$Drg^gNLzx{MdCjc~bXU7>{AJGtbD{26(iIrZ?F;5ni z-ptguF189#(?DzD@|1MtjQ8!kP+59ST@>`rsTgper5k5YV3|PiYf;Z0BX-m|5f&W8 z@5}3uW$!h^UmOzgqF4=G9;GGMjy71Sm=hviIicoI*ajj}zjKgyBwUDW5S*ApC76#r z8l63Chj{uztt%$?DG3uj#lDk+1Ez`?Puwk=%*~zU-8DU+Y-(Jfm>lOK_<8@0pKIXe z9=GM&&X7-}dqL+#D=FEowt+TJ05|NP;zt$9(l!7)k7$#BD`2WtAY-9nTV6tJ!34^& zh9$2Yd$jd~5H4R$k!X6{(q=_tW@(Y4N$J$~;Y zUP{+^g4aDF)8_a+oo#&P(aNg;QIfYgk;n7**8~S+jin1!Fe21u9Ln{@O%#{L(Dt7K zES0ka)zrqDULqc~5kcs|MaJ03TH(2ZBoOk~ODfl(TcGFFDwwdOdFbtPB8xYRK$V%P9r5~*o3+un>Ce%FU;PJdIXW+lQQ@%^t~e^mxV_GRjn4Wjv7y*>ZIxl=u}By~*ZQ{~_bwM% zY&Z*$Ylw(k+Uvbv+X;Kl#VAclmLlNQEUZx-PtB)$uElDot(52_DM!K#>$(9GH3OI^ zX?lFt73%S?Zw*C;a5rsn<`zg~&n)f2(?%L|?11)?3S*ijA^|3)R@V8 zs~eVGQ^X~bv-4ZYX#+}fV9P{C8Y=@Xy@v+hlVyv!WsmcG?dwY8I51>v&&`ri5 zs|)hDcp!%ayAVmGyfCY@`w_(o3ZBsf{j3NMZS*NtQ-#iIi?v-&>xLa8e@}B&_JXb> zy%$(Td+1-=#ftZb2711-X z)z%5XK@0~NafcwUhPt@|lE=nve)L%NrPBmuuUUsG&0C}6>k9Tr#TLpooHK%F%Qjpx zlJn*}n%!=XOIsd)p!t+AVkQ~3Keq~2XSf@-5R;59znxXX2vV1wVI`34g4`^M-Ar(Y zCM^Hawz!Zgdr(Z27d2SG-KGvw)5Is&tZQJrI`y)Fs-a1{w&SX@PQ!%lhnFqJ6Z`GE ze|opSO}UhIOL0vSFp=AE|J_9XM`=GmnaTp}ugX-J^V?GZw%H!!ZJ4e|#CH_j7ko*_ zjywg`n4fvKYSzXJ#o~Kau<9nxrzdOPbVFm>QW#>D5eH9GaQ>HklOSn1Eu1OBS0Mve zeVQ%p1V@WWGO`$3tvf@>T$1+Tm-Y&4dR*QTY0yixRJzM@5s8^MFn2Isxlzf9LDQN$ z)YM;N%$9mNl}2`gh(q$yW+k#D9*&UhgPn&BfGFDJu62Bu{b;yN&F`q1h7f@H)d~QB zJwwswAoYyFby8|}*=4z$0TxpGm2D?}LLJr!LhK>gvOr%oCnAMT;GPY-jrWfWE)t4!sB=?rc1i zMtit&Ge*a}@$pxTjYi#|B{Q9-n^o0(|0H7uT9wNLjK;yUDd|a4iF~H^_WQhO0?ZXP zbYn7IkT%Edq40}vEa)l-1KmR zsn1G_rC)geDwg_(N_|lEYZmGg_NMfE-i!e1dmYwN5ZQ$V7hHAwZ6?i5_&9m_+Xo(D zPP|_GBh4;&G1hHChzs6_c8>^pSU z^ELdOC}vjVas2&7--2<4!Vph|OL9|=3Cb`|$94RWiKQQQ7sOGba^&|lhxI9sBYgM1 z38Vl6E?g1;dbshlo@m!hpN^Fn)My@hY(ie2LXG>8yi$QAyS zX6}ksUdYtCTH==L63oLG&s%-l_q3gJb}~093GJjmZ>MVVs^}!D`m@|RSkI>d0wpq% zOjRzhOe1)7c(wSp51~GPf?Ju{6bX?!VQpfb>&i=5nmp`GWrW&QnUXFnsKfmrLyIMz zJ)__hP;~N?bPduLD!XS?QM4OW3qK|+w}Kg$L4>)J9k6uFm7Is52wOfnc&l0m-V+RC zGYW@FB00HZUC25I`6t_9FoplgX?#(dPd_Q=ufdWocY$l|k(e#{$5Q#-q)QDS1{uuz zbi8Kn?>Mg{uTCbS?6ap?HJi|mM-zM5J6KOBPC0L1ED)h?r(GIgfwD)jb6R(AhyP)L zm|Jz_rz3t?ggxF4cT^2<&UStQr16Yhk%}T1a=O3MSxmRu116|r+_rGjMGEwOAC~%+ zsV2=mf9fZl4|uKLWG86;Pu)-fjv6wQ8c!yFkF#=Fwia`H9EO%-$Epm=(>%qW&~+H- z(02ol+NQ4SWRkd~NT)3>D^q7E8w(TuC9@H^&ObfOy>*#{J1+@`fE-!{ssu`m^y|0Q zRZRzr^;(k}o0RrVxG z%$|8~)YlLPyeFEe{Xm`{kFeQV7;%a5xsU_m{l8hD7dq+}3b3HVcaTHp>hDNFFxtTd z4cltogO#_p)$2?i;TExX;pOVd{pR2n9x~^TcAOdY(#ek2>nv5$0-F@~N!{INQtb3D zickUT-eDzJ$?0pF8Nx&JJSZT**Yj=x*uUN>jt3|@bIwLm;3$=nD!qMV96xfboGgJI zb;g4CQ6LdY7p{c-fx8ddZ>&yET3@c)8k7xJs*=sZ`_3I+>NREqz3eGKy~H*CM7tLa z2rrKYf7T1W;tahv(a1?m%*zRAUZFoztPtQzI2bL46YR|M1;Oh9L$df$fQPzENRD~X zpJPZa0b$w(P{AgC#rw`0+-E`BFECR1W=|C8wao&lr+cu1yu;FfiGu7*Z3Jn!L`is{ zt$+GRQ*kmHO#7g3gN=0Vu~rwZ{Z{KPO!8~1V8qJ_u!ORp_zL2+P?2AHQK*ggK*Yxc zIsBiZ>Y&XhtE$I>Y0+}CdlgGUEmis_I6bAgAae6oEMycXEq-?xNvzmE&#e6ob48~5 zxOQg15Uu}@Kzv=v|a|u9zvE9ZyB%u2N8^@V9xE;gCpXx-b z0g?C?WO2bzq?6P#ktXW1p$o%AK)L3KdcG_=#dQ>}J;UdLae=yx4emv`hK0oH+Md_r?{QYcnN2V~oT@5^qGJ^AsMBZ!oXFW+noWDpU$ z?Mh{m&lC zRRiL(cz%&+8wXFbih{ebMqyP1=j`jHlwFq6g0Y>uf;Dpj346>{qQt!0DPb2+YyRbG z+k)R}f=h=h-eqd+M^KbE11WCv`n@c{#>{qwz6h+X?VHq2$~*DJax6k%FjP3yn*H^; z;eHRhy&U?VCNJ=FLx|EMjig5@+`*yO4o%Gv5qa6DNZrBDUDPJ<_@9xyF@+w9wQ~Hd zIzp%W$bzOu1sYfAQ-OMx0eRCX1#p*eQ;K~m(cZFEstHGPN)OCEz<|nF39$K zpQBP$u}(>SBe`T3ZGPWKW7sb=o=-EV>?98NC9hvx7RLyV5x3`)D6A&+gm!ZA?t9A; zG*Q0&XyOmO3usKnr4lZ2#k=&_7NT)6dEq}Vt5^SqhQ<^|P52nd6s-V0g8#C|$MFx$ zQ#gQU2|j`Gg2=ts;Ip0X(UcP2T}~|QvlLA>LKuanfeJI14ut3!k|h^jmjd}e2v z00JIe$;-hgw3cdnx%}?&d%_~WBtX2L{1am)o8T+ti8MSMp8zTeAVOJC`-2GOm(tQ8K_AW*_jlxu05)fzd)Xv=s}n{r#+XR zNZd#hvm|F8SArxR41brO;I!VZgk1M6dJv zY%!CxJ`=6g$tIv81%OO<03MXB8t7#)RmT?|l#W=^!9RFVNR+ysL-hGu5bRxy16nE1 z9q!)Pz0jaAnKKW@2+e*W4CH{GBpzhesOw2_7KYMBO+=KZdVx*V=Hf_wq@g5=9t>Gm zt0iT<|Cdo|NYZ&RDuLC8w{OULQ*%NI$plra{U|N&VigS18=6kADSJ`Wlfv(UTQ}nP zN2>;|O3m-;_REP+=5Y=_eXuK9DT^qow(glLEk^jE`B-&-{V>(q4oj2i6h@#v_het*aFz8%SfhGFd1$0@Fwyu%TUNhjFp7x2{-+ZhSu; zVj|qQ`!YMNj=RYo3;B&S@{31)e**hE(s#nRelmv!;4>!woiB;wpYWLlLcmD8upl2B z;pC)i*sC3hDc%%mUAf9KMk{`A7I+0l#?F3IDzI))8|GjG+SpE6I=H2f4qqjCx(xo5 zv5YB4=(hEx49c5|PBkh$C$kHWMlZSdfd> z66w&EB&X+CL|6oAciHJqMg$Tr(KAWiza3Dh4B#VL(l_(EQ9_f_5wK-V7}I?|ApsNPD{_Sn3cKLXJmPZGr2Qnl;a)rIy1Y^Tw*D&sk_(6PeN zFFs}}JJtkf`wP?;2@%+T?Fq_QH+$GT)Ys*C)#IT=I*h0r-Toj!fH>Y%1rfJFZmwQyqjgY`fugZ} z+~&vM*Q$7YEbZoW{exYw$v@qyE99k3DO2$SgGy;6lYFc6VM$#=FnFY+`S5>QWrnzA zqfH{bDdsjxYDK*Y?-QA|$bmeIPhDe_HOQ(>xRN42EFTTzNR$!A9i4bq2`uu&?@_ck zOP}t)`HO61Ly986kc}BwjePq?7B)2&O@unS?4=#xsM|)3XsNNO8qTKm*;OIup+S)u z`{C%MHsq6ccG0~_Gs4dGr^hefoTbW_9@tuc9#1N7@wt?7mMr~tY}eCk|6t3|?KRGG z&%eEbpjS+=l43h`+*B2OwzrTo#2PbMu8hZ*w7(d=d|%IgqO#_>giwEf_gFEKyVQ}h z@Q5kGi)Kz$r=lV;9uzuwmpjM34)G}tWg)|5-xYb5Ouw4g5j79GrZnO0;p!A*G2AgT zMH9RDF?L^DIH^n2hN&F**MNjoKGkt4*u|40t9wtlXk6FH@88wqK*i$<}=st7@UGg^i=&9OYOFMqzQ-+Q}oHk%Uuy6FS#gM*yYEWw#uQ$nSig@ zIj;1%mfV>j zWica;G;gBu^{=LXPi0BsrrWS4-mbd1Zu+7ahW71?{#1%6>4V0lRqSI-4&S8Jrj8k% zLxcyjPe2?3b81KD7)#S->Wb^O*s=4pP*Zd91Lh;4us1BfBgsR-J=(n07QbcnWI^=T zFZ%T`%$p&p8r#WixKG0f@3pr1E!!?^J@;-ytlJQnSF4H0lfTB@UYPYVN|z}~)$BY8i`c;+nhso!?|4eLsI))T$BfC0_@9|rUfAd2!_^gJV~SM`)n=z|=x z8BQo938+w3ipA8`90z=D&Bhd)cKMS>HJq`SP&uhs>X-TS6rA0t7GB-K%Jxzut|Sa$8N&$=%^Urskf&b`6pQqG;8Z;vDv)+P^w zQXS=To%o}wgz}oOqJwVZ{KBCxnwGYt~8ud2IFL0FW$_r_V|E6S|ovQ=5eIzIdM3{DGOrb{JUITUo7}Z z)-dHmt2VztuPccX^#RtNGt$QxV%RNv1&Hz=+PWnC2mJq9?G34aBFYU<-+WO=CgY5S zRblr3APlIH5`@7F0kv#1DkjrU%|hb{-g7k&!h8%V+zu@K@{>nAi^0l{Z4b*j+QO#n z&$zl~-Zu)T_tR4l^*BBwO+!N)TX)Qh=p*$WwFG)Rvi$7~IjKto)WK(K3o93Z1*Iv6 z*K=^R5ZihDmDWUVr1xaF9kU{5j4<+aG<7J>u&;t7saPG(OvOc$*V<}%E#ukuQ^}C~ zVp>JqFYDbkbzKr7nr|hS=J#v4FLv{*Kb0N09XIJ~7t19aQZ#Hv28f$nkQe)iHNyPA z)n^@MR!5P*=*}pds*-jpPL<1vQ#QNY!DcJstAJ!?u;DecgoK-^=ntqT5t^Y*e>ls7 z#$G?HBy~rk2l3M_5^>pP;`(%3Cgf!0_#?uiqNNGsatswDt2)U^)n&VKz)fzk+Bu{1 z6Sr()_rNY1lBib|mvsZ@GuK{o7N^4wV<49*XkVVX2vgHOYIJl7`)In;;!mFS;Du&o zQ3Gf?zt686MxQWx9^WZ{GInKjn1$P$&c zw>C=BEYk^?w%43UPmEyoO`XqKx#fJ6cX5HBjeX1k!5Iw{Z9X&u_Xu74_SO3%u@&VB zfu?5h2UkHCUGSY1!wX9r=#KbD<~r@i9M+jQ+uMQHc< zGjGPp?Hu<5+$m7*{+bgZ;Rgz!l7}}+aL{RTIZdN0$ASxE;`OM zLu0%n9BSuLOV3sG6$SuVandk18|@h4JGOxB@)Hh?DB1agBF>)QP0efKs{TjfN+c;6 z-)k?4ipI-_OwAJflDIyV%&DC%;}Hc*?|=4Q2r0m6eQc&%K~D4; zv@{Ii5nL*NLO7Q=v9aTX%ckwn{VVE9ELMzJt7Xij%)LF&!jfB)wOrrm;S_ac-JX|A z>gtSXY2721cOo?oU(v26$Ay<-lS3MJJ_KgqEQ`k#;g6RIZWd1K6H!KL>!Bs zLrIe|l{ao#8!b59k!bD+PZIS{PrfwngjiV5K|?Cz+?ZTHf<63zVGHtlktwHYNC0=4{cP~|fF>czl( zh09_m+_W$MWb z{vZ{55pBYj7NT+^yt->!k~2e0DIHu=!-|0TOzImdX5bwP8KI!2hoER6nGMfH$_EW| z8_kWLOPeMUL^j}wmxmn`q%UTGG#DSIq7h#)O=PI30jYxej{`JrXtzfQ3=xAwDW%Dk z3?$i73C?XNMJQ* zBF73zxdpW+g;BR=eZ7}zu*_dbv)g?@P+rZ3`bD-=|N^cBCM zrI(?G7#P2OD4VS<6R};p#TJY_M2xNj4PI-DdLFad_dG8%RSuYe87MrTGS$iZWzm{G zngWA5T-0eI_v1VKCnz4#1LTo>!>27rZUt9s?m;0~cj+&-_p~;cPdRk~MuNo{FB-9j0S3!-k4`Z)GUvtP1z z{U9qD_Ptwnuv=#C+5!MP6PYVwBBZ&>jdj#i%t}^4so{mZK+%qufY<5Vg))s{XhtV^ z!JU0PG}BCv$$3*XGQhLxe;rt$kLU7v1Ns9NzxR zK2~qI)_t3_S-?fmo2ymTGMVhN;qR;-Q8KBf_^nuG^*d88K7%f2d2(bxAGy;gq$W>z6U=pqynlE3_&n3&9}y7z5|__ zHR=U5JAf(euEV&7t=|ze6%>#LY$J6VZ`@uue?nId$=VaOE+0bP%V${W<`Zer6>_P> z+gys16M6A2xas#apCJ?jaHk?(xaU5Q4Zx0psP z{>wmWAhP>U)kqnP$2EjkXrNo|a6=huP~3n>h|5wl>+C5u-yAdK0yl>JcFTp-14HR+ z=tGR6mNr!_w>BCl@-+KvER2wc!*Tu+gz}n#dCiaTX;olRk6#=auQPom5C6wc*%2e5 z)rt2VCdSljqLk$f zAtg1W@(_5)1VKTbeRvTH$ub39@y6}&icwucjQKT?CIceWw32EEh_#fopw!U+IH1A< z{bCz|DYT0?kqo7@hIF9BOD%32;VkHNAdE4fxNcU!arshnY=rhy$L^M#9<~=v2YGY> zPTGG2m*2+w?LU{v-^NP1;K1^x0ec*=kpF#;<3FJTqA%XE607LYG|0`X99_)6kIDGCw)ZLTw!P3sD3AjdM~$OmJ#ydZ`zwdroI4K(X)YBgo| zk~Hx>XQ>~_0TeE@2VD2mm(BIg(@ONp6CyRrZNU!9&0ak7biIJd;i{$#BzE_Ap@k|F z1YDG2=@>EP(;AH`V>j8Rk@;;wEPgb+$$QIsDiiVA8!|^EgbBJACim={!HnL-I@dmE z!KOXoW?1N_Xi2TI$RqL*XDYEwbA4@y(ZvA^o-cq%WW;eS( zFdw5>$l5`DsO`LAe4I!3P}eMy{1Jqp4=GqLj!>>lmcnji;! zJA}C+cDO_SX9mo;WP@ja>$&!bZ`s-8irHoxd!Va73H*~BXD5JUXgmOfE7l#H))UaQ zWTec>lx&R#p;@L0Ly6`0eX?|3jr_(ZG1LFosB!WL+Mf{w_Xx@Z0iVi2?7kHF#6z=lMj}m|Kww_*~yMc?v6o&~q(~)v_J3G*V~l zG5ro1Ow^#B_0y{2yDEffuiCOqi+52s{A#K^&}{MiEAFhi`ES@I%2iP$kq6A12kO7S z&;QiG`A5`4yMn?^1R4rS(?By-IrVQujlia52%LgFpu~;0o@V=$_K?Pl+aSaZyw0+I z8=;1z*fvsg6)*s8hXZ3L@H!{Tq=}*aro{D5eR-X6zS)0yd7bUSs@iNFg>b8bOzD{` zKdu%qtFa*X9Hlo;L#us~)QSt7i2O*7<4L@EjUQY}J@6x8O`8te$6q5i72>ffx$?j~ zeFb=%Z5oe!ah5;~$&xPn07=^I+lv;a$)%3c0R;GFaNXg`ci?$$xWh8479)lgapQc3FxFVPOxC7KRE-h}84KLx}d%y*k( z7c#c2wzcx`LG^WBex|_=PG6+_2(4CN;_B8}f2g1z+t?Ar?E}mA^KMufo+p(a;+l^l z+K>w`T5yyM?5y%a>?U0=A_tMMM)>CK13%cHb7CsF`sebshvFQk%D>W) zCrHElGa?F9PYk~e1Q8_-5;0zTFJavil%pWh)~0Ouk+MEPM_E_bwVP13+*yy^OL_44 z$x!DlZmJtAdq6SI+v#gp#P3s+mp2EBdOtVdYS`tmlXCdJut}}NLbEd^DrxpDOF<)2 zF?#Bsx>J6IG+|6+R^TroCgKZ$Cq*5}P4``QG6bQ`IL~{3UQyr++qZFEH#E6`HWxEF4%mitN+IB!|3MCv`$M-=bj{lP3-@FX)S6;^TJ zW^GFCm;`hET_SE%W3mMdmY`!^itJ%bTNphW%FcsfN0Ho zVPFNvP;(EuT7d)-niYDMxv;wLKK-}*f-(;R?g6;LHp_h-u5568Zfy0X`Q_qtuMnA2 z2ToEiW(tmM*^QxeC0{&GnAkN{znuZ&r`ruiT4+meXzv=cA|Ek1_8iwO{I7{Mo}uFr z)B89;h370fXdv*r<|)0NdD|7I{O4>}gAWedkHM6IytY^osD#%pv&;N?o3~SP`<7Tk zcFfsu0I8G9gkV&M$Q~OQzG#48a!l~M#kTu01cGJ_TipJ^JlK}KBMvHg7#pn2cZld$ zkI6F9lqg~af&8QTM((g@V|B{NQDV1@P)-MO%L})dB#rfQ<@LUskrqU&fp7d~1$C)f zW8Q*8!iJiOfi&McKF%X}=K{7LSk;IPowY!S7gbYXAA!;Dpj+(bH4siP^>``T|Cf>OrHi?Zo%(@C)24^ohi>!Rv!)Pcn-iN3-o+)p zX9}*ok_u6l@O`aI$UHW$nML}6_P%ngv!CQQ8IR|+AAT%I@}M4(;fITbLF8${L%`26 zgJjE+>Q`!K2`D5B9;=s>p@cc;FC$NYEJG%)`}IAcxuSv~ z#+B{%IkaLT^m91U+@MG%GjX=86Ui|>cL#x(I3ityX7Z|xngR0MAnyBbk%49j9AWO$ zHBtyT3Q3P!n0q{oCagYsnT;wA@> zld96WXZlmyh%~m~+LVWyWW?2e>xpf_h?1GUkg3B&8L{~4S#yxdX?)R(T|VDIn=?do z^JyD3c`sMEt`4PM+{iRKE8d@Di42!V6ak-PG9kn`HbKCQ2(K!REXb(^&? zP%gr~7W&?(`8|*fJpUBv_j@T^zhmzqieTIG;zw+mu2OTo>VeFqo$w7{x%@jW= zGIZEFxy+z%QAOgYe?9cqkq>#0V+~V8&%qX@pg!%<8~Ct+Ig=h<1!niwE2ViK6w(qgaWDAvEUxs6Yxi2D-fj__rJmPPt`B0|cTr zQ1X1koH(lMIM`{r81tIyqE!VKC>&drLl)*AeDQ*EJ-Orhda|9l$HUD4^tZCEX{#>KoMg;4@CzS(ju+V zl)l5kgE`#;=mA2C^ReXy6fI~3=ag8-YUdyQ4OOwQ z4#WsYvO4BeJX1P`a+Ner$$_0ldy-}xi{iGcZxj2+1z0>s z*_bt#Sq4^HMe$o&nzZcoUT^2Pe-$3LclF2ZI;WC|UgkSox}qK_1I%F+tn1bXzmL_~ zMB-&`eN!#|bwvnrrtv>+Sxt}MOF|>S^^jZREGN{^@=)fQ3Hoh}q!v}dzRb>vFN3cL zn8`F+{Ev(2)U+1nO&$bdHgoMt8ZX924lz2K0{>K=g4-5m;CFL@nsmFuTt8yFe_2$q z33eqqyiOYY*HWFieq#kmHM}ci83S+*b!l!{j4y|WU6gK3_BVLO!#W_te=(eg5{8C< zS(OV=Vns)w@q(H}xE9CGU9tYcOJtj{)hLlN3s9s1nSsKU>7Tk%Uq-j5KKaL)bNd-H z6*IBSvcD{oFiy1lNSWFg;QsEimDqR71NL_?Ooakv+0!0jdz+;!B;Z?Nu3eT|joK=As%{3Y#&hVVKp z^i#0t-@ri+ji;oS5Ap6H!*dlrv(;PM*hW&Hs=P3?uC}aLP;#WaAHWnV%!j}tj zCWUCAR~<>dteM3xkBMEcztGIJSP_p1bHC(_i8b@Tj{IXbz%ts0_EP09M#bN!XDU9A zjiW+{ds&D&I=R)3MW?;XCheZ44fEZ@_|m*fESM2wb2% zE#tk7;6awJZc{O)6BM8NIn+gFCJ*R)=)3v#F`W3|qq=e_w{Gscrd@-xrzOwgkqCfK z9|-_F=T3iZ@0qPjrm-+ux`5ASou}MiEuPa~z>zzMEg+SH8UUg>;di;LH;hg%Ql;+~ zsFwl2^D8HV+T{x;0}#z^n=Hhns__y|3qiX;Dxd;<`qo_5yIMjk_r@}s4eY0qYd_^o zx}IeJ;Zshmf@J8L~TX& zT?9^DlF%@{{*OxE9p-P&7_^21#N2rRAVD)p}HbC`Ep9ZW;j1;&0jft=6%c*)FU^rv zxd^r?eCO67ax@QZBFU2$d11~ZSRA5vbxeYhF)bKn&l4=^N|SW87N-r4A53k(9mGs0 zNL&$z{L}%7UT}}-@{R|r#2Lc250`xKWp|DiSBrP2YY65mV$9c>F8avaeFcP2B8YV+ zh)r_iob${*66WhIq!fdrAeHkC_D+V?I|KjEz43TILm*|2Iyn`&XRy zNuLUc(_%@w7lAm9=(9J>F+yNpPQ?p6?Q#-o5AhvtSBW4k&#I~hHAa1-&?mgD|b0oHcwRD8O4dFW8Ta3c z>-$E{5@IqQ8@_Tr{utVe=~zm!_i(vCdOE(|`?edJSBE}AS!Ox@E_D7<*wI7knnZUb z)P;@n2e%hbge!MgNM2iy@Hpj}fXc!$s1?@RQF7#(=}I}mlEDHLi9AJ=30JnYJtLoI zXx@yTz`B}f+cNu()ZIx61{U6cvcOO)XHA51Rrh(j6Chq254HA*HMuK_4~0nE$5Jt2 z@8>cpAM)1_<;jA3`5p=hfh)q6I%?LK#-I8pv9=ChsA`XnSWkUe_WN%`%O^WWNFv3L z)ZeVg%WLF-z>cjr>g-99C!?pbq>rlnk_Sw6ob36#T1r%HdXMnSX>#kj=&NVg<1%@S zA%taLK3rc?>(7~z9@29~Y<x~z+)}nI-jd@EFzR6+AR@{e#np88xXG3;Ezn>^pJwyb4szhL*?~~l!+mD2~o-o z;XlWBaRaWa!fzlh!eTauFk+_yYw~Cmb(hmeJ?vLOuw$r6U8|WxK&I8FInaa0G$FpA zvEpev_*&XbVM1Wk6tl5lRo*4+K#eNdM3yNT2nMi9uwv<`5T|s6eil($8V}Y1P6bkE zWXwvE=p`Bg!UkQ63`y`S6u16QkV>v4Ae~e5LJ7Vmxw3X>2x&~RI;Ag;rppsv>yOxA zz2&`WQPostGJ>-O{P{h>y~f$(*pVc2Xc#10>XGKF^L*378zoaVDpLnUNQZT*({Qao zj0MWLAUvBLDhzyVqR*4CnpOrZWK(gdAjt~RO!s$PgR-Z}|9{b(!+9$By~T@{ui+Q} z!AGL}N8pAHcl`?$_r)z45)6_58R3Zvdw9VYt}2MKrlHG`65Kry+&#Fv z2X}V~L4vzB?iMT%T!OmP} z6Rh>g@hkL#KV|>L{YJ~&L(Jb-zIul6_cMxC;Jf%{y!~Hq{D$KawHuEQp1=DJy+&r{CC(t2uRgQT^S^1H$qQf^!iI`?M3c?d zqRPMN9P3MFiq)K{x8QFS@0s)TW?Ap=W`K78VRKc9W81L2i=%CdcmTg{?Yl+(0fH}1 zRu-!A<}@4NI0_~Qv#imwBWTJQ56I!X3UpM?Yd&Lu@`KsW{2!9nZ7b2@Z97+wHSp&P z(DDr-NOYFCb^wOu)0vd*rrIvJv3|qd-wcqW1-#y=)b>HE>-_r63hp& z-dRmu7<3{lZRBGt7SaFB>0-Zl(N~WHtcJ37I1fyrz|<4?_MA@MYIygk`9o*-s|9d( z90i5^5TpZBrt`GWuz_b5_2J(v>Wl3iJ(%tc;eQ55Awd7YjP(EHU{+_Leh(Ass$N!a zxDfv4Ys01lBpJYO6}W}!Bqln|jkI7==rVt$_PlFgf4fYWevbZ3Kh2hmo(I#^{_rm_ z0mRk%2|PQVSy|EFJdY|swGlX$$;W?L&}SGC6@G9I$ZFhg z_3ZMfRdtwdFd3-X$n+1*y?s!LG@7X2D5qB@GQqA6EeE=sAs=o!2ozL|7_DU~)O!)# zOkh`-!72?&s~H)rgfH@0VahA*FX-6nEfUj|8!7^r0abPFn@`*c)|`|d4XGrOj07U6 zHcp3O1a-eDx2% zShd&Ey(?$GDZGQMS=a+)8Z4_mh%D5>(HQ*>^FoH(YMR)|nXvgjExLG6@yZ`P$6dKL z@-R3g(eDgUT+ayIa^^~3g{Xc4cLcC?ls$I@WbA%VO)ZhKpj!ZU1jqp$0p;M1fWen< z!5sm79*`3F?_E%HUgQE5t+f+`*TD`L2$Lwe8c%ZWN1_)tFmJEIKNT?cy1fEFXbGs#2dmbMy2 z{amcdxLFd=x)nVvK01<<5jPu0HHO;Ji$|6uIdZvuSH~-ytC;$*;j&=AYWOs|+LR1P z-7atZAoBA*pF6z8^s_2oJiER<|9!B$w;Q(sNZnT5^q%eAbw2F*2(&|MJoIa{j@4Y> zEM?k#nybwS5zgwZ684y$&Ac6SU>BBDk&{S_B+^kIW zk_+dK{LY6_Nk)RhiOwu^yd<;2fHj#6zmO>+GDm>KQ$8Jx#7Kt4nZ_b?(h;2hiu7c1 zwT~uvz(z_Vk)`cjshgC#35Cn2GSbA?C~(JT;q3^LZnn`p6$APKhxV zgT;#+1RH!3S>(G0v94&i$mPF!s2gMC&l0OFhL3(VRA{0yNt20_I#ggOs4`Y>EM$oJ zY0Fa$J_;;+OI0vS&4&7#i;BaT&^!(Eee&>O-*B4wcwv%prZnMvlmCnnQ<$awt7wGX zMpHJuv1pwgWm${?{I_{o3Z~^UFN(WctD+3(>C+a!s_!3+;?PToSUR!NWBe#UjEd+D z8ghun9ThyL>QPpuQH)nx9FU{lC5{%QM zx6NK`yYn$vui=uD8N+Yms0ae{0~tXHSxJGP(^$uJpo4;4;(MC9xxTWLeBnQ#$Oo?D zc$R{WqZtodReXuAH_NM%CB2fC+cn)*A}Vik-Nc2jO|t;mg%4VfhLTt6z9%*1lV!Ru zn$AtBr&kqSKt5UT`;cL2MF(IQgFv}L z$T&>oj@Z{ND_@7litBP5=%d!-F^Lizc(bvM1OO6os44G|@@$r_Z^XV@Ngth= zy})X$Yc{rgMP8R3GtrltLMSF-B~6d=jy?3}>%q({&naaenw`;Ta;@M{*q34mJ8PmU zu%sw2UlD^Am)T82*MxRwo;n}@3p2&!Vm{(QKq8DD`^5{uwEF+1VEb3!nnK(&R3-l= zMZd<|GHVB*O2eGcoq4XDbQvtU2C)TsYcuz>3Q+}0c8TC}>EdFaXbUpjL6fSSG|;A1 z&@;&>!iz}Blx@t!1iD)Z6j)ty8gSH#aj1n5!brh3s%Qfa`jo*^B3AklgeR?m=!1m$ z>2mV4y4qzibECb5E9mn&-Q{UTIK$H%v>C&I?^Dle4~sj~7cUN<5{ZNN;W&}+CQk?! zzXTNDGVzQZdd$Z(PZ5)SQk0ZZ4W$p#Yl0MfPlnEnO*NW@|B zcxM#--R*!+b@bF4kRi6ME`i)CF}gR}YhYbQe}q<@$$LZB9rOh~$eKCjjp)s;9qizy zX9dpjgzlUDyaW3=4FT8*T#W(?{vSZcTJ5<)M2Sp}(zHNpZ|@Sf>kY+r@fn$IqP)>T z;C1BwB^?pmOi(q|)j&+(XCral&|ah*^Fba`Z?0_pb)Vg~sVWI;Wgo?0C1R}n67q!A zBx&QB--*W8zcX}l;oWgt>))tRN4DkKc!CY_j*3 zUV0CRK}OMN$j@9I@sBL5^1@er5$o(AZhIQPx2@VA?A=H^iftX+|8YC<)0|kLQ02k) zTD`YQ&$M7_%bB=;=j&+U)T5`b&!Y~BpN}WS2mg|~mB*{)&O_xBG^IR+&zn|tORap4 zZ}YKWyixWKENTfl9W=Lm#i*pa{N4JJu;?*a$&qQ<6#BA;I9a#)G_hP2v46`{@v7_- zAStT144}|f(4-KvhHmYR!!w#%&b~)QHIQQ8uN8n7-fAjgqI00ZLT_` zOqP;AX`B95EqMOV>B8%$rnB#%sR*@=5Fw{b1#q)HCXlCqO~2>!SyV$XYfaelGiCNS3phK%DLR)19;Jg@~fb ze66bS6(O{*i|&II2}qjP7mjMlVKe#Z?)SMTYkYluVMmJq#CGaXAeizXSuS~McXP?xsCzt)BaGlj773uE9WiWgd;ON zN}Uj!TEy*ff*azbSH$n^?Rkz_Imm$inNmf;IBHm2oL!uJx%=_qpV!@~Y4|}-)GGeJ zrFPI98B-T9tbaYj3e*c_IVfoC7qBmY8od|fFWd=@xkZ3YMhx)V{137Oy#MMr{&$HF zsPDNFz(eaV$G$C|zMfdXi&YO0V&bAA14?{g; zH&uane=%6V-800ul%&2N`toLo$uG_Ko@K?hu90&W6(YX|=5zM4{N_S!#w#1j_6-!D zvU-)-?oT@X9;Q4@y)=L8`L1LAT?rs;+o;jzOdGzD$T#U|TT{cNQ1jj?GUJ!WjH#~u ziyCazX44NQMGM>Jb5>%hnCC+A(QIxkr$whHO~yUH6{x_%1X`~lU3{i}G9P(J29w;2 zmhVq`;(b9WUEjCak9nw8F?~}Jt1Zm=`5vo}0@sY4V zW~k6RPM{KCgce*0(7|kfO)mqEL)D;f+cCFAp>wUChC}Owi?lhe4$SmG{c!QO?{wNLqHd>fGBiGaB z{+s5a`>aGWd=+eRTY=sl*~hg4H}`-#a)+0ldk?g)H5;G=fm*$?+s4eKK}!exOMbe@ zH#_oj(r`fLzq4ub^CkM>BQ$ld701^wGY+B~B%e#ctTh}{{E-Fd;a{@$-xcJ;b<&% z(hUN(WF3B$r>7m)!`7|OA}RCW%FeGJ6PxaOr6yBPd_vd9%VKJbB+SQAOt>X$4?lkF zHeJl1Jr!x+YwUP=-#j|{A1m!zhA{|h^gFl`@Ccz%Ef+YG9*3<8`YqGzIixtYj-9)~ zG+-AEjUm3J7YC@w1GjFUT(E#m(2rmBK`hixW80;3ZzC5qsyf$9r|u>XnG z7dv>*lq~8ue5noQZ~5mzy-G6w>koX0x?+#OC_#s?e%TmvX8`o2wOY@rEy7p4g??fP z`UDYz3D|NKm~Xt;s8nzAB|?zRalVm>mf`Hg!^zvJ&U5e5I+KY;Xo?=y6XC3mTyMqZ zsY4x9TdEI)hTxeyCyQ;0P*8_{J!M|QRIgMfhmZ+j%qbI_AfR_!@%6)m!z@GBLy_vn zJ%pE)HB&D}EhCXpH%E=hkqDnP`Ht32C6DX_31YLBSEJ1+|7vQpYCm9gXsc$*=F7sW zPmm9)#>f`1D4^58_1w}CceNK6ieQ@34B|e(Bb*u@lE)evxZ{c%QR(xvn#qeRWclQ* z%!W5LY#RDm=v#XK5#6S6mg3JmrVyQ&nZ)jJMH2SeuiBQl^Xx=w(m~x3=^r*kj9Cgm zy15!AMWu|ZgLOlak*4erK^}9gcvCW!Nue0Oeg%!9EG>5{X(3RSnq+R@(2{VLK>_+m zn=DhwCoZy&V-m3C>P?aD({9tTUy9k z9;(3w-b~JOf~VzIRLrc~-stQCCQ4{A3#Dwz3h^+uD;r*07`mEtT>G5c-mG4-*VPnu zD0e4uP(p<(n-xNs$WGDS#_5l(DSa;S!D74LkY}wlUW?!0u*{9mCi{%c0<1=Vu8vg= zkjF=~vyKGtHXiuHdZ+Y8cvBO{$$y5OzYGJH!OxCALKkbGK7>gHaqT0(0$jFIQ_z5LkQ~=T-rm(_&hum;{zD&1 zE4%=Cy3fVL&Goil71ff9X^4ZId;v6I7^olNp|eT4wj0DBT~TN+@zLR31lsq_yS+P4 zP&U`AWpDwSE?A=39b+(s6WmqE>9`?N8B>7zm|<==A3DR(R%Dh%Gt8r@UVkG^H_C*p zKOcCOZb8_u=NXLmx(w=}5yN(Q3cD4iq*TZL8&vTe0Xh;;fd&oMk)Id=bmZfKN^xX* zvG-7G*nT=%G~YYRi=f$;_Ln3?V&ed%i-|3P;tJa5Ed#P?Z&Q!sI(~A80w(^iic7Es zIN>$e0^CkqW3zL3kNt!6eIl}CT(#S^?|oPaXdU#DJ)5V+YZ}nQNr}Ro*p0g&Qgsr@ z?($b#qToDMY^wPFXU4o+7QBt9$4unhQC-pIY28A2TN6x{ZXhLMUCE*|iB zh`A;_ART`SPhPjit=?N7ULxkfhpXGYiT!t4X(pVHd_u9ubNX5pB(IM{us_Y5oSk1@ zJl=1$`j==waL%2%T_3G&2;_{%DK^}yp`A}$is#~ig|82Z-c ztq?=c4^s+JAqs{}Xv5?nM>f%p#*kmF5**4Za0gQ2<};@cd%8zkN8ITzax1y2ue}S( z85a7XFz_2bROAf3W!~@NgWE7GfDelFL;fXCeX|Ewz{d2Myh+w>ng(vutN>%z-c@3o zVPOPHB^~yvH$ZO;jY7Ad3w#KDE{~j{%*Yp(Vmi2ORiKXI4fl%hY6K{PCivphE`yy! z!F2d{hN(ykP|#GXm2}#iK^dx7biCT9*|2c8frhSm3g zVR+iAbSqg9^@`WahMbs4N2(NU3?jkN7$>&6@^nIK8wC*c53iSF5xlWq#hqTT;%`vt z3~G*jf5mEzIfurq63+7b2wIL_3v%qs`M;Dxm8lsrvZO;>4slAearMJcY+$}^j{)?bh( zlxQfkz9VO>KaL$1a~Sv9HQZZIX3cE454}|T6dN|%Wwvd7nh~MaILexgwh9BGuB

    4MlXWdJZl<$u|_{N0%TPYj_f$_%ew3RG@V{iG2$Kj0i5LR`|QV+1Z@ z4uz(2Sct(?LIq7cMf)qAT&w0;0%{-j5nE(E;SK5fb4}x`p2^8j857948r+UqSvivpl`63rYe|MD5VkR1H>SMYx{WPAB%W~ka>01a8YRt$|=sJ=)f2Q-q%gra`1>1+k` zYk(gy;u5J%S7A6I_ChZ!NVDiO(KIlZiiW3{l`J&gw&hRd? z$cwEy5iFL(NNDs~zh&XPywAUIhBXkcm7G9fhvo7_|31u8?F2+Cn5heFxbius4>TfD zofyv%&B!aprN4olTN>(=)sIrZTD>O2E(A!9 zTzuuCRy-$*J-_UQzFzAnTcI78kAczIGD046J$_Z*8;FnC2xlz1UtAe!uv>?Bgtb7=G+6-QbRQ0$u?_G{5~W!LFl3zsvPO%Iq#VGI zq$7;KFl66Us$hHciV|Qxn!m5_p=BfY5Yir5RC){mlD#iKrNxu)ChY_l z;c~_UxHArsc1e|jwIE1v@Vg2rki68B)<3zN#?TDyI^CASr^ZDvo@1zJ(B89*WAFTVwhVeI1h|a(A^awQb3<#;Nd6M3Yp;iwUtwbaU*Lj>5Fw2@?QQRcTIajpdiNW|lOg@aj`J;yUNtR4#85@F99cOV+}1V)Sp(j+ zDJwk|RPGQJO{MkQg0gY|L^v%*2RgV=U%E2T6w5L3L=bLlbM}5qv)4(cUXg!Y@a3C{ zpbX=brWn^jI^l+yMKP*{>o_C5RKoXsg%|)vDh5P{&4NMm$ojtH>C{JbiNXT3Zj<0~ z>p$a`=D_%`=y~i#Bi*bt1bkF%;F(!p95i-Doo4@lLe~*j%IIw6g3;d4FOv~33U`nm zoj2q5W1ZK}m;0jbdaJhRlX$tZv&*@E&FR%J2zhkIfgu!aEO~O*n}$*;=$l)aB=KO$ zk1WQCW=tA|l4g01{Y(mM&bnbq;;>TSp-(EoeLtU7nl_qTpt6=!SehQgc5z?%hNuYF z)g~jJL7-oK=hSZEfBQDrZTh;Eb=fD&Jkm_NX88kL3t=3fFPM#<6TqR&kKfo)0YK6ztwHH< zpOoK`Z5s#hw#b5^A?JA|F$K!s=pf#Zm&9WRPH2v5AXKi5KKTZE?&k1<2n3PD{;7y`<4Up8ZCvZ0`*QlC+ z-ok^4M%w;X{?q{#3reP_ENHMB7;qiW3h2H6t4YQ|E=!#CkJVLipRj+0B>TViC`#Wq z!}%!3|2A>cV)YGnPmZt) z!d~tSkz#+Y^4CtoBCnrh2kvtkJTMbr|118zyxg?{7ljDRDL1~@l09g&r;feem#?{E zpmesZkYDXqYN?k{Hz5oBYk$H5>`xY9My5@}!*cl3C3I2-bT$_k$N4J9H9+hgQaze* zRDBTXhUV=M!S*O3;g;*ZJXQ?rWI4|GmzSaHnBKnsNUtZaI0XKsLyn!A3xg7mEj=?& zmNaWX7y8j=tplp@aFo$I;H@Z+rKFI>c*alPnM?CIEuHCxmnCu`*s($yQYfCSFOJpn zeKuy-S{%_F?LA9>Pt}pW-sn7C_3@2W3U*Bv)i@FI`zkp%7o~3}3B@aQDzOJpwOIRJLK)0@o!6%P@FLwUJ2O7E+pTg3wFC)Q=L-b@Jn_(_< zlI0=rSt&p|g2-(8(1H2r+A#2bZ@%oHUHn@HI4N#Lv6lro#E|+NM$765wp6S>86Doa zmjlIstkA)BYBu43Euw@L#b2!8%@+WEKiS{zo0sHcANdb>Lu_wMU$^u5%0eOkmx6YC)o!|hlak+wl7uF8lf5Uqa# z(h&bMdS7VKEq@85T{j5+a~S2XhWq~!MtQbTu+RTz@cu6s1rPX&K9rSkuQw+C;3&%B z1|7^2yM40_A`u*hWJP}Y_E>S(T4yCJ*hN7>CfG(hKxuS6>~@*E4v-5~V+ULm2-Mb> zmblQw#B2e*JM|HQ8&&#e7X_>gO?K7a5~{&6*yj0EZQaD=^Vclu8qQx+B9EzT?cn|} z;4wWg0|vV&94`Sb3NU>cNDfM127EhHtddayGwU0z2AE#=G6%e002r_%+q2wVEkt~; z;)VU~j1vK-H~GppaD%Sc*wuIYb)el|QB|O&I`Ng=jjXmu0N~@|GYB;3MvTwDFgXmh zV(~^3djcwiyo4@*3ZaX1>VptWS;}^umtGASMZFT2s9_g6Ug==hYg>rv3WihDEMdRj zX=Vkc!R>z zq_ioAO+eY)ALa*C%0f+c5fHSudV;EvzMEFXXk31{YY-#58F$C&)VN%C+B_Ro;Oae@ z*=rGgi`F{!J$^7LjMmbNj4_lx|BfYuc(>B#SSOS$<{PxGHMmSw0m-CssQYesen{NxE4 z3{##q3pA43L6W5T`tso%AKwVDUdSVy7a!H2>t(TaEfKN&+^bD%yS*0b#KF|yypV^} zt!}z=%R*9~W3t)yoqjUi(YOM{eutAjury22>m*-<$F=-%Ts%P0#G^b5nWd*-!3LQf z0eK6#SGq<)=7k$3yZR5a0E`qqWeMW`w;}E6#^RQ;(0QOVb_QCk=<3;kZ_CaV0U3w* zl5WLD=m%+i)hhAG9ZFA45y+K!-LC~d(^n8qEe_d;TNa4Wvbv}%BI6m~@=Fw2h<4#u zA1~U7he-yMK;wBfW-;bj;i1d$1sD?<;Z3D~MrZ|P@bgB9Oc}4efjh?A*^Q-Zl*nK2 z!23zH6FV*gL&+FfiKCRwAyB{h1!Uync{~rDJ&Wb0$S}!)Q@>D(g(rTL1DtCM&GUS3 zN|8a|s2K0JSlm-73#Gu>S~0L(phvAaZWlo+<@s^2z zEIq1%Vt_M(HpiRFFI(RO;(QMkS4t_O_pf=($k0Umgy9@ zAoqp(>GOXUZKQSy9#7v~d!|#B=;CWEz8Kn&xbVG=a>Bq|0v#Wa21m>&*Fkv_dWlgx zg0PjmHC=*Y*5EU*z_p}D@6xwAr+xtnRx9W+G%(03?_WM`%uU~IOH`$#*ySWC6YL$) z3`(dJk#64Ng?%z#n4tg5Z|BDi>o|$9zicrWDL{3F?|wx;0^t%BiiMZ|LJGo<9uB|R z|A7<%f~*iT^Xxn?JAK)_4jY<7vOmxBBKad5a4_gdT=l#W?ewxfAYu;W(T%pm`tJL? zJeCxH?Hew~M^VIV*KZ?VFEa2EbKo=rs&W`0sJp|dJS|@`$|(wwFk5L0XE zG{op(pF==~u)u2G; ztQq07I==y+Rlzkhrs=)fFafizEb#ZWCp4s}Im)=d&(aj(I94})>J zTkV70bIv+cAPlMTD_VFhF>anYJg>7j;I}UrKHfaQtIu(sDEZHlT)!0W%H^WIG?1b* z&5L>uNv|UETYz7Nns)Ld>cdO>huikiRL8-Yk=OEB6R0_4$1o$Upt2Z=-Dnr-U%{#< z-%{ihh;y{7T(P;s!#9`8vNxfR@yzGkN-5^BWamz8?WIcFpA_^tV}kk$awFod9nmpx z`(IEbVWA>W5gP#DF|*t<{W-%zXLIriHI5&dVw(K0Ay!3G6zM8B5myR6l1GrGru6=H z7#%V&k^^C;GYU;?RL4#uR3=jk(MORf`}Zi8$Lll72&g5V@3fIdMo=3mL)4ZFGAZi~~Fi&P$JpS!qEj*3w;h9%Y?rC3Os6J=2cDw7F&xd`X{Je0ZPn zVCZCO7zvy`ETI00)iS^ReJDn*DK2F0jI`VxmmC3N6|)QK9E&7>ByZFV;JC7TGdf$6 zu9JbtHbraL@>&OaM>$B2T1b9W@B3%L-tdXD^fD#xIzEk*7uXu&Yg{H()$rR{X=0>b zMdmF7C(^?|)fVNIQus!;_e>|c-V_f%pWZ1i$WkMP5nCg80vFeGkfl@D_~8;8bO+iY zXWvq@92QfN_>FxH%gD8exXYvl`qieYJn>~Df$^R6jKJ)sL4F!%S{NR1JrmHm?00Ir zUtkK}mG-w|l7^Z$Nq&c}(Ic5^(qcX3<&^SXOr}P&b`dVLk9Z$q3hOG+D=lbE;=;}= z`uri-<$divtd!%ltptg`ir)QnDE;_rG%<{0M63~fpsoK1UvgjOVsd3fX`fw=WSS98 zCj?jr*A=oiTqz^W#%IDn@%s25_1XV5s6rHf%!&`VJ7-h z782oK?a9=A781!^@Bs3-jH+ykprUXb9HwIgc2|_Yf+U(ikOaM#+C6WLtDp`_p$72U z%_yzC|Mr;GaZOVhf#cLynK* zhqnWyabI4ngQV)x_***Wfiy1H0cMpZsivBAHy|6E>-sM@@D9qlR_5IEcx)FxgpMX! zu#Sjl?z^MoFG}i8JiW8L{v?5=H4GbL+$e?4RF=+Z&=FDZw@c*brrKeS5;U6BiFoP$*%3qo~wpkj>AS+%R-jFp(C?! zr-7eOE=B*2qfYjCZs)^A>cQ!%sY(PP|xNU8e~dl<)S%5^#v0) zKM7@&4TF9}<-G;|g3@eeX;~IMBn-W>NgXE=pntg&&oT$P_`B@PYhqf4mS%!y%N!oi-=1u7y>f*+9nj>@-9gHCHpXRhq$xLlbN_l>_jRcvozMB1t zV!#}#T2U;O^uCtB-#h`4udvhPO=m{GVuxOzo>9b7y(K@aA}`1bM=Q=bJkWUva2ho@m-NVElHWqYAC?SOUOA{+AdJho93sy8ozKZ!)METc?8!X zi;0S64@$%RR zFlQrB!;MNozm8f3&=WZGTq_+l-YVnUBmCUH&~#%ajy9LFi@QR+{rJ|h$s|M;hnb^h z{kFne8xN{GFNfHRMygthPeORM^2VcZGmHlJGiU`(d^wnJ5hY;#^UZCM<(oB+SFS^) zH~A4E2Yu~tSY{(!!;R4P-${wCeI6w*bX~@3m+=$&MA9J=x@SDPR!ayKC^$|3JHKDc z+OO>6W|(|iSO9N*8p2r=$VhpDWEUNLACU^$a-!1X57f`ZXuPpzBkn*(rC860upg8= zxx&=%<1rqT!@$F!v3$>4a*80{*{U&e9APtY;b0VAbY%Bh-pkj*;%23;_NZltN?4vc zKbMal5VOOG(B2`={kjQT45(#5ax_WD?asnO<0U!APQ+AOROa#%WM2E%YaMzI1Nyy~ zn)od`C31S!?98Wka7BIELpr$6)A5%)NS5eXab1Xh&{I(tvzZ?Wn5&sEZu5Lqla`e? zXIy&6SPaZ|PMUag+pK*1x$eSKUp6{~Na`J;jHCPyvC(l-lYhMZR_YU`BbVx53rJU} zrr%@93EjRMI*TuvWUI0NZFu>QhsS>np7O}ztHS|!n)Scn>Hi_+zzEbuL4bvZmnBN| z8s^FeZJ*0=)s`720cYkKu@@19Eh?MNKEO8Z%*&%w3$xt`sEa~;u8U&PkF?NVKUqr& zLXiA6Ra~UX-PQ%?aQ1M2l)0#w8B@vY2@fB`gST9J`j0kRQ2W#%%s&~?eRTk zvY25LK2qF6#5-0D7pB+8bvrJic03~4Yof-?ba#N zPFM)Jy8SBs$Td`<1!K@tmu7(&dGa^H&L@OfS_8b)tXpp}>`|l>yeQv~&SzI($5|?GSx8%^WRvDif8@j4PATf_ojZy)+@S=O8`e{ z036LE7+;N7PVXuXP&PgqayTSs1^tEtb*wLrA=JT5>)Y?LC7j=B40>*zx@AA37QHaFXv25IPa!7*?>Yl1I zqO3kUN*c0j($7ghP?zDBgr{!Y)A7MFiLhtNvS+SA;G?c}Xnh;-wnX+T>l+>fKGs1D zWQUS|QF`D|NQLQLi&3p4^^rKPhp;20W(E~>?;XP6vK#=W&^HmJLR74a0KoZz8;ueGMDw7O;XRJ(wC87&ry{z1B0xT?x>=JXA zEs%no$?)nejPAVxSNNM$>-QD9!zyG+A{m==$5MPrrE3t}3(zo@iL-;>)CQvIBnx2c zG%GfHL3LMiUQuu73#gO5x{05=T>{l2e-p1UES3;* zI|+M2+wCMg6$bC2RFW1Z|JR4Sr5#ra3{Z>`60d&G*DqiuCsdReR*@FQ#UqRm%9oBN zm=uO+Mop?ZEXHMyH6*6zV@Qs-Zze?Lqq}+AD57~zo_uS)d;7)jDR^8iCsmT6!5-(4 z<$Zz+0~B*@9}*|`!1Jg~Oqo1gs)Z~MzMN^rHm^-l;%wSiY3B=R9RgG82^GrZq5-## zds^Xf&FJJd(~k+Vs-_IZM~MLzF*S+1rOz*4A6TU7HzpaOZ{E*XAsK4d4QLO$&Pr3~ z*GTr?Qp&C3F~2h)D05q0@V@=;L{FN!L&QTM9fteAq{IGn%mWGgOcr!-!oK>R1Ua~x z5mBchqTpDrVgJ`6uo8}@y2qf(F6+Rw&g~R~~`^7uYnRYJ1Wfve}@7CB;>FO&JZq5V-&t2lf zXBniaiijhW689JMGSfWc5d{Ukw4u}Ad-5|S|9EWfD*lzQmv96U_732Led7a=u!riG zmEMR2C+xotx|g8n%ly2HH%rP73SbYh6-YujsbZk-j&5vm#$W+~b`Gvih6VEvd%*5_ z95Rx~YY0yehNWOtOPZITFGK9^C2Q~B0A?j$D@$M9(+ZISLP(wcg+y)Wn!T&+ISPOf z(x~13Pn*xr@QGvaI?7HUPS}JkGf_^F=}%R0aSv&tOG2!#?9dJQ&1#2k;hOHJs%Y8A z#bvd?GgFq1rc2p_7$tw`vKp;!YRlEP;cphscvIs$KI|w;MT-G!~Sz9?BjbhiXe5;^4|n0 zQ5k;H;VcTvO((}6`#tO4+e2T|(?xsS)O4J!`}qlwFo&J79p7E-Nja}37c=gpp1mv9 zLgQ>-O}5v-ow>es@&4_`Cmi##>fN^R*c!JGX{Yb6C;F(|Vv>?D=1$bXcYH!1n}>Xc z>xaHN;qz1d#d>p5$I;7^`F87X5Bu(GRmH*uqCh$EwmP_+SVFx)Yb-LnYJqE@10^n$ z@vS|~TRYLyl}>R*EKU?BdWz*mXncF-w?FO8ILyeG?LI^^#Uo27;@AhsW7(%7QR(6v zW_Krh6XKzK37qm=fLL5c2={F4w^hNik4KJ9sbVoHz;YMHLP1Dh2O%E@EH8a?>flg; zD-g3&r@jKzjr@vP*zB~r5n->;<*VgOBA~JGm=Z9LB2dpBPGeQf1-8;fg5Qi!hhjnmenTn4`C=3*Y#v*woL6zP` zhk;{}4Ha1utd57fDq*xSJguIH)V42ffLBV!t%;I>`C%>%ZxyB+nS@#4{ z#BQ}WEYT<@6kQ@eIFcb@4I+kEbogME5V~17+M-_QDYjLmDXP&MttStmfIga@CZQvP zdRyUHcq0CcBE~UF1o^)RHlh$n!Zl{v5m3V5c63IAs#@0)bGv5KSpt^oBETS#O|Hg$ zt-ULZ)QE`yYfyGNq{=J*ofkNuyH`DVO|0~8aG>iI4v7w8SVYu|M>B#OU+4D&1bZCG zE`P>#!y=YND0{>Xh_#!E{>;W8;gY*pr{BQuJw1J$7KvjJnIY?d+_ofsQLU2!2Yjq9 zGTKR?(SlM|v1(V>D`5J>R!lR>5FF8xYXrfo>Ll}Gt6t-LB7EU;FdGT4Zjhc+@2H5dNlmymye#Gim=V?h%T zu+#$rmSc^itd-s(6~WlYczJk$R^DfR`=7Es-@~X1k%^J-Re1)*GM%2vpOudZUqYm3 zaTvz=OC5v#tbW~d8z)BNbzlL;xp{vuLi0ByVJAk4p^;y!{1+Vekf**~!0`P{PT=cc zHS)Eu&j8qn83ZF=gpHlM#i!YJ#1fP~kT#EGzTjRSEwpmxkP&RmBobn2(3Uv7pNW2-0L&hWt*fUR;E|a#Z2Ok6Ws)NgkXPM3~1N;MqX4-t@ z?*+!aeF#D?9-V~j=1aDg59`b1ISKuV3tDx?#0_q%WZX9h>tPg61KLuBIofcM7u{T_3~kY}w87 z-?!yAC4^95>C8jm>yY6`wlU~Jq|@jsph-`&dGjrTya~1GTp*C1jFHSvUXdLwBIZgc z%#!2dDfk=rU~A4k$mhdb2J$Z^z`2d^S(Ryt7wf-iQZ3}0DXCsMvD{2BUMA43rbO$8 zUN^vyp<&6Opx#r{?z?6`qk@-Dd$}DTj|4AQ6;3tNIs~yaI|g0(DgZaKTB|*7S-Uv3k8p&e#@UXL)5Vuxay=rR!ATZDtBUwj{O;EMr;xGJUx{}f(C^T!ign; zWT|4xcv3C-)imWVlflq>Q;7i-&~b8%G@AYTPa~mo^&f~Vr(ZuxC8YNjiAhmTi)HfZ zh81Ebe+gvdG;K9rs->U|laYcD;5ho(vXIwLFQG;sh1|ww8b;6Nsf^P&L;!rkb^v8+ z-1YexE{Z|=WwnF_T6s@5i(moLfJqE3jsi75tifyc_X`wta2m!&s56u;;cbJQ#bwyQ z=N5%AT?A5Q!)?DpJsN}N?;LCr5n3Gyi=!yJ$xTZav`bh7E{#1)upo*DD1r{+OrK`^ z!4zgs96IFV&3g@mp#Ix5?ddle&M|-jhZw^D<;nhkYh}lZN5L>|fXjFIsQHPcDrO5E ziC@v)bqO3gBZr8{w4&TZ7zQ5f(SsLvLD*JejmM2aZpO_vpK5hC;NayW75g&W+q!6F(K`Z?iGGJ6a%cSb&y7 zhf*zB`>Z>pzX}|-Lg3Sg-wCk5f54v^-K30~X0wJJH}JD4U7){2q+f5>~ws5-WF zTNJlIaCdii4=%yo-QAtw?(Ux8!QI_8xCM82hd0UEd+l}ZJNNuQ?f#+7*{a5 z_0hlHyGq>8D!E^_I?F9x>al{Lzl_3LZP#btkhhPQ{mUg7{Pvm;0RgJa%qRnRf#4l% zrC>_n)bXphx~Uot7cM>qgXXcuhuWEIz-x;I*t;zKp*B&Z(aTG%Io-hF$~0uo!U9Xz7`+rooK4LyDmJJO0f_=RsR{qps)t|6J_X{w($%{S7b; z2^{4h3eW&B5Snj8@1l;_V!htc!2I$s#zAm_3KeYvkO3wLEx$Q8a#yeqj@R&>yi0wK z5JXLQGra!Y>Pr8^vy-UbSsC+!qoEL4dltgooF;Z5h>=d zDvEgx%ro8@x^;wdS3Y4?viY)yQgM?ViSK-VILf8!LKa>=0?Qo+K8PUDn*rJ&2nUv* zjiUgu+5@5p1GH_EV&!(KR937ELWrZk+ybqIX#n9UF>c_{%OOR9j=a)AVj;FDOd>xK zF$jo3L3Uy(eNpRyiKif{BhZL=l`;rETg@TA5y8mwyDW!5Md-=pMv6iP3{ycFpR#_v z4(xy;7tX;{Ld?tdTW}%4B2RqQCc{N!nmHkp|hNfZ&)X)jT*6aqYIA z)*e@=RzzMK)XY-70<%Vp(_UZ-m8JUCKRnOuy*(fW=Ia1lupnJSDAJN)R|(Dge3ZT#3cnFJ{J@i zG&1Zahpo-3JIEFHl%t)aQpfkJSZ+)@yDCKO1E$GZl+GfB45EUq9atk#k5o5+X7 z`WY!=35(av!`*$|51pL5X&zx2Y?8L0DSO&g$VzhI31Y~o2bX473!~6IcuB{ zwM9li+T(|vwh#ys`?P2`AnkGAXQ0zGMvQVQ+q_pVIggydT{R}&B?wJ z&dHxb^7RD;T{efG)R296@^N^ndzGhv{~xxC#8n;4w~{4M8E+s4#66nj53@)#9vKbz6bkxUr1xRlseo*nky~B2N0cm1HfM38|hes?OBC)>wIT5qIfq zD4>G%eTrwlBcF>lHBZkI0qtSA7)cH_QryAStGj;ZV0&{cx|U$FHiW|m2+&n+YJ7m3 z&uy601{Iq1ga?9sPKZDs3r&HM{OS3`kqisZ_386}%o)m4|4~a^zTv3&Dn*udK;##%L}*jxuH2nka)X9VMkc^`)thmq zZ(ef@4ytSG#0(zW_^jEg?9ZGpxoa02xI8xdbT-M-Cq1{(rMINwe$%cfYNRi^UU|b} zseGG!ji?;NU+?t^U&2>Dg{NPCJBv=~y<96n%Na4K<$74o@xFAHrwvbg-r9P5t(Lzv zV0~XK--AT57KsZNQ9(IWt3wtxc3c?4y~NcVT#VU#B(iBwC)7~{(IGD#PaTRMqP@_| zv-qec2Vi<>pi}4qT@Bz}GAN+=L-BxWk^-nE$*(S95C`{1dh2{_UzRU=fm={nffh>) zx=3yQDke|hQBc|?`_SHqsky{~LF+E1p>pgDreE_zr<523t98>-^EB^24vVVwxHV+K zKfnWeL$uvjaD*YzQ2=3IR?TlOybN)gsEWwidxzDc_fIatavT~0NicuCM zvvdkmzM^gh4F2F0EKr@ffC*`uL4_pMfjLrP0l-Q`E+}e-L546XF+eff6q`EM0pR#ej%Q?oRo!wDt|{(zsL(ld~MPU<9OO@#)R6D1M9D5#iGMBeckb;>HpJ zc`(c?>1nZv0g`I4U;7Ig`bm_?3rlKA^5lXHw|XUN7A?QFxvVK|>rgjZAxVgvN(kn` z^jckPl3?Ocy4|;wkTLXM%#rxVPFyF8Ns+$r#$4o!!T;8ABA0xSNN7%0ioH+oLzOax z1`Nv~(?A&BAp6PKxo(8Kjq)4Ud?pui{COey{XfrD|7!^OK0{~?3;?Qd_@7Y4|4(HO zNdD#c$iOSpR{3uypl4R0(D+FhFCI3((la5dG2ED34+-mLw+k_2{-oOO;_#z7kUA zgKg8q2eKas58d*@Dl2E!m;zMhtao7lXq^6|v9VhDqp<;~%wzDvLH-RZ4xSN;0wEyb z*1^8@Rz!CCC`ve#Cdntk`Qc=Jgeyc9BIfZPHoUho*khSDY@Y$^$PKTM^cQ3&Y3cQ{ z_tfC+4g9#KrT=sTnZpknTCI6OFsgTW*7|@xZu*@4U zJ$(x8|4U~M4%QP5kl5T5VL%vtd$c$MSd~P(j8p)sLBvIAK)kXMHBH@3LP|sMh&>0^ zk0m1>!L>c~`uDDfmWHZ~U`naUC3^ap$uYSLUW!lNj!MvGpXR?f+`su-4|fl~V)DVw zu*lda0|8*g^%aJ%lVy2)76^G~$QMIEqckk$W<<|3#zhw|r~&y->FB5J7P{gqQ-bWt z$U*(cA|dwF=MllJ5}!;hiiPXfN{5}I`+wF0`41{y_>T#%_y`dyfQx_nn~QeMieA z7Ph~6N=%6pk`l@i(&i!iNxctP1=O;8wgk6RIG9z(@$Oy;hAK0y@MY&V#i zWxx=b%5~JU^Lx5DzM>-7p=9wDfPib(>VpUtd3W;`MZ7R&N&MaPr6*@v&LjKFNFG0k zxu+O(z-E>AsvZh(K%NoJ$%f!CF3trQQ?Z?R(v=2ufHz!#{C5_pPyBQ!7$>>?3_~DJ zM6nH)tQM9Wkwig4t6BDWx#D?#ZXhK+gns_LNxV+1IHGYqdEJIha#bO6!`T8sLLlHF z&9)I#xE6pRKZG(-K9S-ap%wlhmun7@8vfjz93(V1U&T?Dh?fU880aT)QW#04tw77Y zBPN;Qj5Hq4*f+K?uP3HV8NLcHvSu)-k5WBcS3Yd0wp<=>g))u>2np!XW51MR3SZR1 zqpUxvLb6p#@?tJS5n0hcmPmauhmj>K2$e>15WF9@By+8m9Fr&64>UE1{fYsLn9Bn= zlHb`ikkAQi+7TfM`hDaP0u|brnJp9G@KFL4i!x~1ET1PH z$%9rH?Bx~eG(>|`T2<fH5^XbSLAq_}o%SjE<1>=UQq91T{zsP%EbFR^}?f7mVR)<&OB*l7d_Ne)mFx|bIh+Xu*{iZR?+ zkYeOmHmJ6_!2M;n$ZlY&$6h6?_e*0&=fzBugZ=cD+8+o?654?EsM^Z?0=F9a_@m4C8&0zOl>`vZ~} zlU?;Xvsmqbf#p$(`mQdgnYMlhL)%dWC!1KPt`X&@%hj5Re7rAM{W7b;9We- z1FXSMl5WZpqhk6-ES~72w(OQ6Hgkgk2X!Km1Zewg(V6b_Ub(fdO{P5WI=Oj2wtMob zE#59Bi=u&%Y5R1W{XG=k<)+);Bj z3|v6qAy;@>0-ww!b(5LxOG4=m$OqF^^q)k@^TOrjBM*P%^6-*L+yu=pl)b1YeUL&N zVTav$$)wmT$X^OG=+GzGhZL4x-+r9kzPh|+7JQs8*bhA&C^9_Qkdjf%73f5c~WEy2N^muVG!=;CcX|z_czjigD z$a&z$yneKdJ%yiHID@duG*FVoaP+uLB4OX_JU2Dbtn1YvJ78R3Ung04e%XN%rm&U; z?-7)|Spc2hT_H>ei6z^TiB>~JEbhV5=oWR-xJAC&mIA7=U{nNV-05gTL5F?@qpLY) zQCaeKA20G(%JA>lnnAcqlUvy00yU@VzCwpVIplN=bdo%cA_~z!jAEcuI4QByB>TqA z*L}PT+F_g#-*JJrqW4HZIZ2KB>`drK?YFXzEBZ1;6k^<^H}BDs88y?os=*cDJZN)rNVsXT$le{g=tDN<(BNW}m=`AtV1Dqw#e_f+(Zis=^dS4h? zbZ%DFig`l9yMNRnv&pna)hIQ+!7(4Kz~V{8FvDKvh#D|cAg{=O4uIXFu0-0yF#WCt zd<6EB!gv;vtBt0byJ{l3$QMuzx}6X2{|jjlp=_@heL#UB0Th`3>+aQm=Lx_}BOHjj zhI*u8QGax~%<;LpYI~NgNX7d;8V*`~RXCyxdFzt>9f!wwbdjLAm zxW9Ft>et>+wRUJ9I?ro>&a+mome&=oE&oqu2rqSW&oA~KGTyPIulw9OXb-kdkC9yi zHesR(lr(Ferth2mtCPcJI%Blz{FDGwtPE#A)iU@p%%%-HMtIMh_+E}CB!cl$5c+Me z$4A9@F7k7L%rl_bUDPKrew_mGBm!FwxBy;!C-@^Wq`A{~ap)s5gk2}pcd3?~tjjws za?{|2Pb^?xCyINSvNfvZ3Vl<#0DxA=X};e?0MN>iJp-O;!XYREeTMGbCh>O0a*qv~ zksL4kH+Odrli;4!fSN9Hu_WI*J(2j<=TC-TqkrQ~T!7Uu-R+2Scy@(;M237iQMxzH z+kB&099^@DuffTKr^$_T3!mM|I@_0by)~sc$<&F8cx!95P7#4MG(z zi9`TL`j3jSUW|l_ba{t@-9k;(NXyRie_8~Tr%rz~NQn55Zh>N1fwEB}mDtBVVasDV zKToY$NHm_VFAShXpG%EMUe1Uv6%azk459}gJ~}kx$u7)%bMt&{cVAJ?UzXyRrB8Ui znN`WyFMHm2%l468Sisk%`+zS>8T|R2SvdgsqEmRi+b@4hu6!C&TY0&JzNBoeYQ4%& zc7OYRyR9yv6HYYwhkOwr?v1Sm z*047r*pEDJlRL1I4cjKX9krZo^sEdYNp>jiI6kpu?I=w9L18+ z#?D1Gg>X2A<<`@pa6)s2K5T}m4<6tZhOM)g5wqyeD9Gf{a*)Dcq({yX%pC>^o`o4~ zgu+POW{8+gcOR2$gsg8R$$T`V5*>>mq3$-p4N~MW(2HK-R?YvCUcZn+rW!ad$R|WG>h=_tF-V^Cb)%%so!YXqUYP<)t-?2+Ekona} zbi?;+f2ez0;vRnaf!2c2c$yQb=OQv2n&z=fMe@Kr#-C}+q3M2N3Yc)C*F^fZn;X`% zI(J}5MKPihABiw!=m}+z9ZAhA(5m0S_cypnVA!WeHnnz3qe$2|qVh~db?uLY?qatS z(?jr~{BF{qYwxzkK^C2F6aR*6ev{Pkc^HmteVAU7e||*-@+E|YO{*A;6Fpdao}fxX4#}g>rk;IT20CMnhr9pe z6#pMZKFcEKQV#%H1q$bXC`^Al5d6dQHvm)}2~nkt=nwYUuD8cAKpc#-Ml-AbH$h*p z0bTt%exAl3F<4+VMZF+e+|Xr@px>uiC^>EO>E(FegK2O`Z8^D4o|gV14Ev?&FGa%1O9yS}80?_#LvVnT=kiTYccby8sl#DsTb zQDR;}FrYRa&U|t!v&CrWJb`+fYNu%f)Z${yB>aH8`Blt~D*=AL-h zo?pOwBR{U&0ao+$En3K-)!6wG>D^PEu9tB1=)cM7J({bWt|eFjZZ&HtZg2}!Ulnoa z&^N0JQS=~HLB6{yZxnI(JUs=G*u?2xYhL^*O-b?m7}gK$rc)5*_|3&az%px`z6oC3A)#Ne=4WUGsi8 zPqT}x7 zB8Q@qGiYX=hPe9UkM5a zUiO`&U{s@i$qqhxZCtFZTweaG_yB?#EN@#Zg=?{VGPA|r5A!TlVpQL|-+AA0Dggio zP<+-p%vCx?Jh}M2ULD&a_eX1s*m9I=*RzG9Ci8|W%-P3B-VJYbJ5NO#mnzopR&F^3 zA<>XHjnu{WrsDjR_?azj*^Y;?JOJk&zFJFow1c!mrTGXXm(4oo0!qjzJeV?Ew;ULF z6mT~b+*g6X6ENqcpG=@o4pXtoU+23Tf^{hXm8a(yx3Jk^5eW@1w*WXlM7)PRI+K7; z+1a{p9u(9QX+d5<+z1!P#^=mje?mw&yUJDApRX8dHX|Lu4ith(`X#tT^-9USI-(CMM9ZfE)Ytr2pbuqPQg$!F^9Mfb4+2fUTNBV%tQVZ zpD3l@rfRS*{xB1;BvD`X(*#Z5Kb^UL7Aa=V=7<}~WMABers80ZJ!d`vVplw%dFj?A z6b_`C#gZB9JvG1^tp`+~(v5L>9UQttB+;?sz9PygBVZwmplwZI8s>$?3-P2efG5W; zJ#@nK4}-oo$r>c9d3lch_3G73qrnoj;mka*NyWBw2=}({^rB;B!gSq6bS0Xr+lT>t z-5~Wiq(jgH^GqOrCNB$Q?EcPZ&c-oKoSasM7Go1_FxD(=0`|E{DKb@6!hEwkT!us1 zW8yn?kabP9nt45Q{r7<%n+kx!M*8mxgj}NpuQ@YdKc3jH*AzKh1v@ol^0Cj+;7H8nZiLGPPF!O7__(B;NM>knh za^`{71rmm)VYR}{5<&>*%nt)Iy0Y(0nyB$xT$yKx0fpNR`xMKL9m#=uJAjX<>^sMB zAxD%tnZaW-ncaXris3{dhtQa5Wa@%D{{Y~n#{?NYXhzS-d$>K$u5OKYe0I={yF_4r~(Et`+apQx9hf^lCodJD#db zkNZU*Pb8IZh9cR6?M1Zngcn>&C9_nUuQ`n6>2F3B3jSKS_w&#!{&xTX$uyk$emK?u zSa`7y7XHO}jp7dr-v>Z4xd6wSEEn^a=M1TM#h;O-RzN!!-ya)ZBsid`3aM|J#2MsV=nF`UubXHe{C!1`#j8f>+A_)8 zN@|}TJ8JO)Kv`%4HYX{HMj5u<@PDhbuLI}rLppQ zza|Y=QQ5g8Z#_zdxxuxz#rxXnug$S0AMeLzH(n$62D1*`?2HRbRilU^&xh&>v<3X} z*WHz(l?8g-VYJSxEr&JlH}4MCg%wA+pL~laO`Q#_d<`O>)$51RHsPhaYzMvCm+9A| zpLd-RvhwqBM4Xk3gdv`t9Zj=Agb97@ZIE@0c{Xb>S`;U1%Hbu zJ`+i;TrT|-8EU0Iplil4apPr;m^F#=1mcP6!5-Anom#4N{(yrRl#GDNqM!Qd5OIYF zMV`M?u~Gq%-NJX45mh8IR8aU(ITQnni`PIia6j@!gxyNE9fk-(_o{_U8CQN6g;7WH z34|y(Ste!?ZMxCSJn@bSSKe72SKhwQjFLJF7_re&*eXJH&|=f^VK!Epa#CUtjc&0(1uYAw++xE^bEE9K?ekH&hF2Hwu~=XSf4=JCJ;3TlbIu;{P=Z`PXZhloY^1&htMlUIITyyR5CPGFmH3({$6-+Cu4 zgyG*tx*uU5AG*9OHp~BneN==Rj$&05M>!2@J}6ig6bE#gpssw79wL$h=JAmRA|eqn zfjz4|Q_i#>q=$T)v)Esx2f+T0`7h1IZ6P+pPp&UCK`3VkADRoEN)77+1;I7Xc*Wp5 zh;NjuOPtbfK1qL6?ezdvJ3gy!3V#?mqcQJc3qaLQ5(Bpm(+TLzePWX^TCDx`iN=%I zYPQ#_RjL{h;1NSoWC`@)5fh20&(V2*N&g|s)A^9)T}gbkj#a1q+NMTxCB`&i$CEMe znkngv>-FiwOBY}K^5W1CjVy?hA8dUId4~UQW!?wpfn3$Weyea?pK}FkfLs~yb)u~u zA*gCsR;%ZxnIFAV@WXrTA;?s_(vhx*(T%Zqi*-#L68se<$x<@2Xxc6{X24a*>+M10 zoX@V>0;hPS0LNp091!=x*$Arz-;ytfHG>rHk4U*GOP`v2CbWvXd8qxjHB4Iqc@?IW zVU`Lxc;6_XH}@PE`EoL-t=?Ye6f8vn0%3DBR({4wy2;kH7JE zU)%qR`E6V9zoLMDX)%x50Df_>DmQ_pLTAtytm9>0s?o(`YY;-$eg;6_4 zjvUr}0PFbe!b+{`Pksz%tIE8ALAjmW^q*8O=sMcF07bg zpXHx;@yZJwE24JyEeQ8qNaE>EEJeG2$V52YlSh7Pj>Tt0@e93r$`VZqZ9)b8{Jd>0F_U=~y|;=tiVAI7miUUbxFxVOFmzZU_{l#?Vg1*~8Sdc_qKCyu zh*1YMba_3YhYGWpG+Q=dp?Ofk<$aHtfO#pn8@?7Z7}O-@aZeH@9|OW{l{ZSU9wjr4 zm`K}h0*V5*v_GY=YL88gChTkNjO!Nayw;|^kefrLw&&oz*MD_3wi=nM0z)nNhCUA^KriTsvN0YS0rmim)aW zM`#t}^q6yC0B)Hb2NTqYm0%EoUGz2C(CUQU1U7cg_u~ZXAS4a#1 zslyF1_C-xgrW?{!gc|+(Fl{{Gu)%)RQ#T@)xzoX8Hw)&Lsj1{Nd-QN+gxTBa`6 z&vwFSafYFo%n`5`c_US+ecX{lL=Ld_hJZl<{}=@Ek3n#M4KibC$nTtf`wwIHzh*h_ zMn~w70T3et1VBK@fctl|qIWVgwl@Cj=O2N^iTZd1Hakiu`V&8_qw5Rnb`0t7jY+G7 zH4>w&M4bAD6L}S8rua5&WDru$TLp^mKT-s3c@uwq0flS7iGe1mJH($RA73Q?xl58^ zC8^;87a{i6UQ~3S{mtXr>GD^5s)tzWr=Iv^-43}c-pt6wRFauwA4?7j7B5-x#7IPA zXq(4RG%sIQa=tkrS`R}FE`mM^TjeF=OK`4Gq4h%r$2E1CaQLm0MGlJh5a*x`;@}4S zPDP{sq3{!fIQ~J$-$2gOn~9M41TIO^$FrnOc9Stq5H6BpUA43tpq1b5tq}|jI#4*n zC0xGJ&t~Mt+w%N%Pk{sozssqqE^x5wIDHe^Oz?BESmCCRQI#?rAQsRrOqX6z%tvu6AuRZfQ)= zLavfeRWLqm%ZA9ON&!kft=^C%C*@<|%1#s%rPPSncQqoxHRdE8Mvm^bJcjyin)Pu@lf|^LoBr z9A1ZX^7`ByJof6=G}lvowSgp6R6LuD(S3h?MgOha`F3%1$$mIXe%aI4`SLiL()oVL zbz8Nyib~(%eRXx1fWGd1yDuAqyS##fn|eVQR((;iX?RW+q3`$k`4X5vtB*mjFa8VS zflKk(=n#mGCc#mUbJc0j3Xa+UcpFcrXyP%RF&}_TsTr#AxHNw#m;J>NZhhkq0rq0UZyRn zs<4|ggvx->8B!q!JyHd_Iw6D5(H>)hz~!s)-`17A#g=otUPi?Ffcs$h7Fx19Flt68 zf1MBVwSjtd4+J~Y8Y1=p&NQ$O^BMncP!Eq z$wQxvCvdCVBGcOO(VhIOB8-=L8W!uv!Jk4@jyHC(zc`iW?MU`r~8}tv;z#&%L0?& zuJLXhLEh4zM?V+}1{QtIKNR&%OE{}c!|E(CV=;pb9u!4Xr5!n8C#ruktcLu>bp+29 z*bxFeM)UGHkt>73cwgAB7Wy8a#?r$qd$r3hzT9!%UD;7*?&1Bp)MQ47uhMwJGVNMp z;P&oTz#^^9%Ws72{OTZEwyk=XnK1Ee6uiGx(A68PZ8{Q?p?F2Ug}m7Uc!KC5oi&wa zHIbNh+n$V{oM|~`3RXkNc&#flTrc7S*M-MOMH}q=|YYFqfnO%Nfu! z6T~K!U>Y3O_t4r&X1jjOslW$F}>Wjdqv7P>f8b8Ax!HIjwjj5a1Ja`R5K3fLg zZ&R_t?yam~TXY!_hdSUq%&b-0q|6mfncj zLRi&#xikAhln<0Pkj|3+yAxhAvJ1 zzo8c=ul0H6_z74`e@eu~ymD}X?reLPc033%B0@@c484ByX{$qP$;SUfPNav^KIh@B@)ie&zMLRLv=jAyYxnp*idWS|$C<{{KZw2bb zkV%r<#f{jnxvvD&hI+e{-bNij_ZF=Uf9-bvpO*h>hZKn}fb8C-uRuV6T#}FS>*(Ze zW$Z}jW^J{Kvl5*ze&e0+3fa>N8cN|bD^Vux62CT1GLx~UiZxxqf)2`2P@Cqn?g-O7 zBm!PmXUcjAF~W7P30yRQ@0v~R<=hhr_9m>vH za8N^(W7zRW2Ms*wBvD7|7q^R(ufA?74-IQKCtWLQjP8VVVfQG>6mECDMfLcB^AVrE zpC$Skf8sXAxC_!wCCXE!cH=P!5kM*5f(KHCQK2^AR(60Jj-}xa0gG)FP+*Zb!@unK z#4U&=o_C#;`_y;nhWcPnve-QzBaj9o7tZA7b{$~b5oTz2dr^DH@kHlUul2-j&eZ_Q z4i#kg%7iGbScs2E_nf>>!k?i@=MD|6qos~#e?Pp-r&Fc-lL6$b_{JtGw1fmydbI9F zPiwcyFL>tP8dtaM9B5psN{HB~Mj}=_h56jwu&ULJ)itM>^5#O$6{~{hRIgQoiA`8y z{NuCqipM-5hm0i2D|C2r&(Q>Q2n*w&a|nh=T4~XQ-v?z5GVF+OqI2%Cq4xNUa!4ws z*0UaOx$5pDbz8jzQJRdxl*;!-D$pUmA&!k+c3Cmt^F~p;fDB{Y(GgYxYwD`pZstO0 z0t6P^RxOVYO{oid%)t-FV;QBE1#jbSo-AnLZ%)+hhoH`MlNMEnR|rUyh7#!kY58TW zi&BpIu(($*0rp_*x32w^KN{`ky zMHQ-pAAUl8AMA!O^g$S`qDqZU>C=Gh*fsFZnBc$xQd_ZKqi>>mGEM4M0lu>#ebAh| z*^(U%gF2=zkDL)2LJR2y({TW~$RLZ-`}RuGy==Am8hIspIdwg$kHGCBrRqBSkPbvG zu1?IU5Z4?y2a*yz9VV^c$Tdn|uCGw~lrM*(z{ahQlfvHA!kGz7{R~5iqw}}Ia27neYE`a%c#OZs3f$qokS91OB9VVU)5tJ26+`u(aFG0-JFnDh z0ST9LkpyDIa0bXg0RseQ4WBDeSJd{3jvD44nWWHiLh3TX$S~@ab%X4bv8q);L}4ch z*`UGtbvoa0>ra9Y_u%p+$9{5PYnqN+3P+xHTZu$JprbqqMCxAomHV9`IxA?(;qwjQ zoDNzj>Hy-_6T%{yYBgMwnpOBu2jgS6)Sd4G7wf^U^Gy+$RqZ4Mfx3#U42h%tZ1!4t zI*IWsqd&e#qstmnr1%H7>}c{~9mVIoH#UIuhp}L&&dx6qZv-ukHIt zf$+9*IgbU0jl-_o&KkLeOULPD!fap&(E1S{-n*x05_yK#K`R;Q?~Hs$crtpqU&ioi z%RFUnJ|M;$om$#E4q=RPZe^xz=Sz_GY2#9O=xw_8&>i=;ft$&U=_PDuadwrR)*hLs zlWAl=ijQGu;_c-6+D)tNLcmTkl2r#5_ra54JGyFwjm*0I);nlP)C_twzRnOyZiDdyO|b%Mu{SuxhvXg zb(0)N7mxfjQuh)*X+PuqaBbSUAB{q-QsI8vo@HUG&hcgv!*%ZvTsAP;qGG(F>YmZQ zKWC9I%^_6-my(<8V;*{DY_>HzP$4&Ux;kJNF?<_-e*swxg4YCzl6WUuv#VJR0EK&> zD%gqPkregW;4NUPSkDz;cM5w?7VH;84^4Ym{9Ujx{)p@vWH$qyN_!10p{O4W?xu5g z6-~9;2{bYD6Fi@T#5M#MCO#}A3UcJMF9}U&rf;uqfQ&zksJrvamq>2Osoxb+M_;ag zsjF+Uf17|HH~97vQcI!<59akSXL`jNN*NlKivJ!RWddWp{2iMCh;EBME35Xq_mCY7 zHxo`h$-Z>NZd{vCCzpS1>>O2H9d^~{81wn@Va-p+7qgRb#+k~HwC4!r3c2j^S+}Oi z`#ZRebBOBm*habRkvrPImCd9buNsc7GTVUbWE>rr!?p3!CNp+|*BT`j%uqFutsNS` z1>I$SALy7u-Z}`4np+Z%yZE+L3ta5Go7F{~AsVJ7AKh}ME^ArNm(0c05CY%r zui<+PipgPifno;>oTrsh;_!+{loo6uW0{82FYYAgsB|$quZzksO7+<}ULnEToMz4D zuCDH2`g87fOhq#MP+ygg#bS^4;yieuen#hj#YnPa#!5blOJ1WSB6f;Z^~1lQHxT;4 zY?-q$p~;$b7L78uv&-TBG&QRgk;NV}jR3bInM&E`hk0huuKt9)#s;(Ol+-P>)1xE3 zNyv#Gf12{LEKHM0a+tj5MbIkVI*mUPlTLImrL5u+koV*MCa?5XO8SsKIAAHk!~%S| zKDw24I6j}`nUC;tSxAZpQnIM7L7X~#OPPXd;|2^_p%j{OJ;Cw`|IhBl|M`HzoYd_6 z;0puNTh4;hBGT zT{mQAgGQa?FeiI|{r!;hwU|#!#N7>VPyhLTbj~B8(T4{V#hnGd5We$$tzULKdUDtT zv69GeW0y;E+Ya&N%~b*`bG0I#CdL#*t>p1|5K7qb?wN25w%F%^Qw#7sK(Md>M9HCT z6$$@-{@#!WT#;~T(hNHja#z%Nd8$qKS@D*bpfe)VCmzxH)^7Z!(X3khY{jrN4F|);rFP7{13aIM73!x zo76dbNf%99YF!k)YIV0By55d)yy#-osB`Mzj2q%U{G@;89*oK+(}+Jpj;ciTx{Ymh zz}fZ-om+mM4^m&5-Y^Z4*XL?Z756)uRGXf|`3N@bxv2aO0^L?rv$~~u1-$l^I zv{OO)9N}BS=))7E;_ihUpn*to6cC>wj7=njM$i5UfnD9N>LCMY*XMhNvK_ujH&dqA zQ9@zfQvlz-eMc8NjqU}d2aw2Kw{&@m34K#XL={IDE(n)+!ZVN^xI9OzA`pgfh4o2X z_q5sxgb7gjd^UR00$)_}@V;FfxOtt70#Ye~5ZcdP6eKo+?leyF28M6AZ1%cQYd{V; zz^Q(SrNfIeF#mu-jXlxEz)8JG(Y888Qk& z;-idD#3$J+%>(D1e>Rh0KRg2cY7-VYr#gtBittQG3G)kTS1iR#{7f|=MuI6PlQc&} zLfLkMbxL-)hZg~hBhB-cPx`9fdE(b?QG2(hisa>2|HAgG!`o;>;glH!E zmYrN9!i{S}KeB!rDG77l)XqlVzKCO7qSFsNRp_CwHgdAst{SSwnT1#xvIzZMV&un@ zhYz~YeX(mNw5fZ%Nw@X`Crn`#`oVGJEFs%~crSu%O|1wlvVs=u>#*M~{Fe!Xn<>!} z?=y@Y>C|t*n|F#7iyHmnw`|dye3>f~Lbv^Eb3ObA;q+$}MOAIITGC#Awb`nQM$aCg zDy6cBE?0#* zI~hJeIqs)2R?BW)1Gc>-zIkR2at!_rDqY8@0m7Hgf=YOc#{+(Cp``#;YJ)Ac`wIaI zi_NhJh-0XA2ur%irRhnqF-z+wRmM9=b-6>B2DquO`kvkXzVlFGFvp8lVhHM0@3XD&XV?-sm!hc0#d+xq1mD<6j5H#vzb^J;5LhGuLSS z$Y4j@>i~HGSPH!yT$1ie0*bVb0i@aBv>s#}k%?imMu`e~yL}P_RF8T$onhaW;``9w zVr9=%Vd>1Hn#*N?M-rkZ%BWG)WQH);ova9o2(;orVY*y z6b-V5f~0~G|3tUTgqjs7;$Us$9bJhMmth>y;>rM~v% z(P#)kM3oZhInGOe0@DG*Gr#3=a~nWqAne0kLyw$aBY* zA?`IQa?Ac+7SI27)y50lXmdYT?D0tW|JBP^rRe=J^ zvPs@^=HmmrAyp>Rjz7+Ot2m67~;|2y3aAxeFT* zaciLIRkfJ16=NG2d(<8g#A=Q6?4tRq+@dxje6})67>hdlzH`3^V1du55YV}J1C4du zH>F>w&10@iQAwH+a5$e73A_t9L-8XqB5Ir&)|p;rAA06)%1g!YGwb zEYhaKa>4cwVQVW7`0nn1S&8PJ{(Y*$uR?F3c}h8^wfAAXR@>xJ zTdB_Nbp#I!PzUIawy4OQ67%Z2i=S_%EX4a#t=C~F{p8H@4|cC_eH&^nNT)pTrUM3Y znL}z3iiUxT4SKSA-4NVM>$VQ&6m!AlT876tx>)?v`Usg~)C>Q1sW|ARZnNBs#}w+d6;^u6*%4B$>A=8-oPp-RD+2UP8{$$nTlVzK z;5|v&E6RXkFiE1R8L4dm8Dva2r$U03W(2ttKWD+Jy2Udo(zANS$b8rA*{?f^2%iT=+|E3N_H!e8{aFLPlera5nas zpNt?i2@ajVZtt4F`e>dP6V^8K!Ur zOf6UL-e8fFLcU8wUOpC^jNHA$jxRx1RiYigqO_Wxx{DegXhn$_fa{6N7G~776UnIAk%DiqS zYr|tnw`&b-Q?+%odYI8m+iIxNhU(=|Og)M9L8MkOt|!%s=2#OVvc;AV$=8~xpN6dG za}f3W>-C*+rZrhXW?YT=86^@F)`+uZBY?~)$w(+#;H-w*R`fAgXl#+5+UW8JOI#C` zC*J{>DUop3qHSsmBFUm6SrA%&mi)a8HB>C&n{18j2j5XH3Z#%q|4wGJ4JgjBY#m!a zKogZuaZeFvZc3qP_(Lc=y$qDMlFHW5bK!fh#(oxzwi}7#`6Y;Z#xA~Ir}OKz;l)vo z1vshZ8)hJf#Vyn3j3@!e3XFK<%xsiv5&2B~LqP@@fC^KlR%U@t5~&7!eLN)!AOeOG zdYIJ38XDRc$RpbF1^~T`devJn>3e|In9wbT(z$ec7%2D&K-H}wa(IEg=vf{qtkv42 zwH7#CND1=Q%D1Lk*~PbS+I;(_+`cWoH8z#9Y!HTXI6T=;K-n&ZcT**X8VooSOaj`o zR#Tz2Y2AkhZGA~G_G4{Xw9=T8lH9>-g0|d?%>rKo%^kIW<{B>`~EIn4C z$O#D!j01pDisKZnH;zHmCAlhlQQxPdYpF%}7BMpN6Si;GwTCSyG_tZd+#W$QMM|nA zQ>E-|1TU%c3clH{>D3A8&WosrOOdN?374vo5E~W!!F>5o2qdXqjxdsHpj3ChPs=$7 zDTl3DTQ$9vNO& z6ZVZg{7e^WRU0HaFOdhZi1NfNEPz>@f$3_d?g+L2lmZR%+N}N<`%Dej?d1IGLtCm9 zc^l{VVR{o>72+fKfQ$^f9K`a>)@jb2N|_T-8i&gDQAG))+gjvT0w6|6t_zTo3yH;g z0tEIfnL^BB(1)54N@*TyLLkLFjN|}tUVJ_qd^JYcf^5&;$FL=oMnnA5tlJFJv-M`U5EmQZ23j{;&TH z_4mL3>;EVn_uBwJT)w*~ekdjPQ~q-G;kx(&@4v7Tsu@l?ZdPXHh}>4Rz4T~H;5Ql5 z2vzRy9>#|KwogHaLyF~>nT=we1#S%BA{^|)2fDDxcVKCWh3;Ys#^LUfIrkyWeYEx5 zLU(cQqupb3?jxG}c6!S;+N4j@Btw0j^hALb?qwr4+a02zYg-2;II zF*iZ5Jrjxph!EW75&%@D>=Dxo-NngSdcRR38HYhrdf$aM>5VU6o9sS*IWsC+vGhIO zdl}4@j}YJO0c1h;a`#|#Y=S_YiIYZq$6G^T8$)L35jgtzl?e%hz}sr?)z+X`2eE9f zSG%LpYXO#HzyMfAqrKPL!(tmmgavTyj*bOb7zTpn_z|#J2a#bpe!Y8mxNp*hVIYO$ zaBHeqhLE+6L+CuO4oo;OKSA+o?_g^Z>lA32>UtlfoH7aX}E z-EyR2n7GoXuOHsSXNb1T2%u>4Z@cu!}7A^w*jtYN9lcx8-QF{v^8i* ziA=cM8m&~hp;}EJLW3d^C61TpMkNuZtaK|(5m)+hg8G^$kBl0lh;_x(qCm8LiLi+w z=OH~X@eop)MVT(#BURnfMlL?JeF}6j*5v~!zVXdYbvc!~go`ya3CS6vJG_5;^6uK0 z?XTnWlfKh&pZ5!@KI@wB;?lVNho5@mhAt9Tw0vTvFkV;wB4_b4m3f)9 zmJ@Eh&`MXQ z0#YWsYpJg9YNPftj+Nahl|L`1*0r!|D1&X7_VEgpyZDYd6-Yys;sq*Ohe$7o79}Il z>GJk+d|lq5SL_nZsUj6_%i^9k@(<`ZAWdZ+XX{0X3UwF?1+Kzuqw-&MYCd?UR^6~f zLLD`<2apPz1^Xh#VmsLeSy&o$!hFIgx z!xCefCZAAk4fxGT80N_ub=&w1)-0d_(nszc>H*R6Vm1Ji&^ zOo#|vHRehZT$(ZraO0n30`t)nyOv6y6J{$Ebb%p_o-m{0&ztc6Q-<>GkbH7rw%y_M1OyVQnACD>G_j~0yg;Nn zXXqM4)DrI|@O{EYkxl!V0^x^}t@JnmNjl!6#38l39Sl^JQ7j6YQ*c>0>Q7JJw(;bH zes_Vbw5Z>vejBDJDN*F%+p;$5IMzTSC@Pu4;)znm_=HF04b+fPiaYJug_@{5PO$%V zQGaco7)L!P>78w+xT#T3I5O)`)NafZn-Hg~DLW8Cw~>06pjG=Gqwh)U>wf9UB$jH)KyA-QmUyckV>N# z{-?U8%Z{TJEWuJ?n=1vbpY zv}Jp<3kRE_y^_CqV4EITV}}gyO*NE6@ zvl)4kbw8VwB;}q%^s}`mu6%03_3h%eu&sVX*|{+Mg)x5fm8o(V@GcGED>F_*T}@A@ zT0>j=H^0~y^NU$lqSy+S1!<~{U#APKjaki&C4bU>DmTi%if>0eDZ0EkmU>e9sBF2F zhV&)Rfix#wBF@4rJUiE@j6_;QlCtFIZW@1i5I~}gFjOM;c=&>CdOVg-MW%E(Z3gmsaN!ak))cCtnZ@VoCD6XE0867f zn;c>BI;HhE|3(jia5X+G9Nj$iIx=>I-oFK6j7Q0~SRT7`UG23CD)WsB@En!u3Jg3} z`isKh%H_yqk9twwQJ;TXdoso8$6eD4zM#wAk5oii9Eu*-uj2N+F&c!z%PL7Td$4P(JMh8C4Fz~ z(ok3Vk(H{Mu7cEN*YfoE&C{_hNpj zs@!kq3~~zPbRu7Y{{@a2AM3jPun47+3*I4mejQDN6Qs8r+)}=?Oj!u_c4e3n7ZOh4 zq(uH=kpUz;AtffaZWU|D{=OIROH65G@$Rb(&I`Qx<6~2Iw$_#(4@Z^hjae;DB|R`% zjNREN4SuQFnzo+KT+H7*$&?ssB*(fu$!5-e!|6AuRqHE5PNsMxjGh)mK}J@_CX_ti z-ZZsVI=LRzc5ydDx@W}6_nbiejMCunU^!*a(G3q=#+V|3e1=OG>LK-;WDz3+2|wep z$(2f*)9q8RwDJ629av`0PGB1>d}ar_(QXatM6VnnW3YNH-tgB`7O*CqM6%QBdnd_0 z5V9WA(F2iKr*qsjaexEY5iY+tkS(X<8z&S1!b_Pd=iP9IP%1vwPn?r0pV8tL6J~hr z6?c=YtikPM*5Ei)xI%>-%_01QW)N@>-N@Cc@80a9USU#C9@Es5k9d)!jUoN^01T!n zk^me;qcjnE(c~e(wJnq%$Kkz+78EhN#ly=BT#n^ZiFlx?J%a}0Vv!`qjTQY+6n}Hg z{x;63Mi^fc+T7e&rWoI)o9X0DlunIxq%XlA@g(fGI6>2?Yc3u|Jt>Wr#wJu!g4bTZ z?cAPB8Fi{Io`a&-bn#2QD?nF3W??$TrlUOH+a!(6$2Zl)x+uPL>Y{MIWAZaKTk*I; z4*GDeFm?hLI&AFyXZmgy=_*Qc@r9{ygNo+2L3mGh`ffCL%$bwgBvI2%KB$*r=aUO0 z(oQaLW5Q@ir^*F5i{5=!m&|Y%lv>)imBs}fi6!ZJdD$_;eWZoHQoER=G%_JT`)HQN zQ@a1LNmm-BHSYK9^534)AGaH&_qFP0g&=+{y)5F=qjgQ%Sz5c~l%6x3kEWPTbrHO+KWj z>tDe8lHolV4GM5=P#=Eq0+>sU4Fjf?BbW?b5VKM=Va>+M7o->AdN7ctBjKJQwk1^=Xj7RFNcsU%J zJKc%K)mp_`H&n!!Y-Um*p;tyf&!TmX|07+KDyN`jSX{A%$xo3lT>*nsXHuubC5&73 zWCUNICsiY$Q9q+X3~t*NRu}280asnX9Y>y>m2hw!H%7Ubvb%0aw;@p{it4(cE`afw zFFw;9VRaZ_RAOQ3WLQy4)R&l4FRV;PM`DveH38amVvqKYP<-)a_E}} z1Tw*XxDTO&f~f<-Zj9Z*D1MNW;yEC&_TyF)q@Pl0GtUb}xRLo|N|?GpZM(vDP^ ziApk%W~1s{lDNXnhTZyar26EkdZZWkUw{IaCtBqpxv2_2C>JJE3Kt-2ufbakjFJMz z8)C)py=ie?;>i!D6WnVB!U9nSejgd7DS1w=CI_u}nII6Z{pD1q236`vHB45wyHt0M z*@uhFg;03Nkg7$rxS~Q~2vVV-s+8Frfk0F-gD#juSIM$<84fWlJ+WZ1l3ZLWsE=+>Pz98_AP z@}2-co;Auyvo%oAL-b|m$^nnpTt0(Asn`{55Ial=I3$}}e*3RPpUT$ZW)|1UN)VBw zIf?^)`H(xFQc5o z$f`SiY02Z3FE+5WM1#5gO9>OFpm2tr9w!yt8{TJP@7*mbkSaJzM~^D;svJ=$XNUw4 zgC@%Vgp3o4#J9hy%nbNFIZSVjI_YL|%t?E=M0aK3{c?w!idK@FvKU>6H1!BDea~$< z%xs2`Y$OxBp_2R4mQYkp+1u+`AT7m%%&>|_7^sH79O$vpKn(G07ugYDXvJ>q3t>iW znk(UsDb;4~4#(JlkkV5)XH3OS+<9f(#x}AT-r=D;0y^K<8rcSCEy(gwC2S}?$qN6t zN_FXuYnT#Q=V6VJVkJe3c^S(@2UcA=qs3}D`E^%vp|i&7v8#)eFa|}~+a(m#AYf07 zD^Mvx(SM^CKwYSmLL2=8{oNk2FQM-kiBk`yl~BB-;R!rff;(-!64YA?(MzCoh3M5@ zXo9l+a)`U8mfAvm$0V|D8`Zc8&rUN4Xq@e&|4&ZiWC`O|{21tub~aGcRxv3KM;41( z8tRRWEQ3+FRb@DunO+@4sG#8kcxTnfn5|M(pDK3>>U&hVV3Zst;__Q&r4&lV zM5}LRJjJ5FJw|HS)CrsTXz6u+Fm4}_WsE)bj1G_+T3xSIEl%`8Ewt+0tYS%#bc?#T z<-$4jz^;YUYM{Ar7Cmq{82g6OZ5m*owewI6%}2i3GhA2x`p?))C$vCds(lt`R{?5M z0qX;FU%kwP7(V^FdrVRz>9CqyED(^LjHAz1@k8UVWSK_QCU9hgvbe$}LZ8`~3B088rtfSYvxC14g7s15b|>jdR2 zBoT+8=QNzgaP0F{Fm4CmMnlROqc!^=I6J!|e@KIboCRBLbPGf#5#`9J70f2N`$1X~ zt^-y@Jn>ORV$sq5?oA$i#3Lp_wvH&jqo5+noW{@ZQu8K$+3UXSg&dH-Z?GFU4`3Ej zl1Ye^08Ls-HKr8jHiDdRHSqxr4`32#Dnsj$aG~rbr8n18k`2JZRkD7VSfAe0xznh8 zfLAGRf-`RJdQ(Gppyw>9!;CvvW<8IPDV!UL9;chdC#3rGxB8@?Zl4PUsJJ!qY-l9= zjAc#z$?1u-zfMme5mLDIFiJ~xu)Xe8JO)=`3~7aT$iNQtzU6(g!8?w44NE^(4+ojn zAv)N&0jeOqnxHl}RGtyp?FHpCPl+mnuez?}^qQC=*HAN02q46v%2q z**cmZ3#TtV-$N@>Der=+i;r4iK19g2;9E(CR=F&fDQ~PwLu+hB!#gtMG!9nYa4c$(~M}N9wXIn4c>DJ4z5svJ7h~- zO!@1YQph+tsOpskOC)ANTJV!_MFoPClI!$)uE~nt1rG9i*bXpJbghE&@lrTCaFruS zRK_el@3IP_8!GV$jf&par2aK1izmo=K0|xbBr(&^O_EsK)FvDK>yX5}rfQPJ+NMU5 z!+#x;yztmK);2Ygy!aO($;aFf6CX<{Kn1Ys0!6z1)@)rDE&QM)G%M^{(k>|3aKqvR zx5<>yATdH72>mV`7jzLW;<3>Cm>Zkd3h1a8prfGyHMW!$(8FGU9u5tt!RS^%U-Sa> z#bAKSPNarw#VjB1<#`h7^Ro`;aN_uNX{ig+I{7H&y-T$1CcN$1AXFRD=A5YYwv0%24GMKQ{93WlePSayR0xW>(pa(#2VCci+<^oDLc?4hwMfI0P zRR|ZEpo3+|nsm}iw|N9yWqxBl7t8?`R~E9d6Q_6gW+f@zn`6OT#mdUN92HiDu6j?& z$!4k?9_hb^LzSneWL@{{T#9bH$#Ju58qQ*@F`Lci1x0cRv+N3XEb2u~LLiFKmMuSP`;Uc&t(p|jrhI_(uj#N>_+VhC68G{y(y|q*fLr>*|5S6B3Xm5t) zDcS_2lQ%L1RG@*X!NM7fRhhFgRV*9%aVfwD_SC^5gYGj9;i?yS<&R~FaZ6H4#zW{w zeBsrp^NEujMUcKVt>qFc!t}J5oHSwpsx-wiR?kuS&R`<#MVKE8!~Iovco~aGPvGd@EuT5{HCKU)7Zn7Fe@;8N$#l7YnZa{=aR)h?9 zS`8ujn?lIqhI0-#AVP;$gbcS^4I%lPLdfE-a}GBkLN5%2Onrp4K)<7!6&`NisRZn! zT2Q4HdJW&~(m6v@RrH#n*`;%an)>KRpGw`7$CeIwi*7F*FM`)pN%G=J3A4eUanQi9 zWi#9mbL!~|)r73&^0A6Dvf5!m?}%Y@oM@}fa;o(MF1V)-HOhw6$p|R<%zhCaq$Ew5 zJp}U@8I)8PRdx*Uy(bs25|pPAw1Xl!(HCMjU^>Hs5Yll_oYp)G=}1xnX`Rr9`0XGx zLLWmBTDd;ql)1ye72|A4P3D zY>y+iad35z8$qa{$PGe++=umc{haO4J|LGBm*$Zdhw zB=^yy$Zd!1apX42Om>j_<#6N%p+WAWe&n{mYm)orqsVQC?Q!HjHjHZ4CafCC@qii$ zRJESOwm@qV`}k4BCZ$t?tUswwL(<0DG_E}|2J2kYTJgCxvZ(rS?kW0c9ZyU|M$}iD zR0o5N32ix#Rr~s6-(ZU%g*MP{RDtsMRI4mqp-L{Qi?0w4B>$82_&jB+;q|q8+n&rv z>hN7C=5TML4j+v6j>%!(p{DVM=+=5Y0jp`f^8Edo%tN;wh-wTmDO^W;FSe&#TZ!#Q zIX4W0Q;(F@fvCq+;}d4@)%MhDE2aIY=Z0Z$>XGg_5cQ7sK{bj?y;QZ2x7)RC9kUcoXo^+@8iwYr{1t{s4F6uS&s&E{HuE~Ey9_Yu<132IPglWnpWKvTNydqO7iiGar8RcTUAC1bDA)a~X;=Dv zp$`3uu;qA^N_?dflf$XLOw0P{-pAEGYc8)k6n3hLS91mptG=`b_XYiE|5cv6diB~3 zdf^3m^=j`mS;B*Y-X7c+bU;lnpdNQj&TB~eWfLphSgafEApJ6x24jc zpg&&ZIbk=1(xAXUTI6-AjHO^2Tx;B3au8g4nd}-F zyT`H%8M1rX~EqJy-%ttc`zGChW8pM$8&{GFTvG5GGt`jN5-+3VBmFT zXj7+s%BkW)kGDShT2c;&c^5hzZu9{#YR%xi2a1PgwlNXgp6oBMQ0*!FjYWsEyi@P( zaG?*dT!+2AN_zXdJn3C{b@|r^z^lK@N#o^ovv(oZ>3kmmvn~8lmBC{3!TXpjr8DUZ zY_Epr-?_K8Ge|6SuN`MFDsVzi zzraF0{)E^@pY4b^46s~}KOwfjt1BEa0A2%}5L+PD8LJoov&Wwh-KK~&W+7MHq>S7? zwuoQg!tX5b-0P~q!DQLCB6Q({aEe4_P8q)Cdc^H!>Q#ve)o_@6x}7Y|`q}E)39jj} zBR>Oi@;QuAigHnwNaDgSc!z;9mGR!kEWU}6c`VoE(eMjNgz9+=hHNp-CgBY4;Mkg} zT2woWDQ;9h7i#;^*+0qfW^raI_`u2mz2KJxW2(;Rtnb(e zzl}^cR*hS6ZBUFF12QOc9VywOli=|M26&AE_!1Bt6F2?nA85YYe zdMhkwUx#J%!Uq=P?zRkz<%+o#7PPO!!uR((*T}foEW={Ce{F>Y?HjProdp*x?AtKz ziSixP8bD%&gBlFtC?xruo0UbQ?`Gx3+iuo2D8^=$L9uLBD=1!@wGE50S!Gx(o7D=7 z*Jf?QVr*6!7RzR}!s4}A+prj$Rfff~S*@^mZPqp{#%7gav20c=EMA+n28*=KTv|vC zO5VZd+t`$!uQrvqh1DTf?c*+K!L<=-Otq`+VuKoH9+T^VT4%X%nalqypP4nJ>_>H< znOeIamJ3}&7KN{gmgOF_?^*ofi0|5aPG-3_?0eY0Jm4#uo|9Q_+4`QQ`aZJfWR@$b zzQ^V31HO1~mOwBMM1eD8pP?-)_$V&nXGl9*cjG+Wb~P=b!1o=*85Pv)Ry;;dCM5`T)IYk`ewprmRHTx z^G10*WA2~A#U?@}y8J#uanS=Vc0wxbJf5LAE|rdjE!wE`TNU9iOYXAy$2V+oZ8nWi zLD0C^ifw|eZKZfH+a|GcdQM?uM z{u1~wj|_l{$^ugW%N8j?A83qr23-?85~z5606eI`{^T64vNjS$<$Xru47ClY+_!-# zLqCZEFv3U|zn=Z5IF?3-Xe z_^v2V$J--SU7kUm_%1lPq1wFl-`ndx&gn6u<>Ww85A;V21>HeZ1*#US1oihJ`RCI+ z`yB6*rSNogH3+`*AVmRW;fyqAw3N;-5qo>j6n4euRc2~(p;X6Ssad3VP@_)r@ZaW;Ai? zH=|%6{l><`lhMSf-;9F6^cx2V-TKYw7twDzL3HXjqu|TyH?DQ`&~LDurc&@L={J6; zSf#Is%2%P^bR*WK-_&sXiu4V z!|68;5W4l7!(T+d=>*ZK-yHq|`i*NHJ@gwa=U1cO_@QEzz9K4Lg?`hGSeJfN!|f~5 zZ@lsHS+lQJzwuy8mwr=c%U@f+@k7OHhkaf8jSI1E{RT_at=}B}BKnOAlTDJF3Hyyg zdmy#zd(BN`jG}_^vTvTFbzOG33Mj%OHH%ho&a3Mu?49?EKJcXzdTd+pUu|aj2DeD0 ztfTLNG=E0m&GMadPpek^7-tbToKixLx?-bzZN>B4aUOHH{#iioHaxSm45FWBi%o_Q z{xj6^|1Q|9=24pA1?~rg?c-I|;RQZEAlhU|}d)VDo57rJ+wd4ft2Y= zbdBbVl;Nv$4cZqeZG(J$^|-`?kU z&w}w4ZBd#-1^RU`R(%%4B|q?G7o#1Y#h+YvdTxBz1(!2Trmeit#ZGHfv%SenNm^=yUu4`o;PG(!&~u2@CAqJlR!}o1e{_ z#)~+AFa_rPhcx{__?e%88Rb8s0j3w*@Q-EADVDx7<4DqdpNRPn z9UD8d)DFd~C0XO6iJ(Yv%&;kGN!s4?gaCmii4_Q7a1o{RX*JJY$yptbZU+5$)Z-0Vmvrl>Y9>noW4b2S z_!_yDH#dL{3!RK7p1$!R8cL6y{2}HgWy53tW}w$#wdMU8rWNXZKx**}BAm>v4^c0k&bvtOC5qMo(bGjabj3}-h`asc@$?)@NAVGV8%%}+@EQ3V ztRMXXwi6n2pZ$CEL;P8mS^U^%u8AamYD;1aDsosK=j8Bq6bid;BIzCg2IONmx)ph& zynHkvtbO08+@A@efdMao-U${g2pbLZ^V`S3Xm^Ay2Z{Eu(>R7SZ$yrnagHeNV^9L9 z3vvb{4#{?*RC6hq$kEm}`;wck%#7ygP~;><(=oE-y?pM0_Sw+$ZqQQ{j~8mX7bg{D(s2Ax#1@i%Br~592r}!bY%n)%8`N?O;f*A?nMcJi9^GoPKk2N; zy?+8R#x`D>dn*%8!hdbQc07yIzm?*{N-$8PV-D7|u-CrI3I9_*@eME?6(5g7Z`G20gc^jSo^y5`d zkGjT@_z)pG8Z*iYx)AL>G|5d?T%?x%F?hiuqbAhh`N@eAQwntNnP4Z!lL{Q1SpZFt z3CiFh2HB#@l^chB=JxiYdpYl*#X)P(4ZFvd0{iK~#l*L`OEE&V^E&QzA?XC|Gf6e< zV>1MA`9yK%kzbF|O!ya3P%1ityBV!1S%7lbsCq%^bfz2fo_pG$w?F<%ZP^i z?kCtJ_jI)JmWzvC6_x0U8lYi zrLq?k9sG`%ApspF0%M?kQBe*5+ReU4|p{rW$mR=~{SJjL;U!UayKoH!8U zey4|Q?Wz}$BMH*n`qyB?v!ftKat2zXl1~OjO86r2RdDm6&gmOl-O&gKDa;KXQ2Ya6 zeA*k|-@`SHzvFY&Vz+tYk*nA3gifbQIpqA4=u9ngq+{X*F_K|Y0MDd945#kiA-r6$ zayf4vAW8vhGu|&OFIM7c3bSLh2yE~i1}^lSrI>PKRU<2TDa03v+o7fzBHWl|xX5Cy zh>VkJa!DTxu~br%l0iy;p4~$;E!f=(s7f{{16bqjX$8dhZ+|wJdq!FQ7V3xIuQqrK z0zzII;Uzukw;ajBS29&C0otQ;qeOfSUIBVr`A7e=e5w4C{aN08;$^j0W8tpx7rhhq z#YDNWz%s%J^!gMZISG*1T#!3nfeiVyJ_Ex96ypZYh~zMkTcM)}$mJsNI|`*uac1XP zzliv=i;LhVNWdvCg~59$m%=Y%9wQbHpZQlsZ-Y#OXq8uGUp|a@tq41ke~KGCQ~x6U zq=~#run#2yx;`Y7e5jskcw4)2mO%&6Pp}U+2xvjR4`APlgmu^3Rh$;4rMUr%CWH1e z=-qjphXPiox*{?xpt~FYjYd%B=TuG+sFGo_RGK)S>7@*gl-I`{)4BT^vL8Obr*agT zZ&0y*y?abV450U@>6E8k*)vDJedt-VcYt969=s^a<=HgW_tN7H#Q{JoyyyfBi>oy^ zZK9Ba7MvZuc}B=VP?sGpLUw?Y5oe*)99+&2nU||s0xk(HRVd^^ZZnt!8o*>M#*RMp zY?CkwS%TVY$|od7AE631Fx5DmI(f4YRZ;2BsU)d1Q+IM^r?B(?MPJZxa08C(&SneT zuDDeSzmHK50P;d5fF9)3C8&&mrncf+Y8`<_lL*fzQ915Fx#GC-p(r{i=)<{&hubSz z5UdI0@h60?1MBlmaOzx+2gB%%_&n6fQF`>qo9Z3WH?!wYBIhJBKjbOkFgisH5Pu6k zd;(a-t)?uQaSh7**d3s{zrg8(2;CUgpvGke_t#)DeIz#8nRsSRW|h6}&hDZc==azT zzgf@;ClJzj%%g#(CAScsXH*msr7>e~vG|AcZhP^jq;~m64jIztg1h^eeC_5g<7lr2 z=K%%SKg0=qrgSOZcmxVpKcUD>DJ*u?M6!(kK(#F9jNyui3aL< zoZTE{`mbz{lOrTSa^3AcpZ4xL$BXMh&-G0y?yxiXfrxXM!_YA3n249wSSk6;)mYwo z0Q)`>js3FwFdX0d`Z!y0mk-?6?pNrTa@N3+fL)^ZfX)PpcJ(#jFr<;+y=JHufJ$K} z=*}8EQ}u^qz||!OnL4t(#flFcRCIm|CIh)7Sb9B12o-f6eyqTcrx_>jbyi+A8 zy5=+qJ_1DLAAgb zOGwrX?esO+23nXeJY!V7^Iv6)m0jys_6??UuH2a2Eu!JYEafuk!YEw5_Sby*MV2RbAl;rz~Fj9N^H3t9K8Y^NU)YYej-EtEQ-n1T*BEqjU*q8~ z82&CE4hJKQjGUn9U{G8EZY6b&MdJ+=>a?z(Ut!sc$Z12sK|-ypi;I6}2>(nW_;`s3 zNu3hja0Z_HNnVp2RCv$3Q^bTFiu`jL1+KoCu^UIwSBgLLH*W1kc2^wC(UzHsAkfN3 zLMDEJW;~%f*&-7f-NBMw(=C0xV`EtCM+*YY2;=`Oqb-uWp}bEgUQzmM<-$ z%I~PYsZlKy$lLuqHPSWUz;;ounGBr7EBd?^0*{?;vgazi^Kmd{IV4G)WrlM6N%Fac zNHkBAGkt@mO7i4B;;0Qj(Tzn>zid12ivAZZD6r%_cXq`~W#HU3Bb%zh#&m@CrFR(UI zuW~YzO|q24OkquV(N-8;!B}ntDpk|Z!c z*Z}nu!P~-anDxw0c={mpi*=x2gk$LrMq2L@P@hwA*Ac6Jeb6)wMwvj`GCKtQTR zpIf~6owAvINkXo>1mvy@q={Lx@d6hk15wGuRQT&cOyxvTlHt76PbbHQT-Qw7pDkTU z5nVq)M%;9aBrSQMG*Tat3y!8A-7!%{!O4rnA_NI#G~KUcDhazXS0{6B%7Gfl{*O@W zdN3~N3Bj&n z^Sq58xHp~m(+U0?a8a@!xEkOyb$PD^g4Lf_lsUn7nb#AJPbkPysMERhoDP(r3|t6( zmXdL1q7%JufVXiT80Ek#VRDxh;P2FrMRq$alH#!nK4`yn-~-OgYTK1?Nlqo~)nJ1HxGOk2Vk zAL2ds3b8vakVy`K2Kx-DAYKm9=(F^j&i)>bFYQD_4$z_YyxlwO)A=L7~-PLn9^1oS(A!aq5ORt zr*K8Kg=K2GD@r&yZ1lKI6~ew+p_Q_(TGT;Xr7Hy^IO_(&G_`ebHADH9i(L(HZUHkFW)LR$M~KHO=1yj_znW$C z(t-_togBKm4fHWoXOdlsCpTsM*ucz7C$WH8mZ)L?Gb!Ci0rvOEO5;$gN~2N>&O)^m zn{aDT&}Uv+FBDL_ww=o(ziqixMrPS@DNutScj{v}1lKA?UoY_AV9b`biOF$P`)4MSTCiI_ zx@F=kUW$BIwnP*DApWu#7yd`kwp7|LdRs%8u05zx#gnL(Udw%+j1SGT{1j0mB^e)o zd%GP~qun4iwHQfGm!N;mq5m`)pACXk+n8_h?auaCGghcZlRWVUX2m6d>BqYaNy@4P zK&&_!?P{|%bNULh&6=jQh?0ht`eHrED_DvR@o41mdQ#;VnwWBjFh7B%6*VbyT4^RJ zI)}X97_RK&r#dhVP~@Ag2J=vZtv~}LAZJ00?ma(N5GMj^5UvS)HS{RT0A1&07q;&_ zphb1=9BUEPR!KYWfoFS0}C_&a|4?k>_ncw1_%)pJIZW<@Drb)-roD@?DqK zkXD{c?MSL!KCliuSGQ$BT4!~njp?(x0;b_OJpNSFOd)jC47O2hGxhUl9@kRWX~pl{ zqB((Ka8pOvzB=%w1$M5Kp0FcXka&|Fx<7eC&e#L0lAPgNZ1JqY_&Zw7RS;p37ZGe zO7_AWb!{YT=9$X&AwPaxgjO184Sd?)6|#oS{S5pAMR3b|d{39-xbLt(4KmwnX6%xo ziS^I1y9Dl^fbZL}1NILxOHcpnZ|C-M^^cWzF%OibTzBAY36*Sp!-q9@#R!lbcm!uqPUQi6U{q{>-eWVL|D^h6)46QB$dTIjD%!!M+YX>xeM#Ei|bz zF<^nfGAd$=zd0QVN;sEcVJow~s-WV~A^nv2Dm0<}TA4da>OUcC#>GD=dT}Zz0BALZ zB4~q`sjrA4U`}WC=GQr6%I^H<7|(TzF)$%23ZAv-`{)+{_2(rU;z|i>byh_PnNRit z3A5Luc0~e0rQ4ad*mU$wSz%j{7-Nu@L0!wWuS$prdx@0rwQ8^p{-eD2oR;%Ok`uV1 zv<3S$E-JxQ8g0jk`bpg6_hbIsKEfSO1)_`y({W0&HJL0A|tzB$C`gU?wff5A&$nd+d=?p&5tMy}Spd80htXmg`eSKZ5t z#*QShGzw0J z$GPus7bcadaEU=tcQI(T8Wm$j#+6S@EhsC(+*&>2>BsJ?n3L5nRFsjS31wyqeOSIj*;{>ukqM1mbD7R{`p+WGGhF9Vaz*U!Yd7r@qQeCM!ze!VD z%|?<4z;4qMcsn}l--`T*!>k@C2-`^%gI;08S59qYthAg33>(IQ?{A{kUbnsaOth}D zf`t0r2l|D^`u2ZiqXX?tx%)Eb+cj&DbT$2fFb?JS*>!SEtFD^qkU5{qrjm#mK&hC^ z(n!13D4Z{rFPj4sLYB6_Cmo9$LvF0?xf7G^*+xYhDgm<;l5E7TJx0i&GGZlu>iabJ z{ij-*gswzcRB7oD%GoiwX}cAO*5-vYuuXvwOi;kFp^;-WVIjGq=!^9P$!X8AL|IAp z<)6@cvg5o22h^7*$6YCWuI@Y%M#{X+aWIrrC2WZHDhAR-Qe!zb2QbF>H%>f-tU|~* z6EFYHp~`0<{lo*0`?>~qZu8`t#)n@2iz|lpo}n@>&Vh8?EQt_vt*I3R`>gqwV}Xp7 zNqEd<7@jcVi;>7P_o26yfMaGI6cK7Ei7&fGhJ&lAx!Zw_3sTK`LFA76B_++>255@7 zBI8KQiq$ie^#It;YJrxlc%i=|UDEwG+~TLurJ_K?ToN7X?Y#>-Vk`_HO-CgD`t*zI z=Z*y8B+PAvMWgTFSpd<`h9&FBjxHmA0Z!+!D^*Zz(S@lzIU_9kD~(U9RbCVPS8v;y zNHZ)5p0Vn(fbz!hBcWo|SU}3E!hJyH@x00T=9@UW_I93M@}uufE@iQ2=khhIE7W!k z)_7wpcObvij-}Y&PeF!jiGn4^a$RPF>yJlQ1!f~fXj(nz`r!lKAxXUC;PivUdeDR9 zW}q_IDx&U;PAN^GfGnOF?L?Yqn&s??;e%&~|Q{oHL<~&do+}}SdC!u?;pxa^_f_)Z~Vi# zbEOUTFW$xKIhSTbY%HCHz>-!0FISE0B$3}!*hUCoF{Z+B6@Js>tIc$$K560?wedag? z1LRA*>%=dwdOZa$t!!UMW^~*#4XJjom|rvWE5ItA_EWFJuK;OuuZW$3eV2reYa5ch`YrOMQv*>Or zPuFCkw&;~4(4z=b=4fXYZ73k7T+&GFm_0j<^BdZaGWGqHKDI-vh1Ia#V@bRY*7(kw ztn5cL!(LVPl-p)uc0j{d-sEvHSZ`ola6AbAXaz`8t)Gew08UjYaoXhf$XvZU! z2hOp`3W#jI$!+aW^ZHpcojOgW!GQaM^RD+vBPcnXu=2#hlQ~UEhrOAku)|4h1{&jQ zIY(_|JYC)xA^k`snvI2LJK>JS9DyKJ2cg_kDHipyAfA;;^G=0x=#$(KbhCA}gU9j>6aSB5PSBk>CaXVAa>jlORe)cD1QPC2eQQo8}UTyEde zRirM48q|y-OaFO*Z#=$(A|sO2)iN;oAd0A3eyF6>5LHI0b8~eUJp}tepX>JtQh#b+ z>QanyEsZp+WRm9$$Jzu0pZnBfwci&RQJ|hs8+6<<#8Zywy>7=AZQMXTt5HAWSjL{tjOLeB2M7#1IsAkTH- z6G%9;zUrs-f708iZI9Y@(e-Y1lhJS&X-T;LM7@PJoHv;B|4e&@We3Iq7t5Fn7;)ss zt<0b7?PD-lJi4G;9++`*B)S=g+wi*Qm|Y`TfX-Wr{k%~p9)0Fu zg9Rp>0#q=; z4!8twzj5#Q`)JPd5p7G)Y(0uaF^Y8O@yIl4wtWAA7v!cyW(a65^4mJ-lhX4uutEeJodKTqww_w zt8^6{E`@JRIIzEma02`2?L4E@BL&s8{BY&S`4>-MpeT)JvykL?k0(m6g;~p4Y zh#$WI+!#;+DN2V6CvbZvRxbdfokBt#IS)b6FaCit1g(+CoPbF0eS{K#r`(=gD2-0S?gMQx_h;aEovx;6rH1 zp5;tLg<$~g1X@Y9c^M#?!Uaxe!#=Ul5pb+?uLZQOjUj`X66}k%K*X9t_8_t`yg_SM zc`tP>*LPqI{uBxhB_e|zsOFJHFHbOG#l!l>J`TBqaFkp9`o{Zn$DaaYhoc2$Ng@RJ z5}J8|X;wI$Qs?~>Ol8!?G|BagMIN#JUm-lYkH~^B%>$poX^PH4XtTJ7fYb&rR3Gff z!M{FdX$&<96$`@~^qDo`Kb8uj)p1UB9%)oNyb|*$^FCaKVg@6sRdR4KMgC)Hm>?R%nf8|R-*-oG#;IS1+mYnM-g!948yZi365Z{veTx(0uNszz(a$gTx zeE`t6bqAYXhZ@8?-z~3$Qh*#?RCx~C-SjN3j>~UgWlR>mxI5jNeUJm+E_bvQeXCE@ zoo9ybcYVzUCsvbyyoBjNjWBR@-AFqBxOylAz)@^uPh#R@E-86kY@p`o!h?{k~*pIUSR` zZ7@Z*_r<=~0xd<+$t`nKpVN7Tn%#>>gSe!Vn~ljYon)YD;=}P_y&T66TIj+M$4$4j z?1{GGPR2Bj)9x%atRd|WxO5Xo zZkUakX69d1t+ydt{0h0DLS#uxic6ocCyt(b7s2#E`)Bm5F#{;A{JfWkJNJ#;-*|rQ zGu)QVnH&YPkdDSBW{XSe4Xx?(6QaQ(bcg7}xGw}PJQa|uBqK}q0bD9yVo!Kgt|7k` zfDh1u0b_Th4S9{{Q?A~t!}cs9c9>hqLhEKyz{Ke9AU+ouOGaGvSunqk&+YH&wv4vW zBkg^?W+L^er>Ccw@+l11&nRfydS7Hi+|eTK?BgFx2`uHLT2k{1kgT9rH59Q^mJ)yq zm0mY!AE9L*%z@EpIuta71xg1pRhOV%BZ~+f60!p!bwBhSMu*i&p|;a`9-D%peF|Jg z@1WC`a!Z}X+|*u|3b_!(8d{@B@HjTMFkDSt^w;|A+U=#(wRv?WP{}Lf?0BUMu zZNMtae#Zvf{*VDa|c=X}$nHUTv zx9RqsSgQ?yj50#F0x&<0fwF&@w}#ngwimndqRC~3XUcouBD~ds9+(8?_HzE{emmcn zN}QY-bzIpv!>;cAsm^YdV2g{R^fJ_yG7nXR*Fh}N#Ptg#$Ce!f20pnNWdbC14_PF9 zqEO#Djbbgr@NI!qmZjTd3#A9BI(Q$5rxz&aln;CN^kT z07TMBgiut1{$`6*bOpcPC6EYUCqe9sHIMl?SJOOC1h5WKK{OLU3cQl3N-xQHxVwX-wWP`eG&xX`8r*EaouEod%--xkub~Ln16HL;hv)l5MaTYAft!o z{#2G(SC8vMUDvy;{s$WCQMJ+!23L;lk=kJgMvKUW`poYUMhOE1=F&*0xK|xLO|E z{}>x)@^NQJ4g#?Z{oUUXyIc!32wfM4oMwQq4}y-ff8nz(!KIk>dtj&si-6xK+S&9! zB+YZx%xDz$s_V7r2&O@NfAS!ntHSOgf`o1FNIU>=l!co-6@mY1kYqm>NuvlzR#MGJ z#0oR!U7uWG$R z`hJDgstL_N2tdYm_*!uR8b_ec)v23BTqf#KtF~*DpB$e9r&2o^K`>aysCB;YYik$imsdx z4)%$ayTiOq_V%by1Yfe=GK6yel1^tCVD^vT1k*!YP!^KrAf=$7f`D*C#Um)ZB2X-& z%r*~FWbr-n;VLky?~Mb&9<7H?M>ah9)rFNot_ybYq#_@5h$cJNhAx|I{uP9Hqc&w@&SGoo# z&xTnkRJxa7aQwKYqRTNt&&SX8&1ck<5k71&4N(&JM1tDLA?G)HCJ+MRr^OEyGM;O;L0z)13$1TfDd2hXOEBMTEFbo355-t}Ky)qX$dqnLKWd~kwNE*P^; zB|9pv38KY+DX*wC=$S*{I-+C4==AVY2_;@|>#u4ioJE-VJD~zNj8r+khbLA~OsWRh zMk19E!gRD!SMc7zYI+H!C2DZ3ye`F!s_eOy;b%w~)voXs<5I6?Fc(8VnpN_@RI}<% ze~b>JQ&f}W=B?Cw0~c9-^*=%A8VTrvs|Uc&slquCZ3jnwVw`qbEM}4{A02g;*Y&K4 zIsRF!=E>6~-*5qhKOR6vCVWn)ZsjJ3LZFgIoiT9aZosPuG!#ll3bcSjLBT0$nGQ`w zh>scO(M)Mf4^KW4b%z%ViCpiRntZM5sZ!mi%+f9!poZ>OIXwT8EwGM4k=^HEtp(H4 zMzIJ?ML4mn=Or`9&HBV^#aoA1*hnI8yybx&W!jwT$!3z$CNU4Zl&psp*dmfZo)0G2 z@_%BScy#F#v6ezlp;#j=-h!4FyC7{8Y_J$elbTuax4r>jw@<@4Fi1+lI=8yPU?-54 zcsffF@S-V{DMYu_vwj{_dax7%;f&!#9=s$JDdB&UdV0KD6X9nELz>}wBPr5UXJeSW zRD1YmCk_DbfUEk8QM9FLQc4 zvn(kHwzp<2fK&d}Lq)-Kw`$ zXuH)YaReC9fnH8w3GPHtD~E77(3X@hht~5fukKyTT13079cUXi|LeS?xpCF0eEG+v zavH3=Y9QM&yN@rj)zq)aM-%g>+?~2$A<|8WtHM3vPAB!l)N}`2$0REITVYq5@l|V= zdq~?XWw&TkR|t6;;!aR=#Y*bp2zzS@@Hnai*4)k1 z$#{qz9L_r2$maR>%=n0CT!sld zReZ&T<{qr+1R;#CNgz+}!=^V4>AeYI3n&5~#TF`^bhJp2TIy!j7BJB~xSrMmbS@UJ zjG#5#oC#NFg3ro}Ue_I7DIKW?JTPc7(?fr|`tD}S+=ytIHD$>&v%~1se(1VO+P`}{ zI7OK{cf(%^&{DThPt~`HtX)-jy(GLar`XNk$!O>$M#!4z{ADFhSKdQJ?Y?J!5V1;^ zK)ENqC?ceT+0mOREljXBVv{#rs8_kV=rZscCTsPZfcqg9CJ)5>_G$BF>{(somrhEYw^iqo5k+vj=<1* zmi+@kH|8vkD>>7SH@}#XHKAP2Xy7dY_2IT6ZC(keM2#t#7148ibmDq3S`?TV#!iAE zeYCMol0N-R^y<+hPog}Af>g*#`V5KKY+<`3Raz13H?r|dBtNdD!|)Ko;fuRmJCJO{~Zy`>+NHFKH#Jj%00#P;F|tl-PZ~UhB+2#pVXt z0?{veXViN@sg5enjyge%nA4n^uBOu!3up}jIu~m?|rhwOXfcKQkfUF%$!iQ zG{K%2GNC%D+;5S9O>AVcgSMl6NoN9ETiyeg z*Vf*lx_lP8DL`(JJR`XCk}~lTynNoWR*7%zDp~>y5vR+6M51Y5L6=`Pm57oSMU`_Jw~&?&2?! zG0G>s|4h)PppM3;YlU4ir zadp9ZgCbD9Wv$717egJ&Dn^6UVy(qvOFndvGHq2QOJI;5zTqLf!b4widBD8D-m;8i3<1qiElZkTRuAqeuC0$-rr zWhH9rJVo|JZ}+WZwK{d4x`;2WV!Ct`dUDsNRHUIixHMp8SvOLxr)LA|A3fmiKvTno zt51u*zls^k441+s9`UzjM?XSaQ||9=QXc_lp{;BP7>!S5M5XnijJ3OxzbD)19ExjhIt4@}U*4C}8e)e7VDGf#oyB zRzar{YlHp6rTTDy=hZ%bsfi&W-vNvyFk{Xi=Tq}fv@Hv4f?56wwMFom&{aEV;0)<= z|4U!qJi&fZUgF&ZVZ^{Egja!m35iV^JTU&-?X-;F-SN zttNPmnJKdSRhRIW&#(UN`#=<~w+hM0b$8JP4g0IH1MgN(j{LhFIJ_PWE+P2)cXgW= zbKdo?clOQ87%wi>#d|3B&(wZJOqia3p*vS6M%)?sxp4I3G0u){C_g^m4zVu?ufSlN zELryMt>ZT?%k%a~AMXDC{>YRVK^6puhfhX-^N+bXHkEAU8g>PH@@e{d;?B`=oRAjt zz|Mz#Z-8Eb6Xz` zxNy_@yP30tVUPi@)<(I4kMP!IYyQu`DMxJ=X`gh~2!S{HTyZL>4nKwdKtEj%-y&U0 zl&!+yTD+tWX$SZR4H1q{GKw;EmoBd|QZf}?8quHo;KA;r(NHa2luV9eu^fd%&AohsSqKi&4pPPAs zDEmgqRqe;j?7{5MEITSLjvEj%<%R%DUds2l9ia-^U;^3`!Yc~bGFb>g^GVtsyJVFN zH^Lr3V|yPg!FOJ}3(i7Y*OPqZ%be)?y-8;h>pi(Nm!pX!m4chZGUP8O{_%vcnR@aH$na^gOyz)mxXtP;uQn2=;q z(8Z-ckLd0gDnCe?TJW#!R;BPkX4NZ-z_ zAy<;?q|hEK#-J5#ICkf>zCHgD3ikxdSnpED{BbN2{*~3tsz1 z8&f+>r}Rwvvm8aQHoR!w`jL^uJIDiY)>?Z6A;BqNhf{xoTeII zu4c;}L>>#vIX&A=`w<|m7LXn+2F2--2x9oP8ldCroSDw(ad(Z05 zRV*ui?c+9Ope^=z6OcsBjZS^M``R{s}M%T?Vrpk7Luns&YPufr@@ql@uSu_}+^P7)eiSQP~si^f6p>JRX#0S3t`Dd2- z5e>1?g2xyGqiKdHemT1S;Ln>?0#8k^ewyhDPo|+AbCFqIXvR(7O9x20uEIG? zEwKx-OhIN0?NFK#(Y{c4fwtotTx1eDML^X8auszU+lD@MI*oC^{0Ga`>|7>53)X&E zxRBP?);VdBXXW}$o{e}o7U66axWm(~cVlDkvy;s%(8!}7B>X&X=-q8i<}@c7Q&8v! z%WoqkuP}?ys~hHM;pQtA6Y$6a9zDQLH0PR8JU`4jbsJtk?&|NeK%_ZC{AKTYtnV*( z1TT39BZn8$7YWGhP3lgM8CwRP9*C*H-5d6dQ-GW=VxeU2T>KvM3?J!hQr4&AKpzwI z*ebD_Q)4gw9Ot7F{*^V%G@mp7TC|ao#!imJa@<%7XvF^VbO?(DOrtBq^&~Irf|C56 z2wQ$;NW7{wI&+@m$gXfBg{<*?%|CSiE-v0K_o56lobLx45J10dSC>tto>zVFU*Ir3 zqA9^H?gQDq_X{{Ei!~EoMuAL)j%>JDrxP6+N45D7lD%j{JVMXnHx%}a`rNl4Pc|5s zNSsK>)F9AN3J*ZGK@allB*ap_n+xA)V;H_yMw3H-H+ZvqoY{XqBq(IGs<1R5Z9|sq zf_f>P)e&@2ZRV2h*3Jah*&L4pi@xv}7EH$V(BpIIe4zn%89UfZvO8n9Qxr0O)kz1yq|CrLK!qgH8ZA4-UMN+V(&IoYr!NX)V zCy6X2((#5u7kK;ansCB0q>g0T6q>vP)UjVrZyzfTuB!XF$>h(AMC))DTZ~=8#`M^;7;d~d|hQ|*?VS$kTW;L=sGGaDQD)*AonKPtR;AoEi1g2ZN0fYSdQQ{U#Cg0xHSO)-SoLlNS;u2o3y7+< zlJB=9wq~Xc39>{q4@w7$9cQsuqwq@9OePabKcX-zUMRbAxMn-Z&Z?(`#CvOQba0oD z$tYz`4yP)ns<7d~#lz_&4l*AJZ}C(aQ-HLq9$3ncr@|M!$7YSYV38jZsHWBTd|wz* z;ikr-+(#PakdPbhREARvfWn@vr;5KS{Kzk(e1mAwNM}F#v@OmjSP@bMU74YQ;#(I%0c0(<4d`7)_Q6pR_-t~EH*zC9%HkO-MP|s|VoUmNd!5983ep(hOy{wT znMIC0gqSFN?AlgM-K3 zwD*do8Q>MYAH%F?nIu1TBHEz{T3c^4*o-O~L$JK+e1M_NuY8Zc3yhha7 zH0e!nx5PerQ7fsfVO(BNy(msB+`@W4(Mqvrx$$SY=xbb*qO0UKVI^CQ=;2m$9r&}{ z@&K}ocu4N+c-_`bo_>1!z}U(PtY9k!WW#<`^YTk2KUq-Aj3w>b5d?}$zTpM`9e6~9 z59q9js4b2rn%dQu7XP1r7ZyKo0(5L0ng02H#!(6H5N}QJL=-zZjYvLnf zq{G1GR$ujtV}U!k<*ZebPb@W|YddTner9tU$Im8GBsUxPCyJ>77}g47xb8m`$O-?_>b}~zICaaQCB6GP}0Rf zh!^aYCrwrN?ex%txTCYpWG9j>L;~Ok4?Z`x*q3q|tkj_o5D~D{_cuRXk;Y=zgqYDY z)L0mlF{?7d)Vm`8SbOgK^cx2dqS(4Iru+FOR z0Xcdvd*}Rc;EhGU7GHhY4bIcF8d49zdkd1*C5eRbQhNlH)CHgL(j-sGu{F}%**S87 z%`eTz0~Qo?aQy6VG(S!><;e1C^I@6LG*+1ephGjklgFAZwZ~DCt`jB$Xey$<1<2v? z^_B&PmeZYgp>Vt1M|WHBhfnfDl@RdZ8$3;6e1|ZT@`26`Qj`x;ym?zpa{=TE@Ix*J zBk}wzM{wSH2!a{X^YBOkkn0t2u++3JjT>ca$D^$h8EKOoM&mcWxCV+BQ+U8Ibt@+9 zo%?0&dK;{>g6C|a2nGrpo1GliVUN=aL=m-EPsR>~6oO`f*~-F^ant4N7F=eLTnZ^^ z0pxrJKd=iKd>`{DmWSe;az&^g3J3HJDYV2>Xq*ieVg@$-69$OK0YwN|&Tl}lKvRS{ z@wt@AatWsN@|!9|OCj zRgwk_(!Y?78OnxDRqNTgT}x?cX|HqgxAO3Ac6Gno-8=Y$2d7VKOKr+u7s_t!?+ z81U?KetElkeLpV`XZY{zVOf4dcTZmzufKeK*|~bXqRaPXKX>-8*@j=)f!p|cKL7JP{XfsR^;87os&#ex+w5yiQiAoh zSOydX`X&@ZmjhIw7MGWeJ(GAe`8L&q3qfkJfhj9RhKQD1L}2(X^oz8jRbz>BbCF~O zBE@~-;q#08ME9Ift84yHf)tY0?boo9)1oK96W#H(2aQWo5r~$=jOYdM#ZN*#p;6(; zjH;J4CC&>U%TC2;fyh~zDJsLg+GInRK~dXh6bTr&#HFUBs6D^_=~0K^N{Tz>r+@Kae%$f$dt}|L9j>3$D5b%&u&x#9`AaWf#RCI?)I&G|~HR zDQH_MAjp<;w50T?2e;+s$LJbacv*tnhL!UI?!499O;dnsk-KD$(<1)o*F@epUl@8&6c z!Zk9z%1ipRZ^DR8&|demjvg(NZBj8f&!k2#{# z!Z!<$71JtBN#!RQBl?cKay^;ROs$HGU$bjT)Za2d>VIRilv((;WsK;c@T;Tv4JV(3 zO5_?<5vBOuFZ|+!(s&C$D}n+FVD)Sm5Pf$-;RvF4U#=mjFP@5=iteEJ6_}jM!dsm| zL9WY>8P-YmQ~3A>&B}!WG8F6Me}j2KJ<+T8n~AfeiO2~*QR<}l&8P6=C>&Hvmid>1 zNWzSMfsb+lFOCu&xj8;9`Ux)jsh+(4@8(c#IJ(WeqW*0|8(r**%{kWy9qHO{2e%t9 zd`|PETvN&vL_eHzf23cb2E$)hY(2AwwPfP9pdB42lzL#2dkw*S!chdTW7qn;bVr1A zdzZ(e&DPcWpoFafU&Bb;X$r#s2+x6gU0$Xs=rp9{!IeEVhjAFM1NWL-%*c;Xe>jzx zzp@253ZpIPdl-c~z2O97B?usB;?Km6K0l))FeCM-ua^ouP*Xt%G5fzR=7n=Dee;>#IEzHB^$S5i6>8pemJ2>Xl7d%Qmd|uS<)TyQy${S{zLD+ z?8ETo>?rq(1(Jjo=P6Y|VTng$PFw0P&IOxKr-Dky9A)Xq26Id%`?v5$ZAr+Ovd~wO z114mts)!C0Vi?U&nzA4e7hE~7r>~;OZJfs}dYLdmN-o;ha+OW7VE3glY?>mW5FdyJ zrD=>r!h{ZGo}o+1$0;EUmDW^DOm9g3-^(R1Gra7bpA&Yx!TN|tm-xR&y~tC!Nz`!eZb z0^MXAtPVug>7ZSuG>_0~2Qq2X0qRs;JaW#^65()Ne`(Ka_wjq3ou1ko+`r*Cf(a1J zNxV4eAcJZ+kjc6Zp0{)k^q?Uiv2B|Iw>XeX+u*x>#Zf+G2>&{5Tt}~})9wq+22bR; zgEmc3J#|O}0vfp5Xs3d-Covm1(&`S;xQL|dT8zUqWxXddw5Ku~Fj46aT{}V}(h*G8 zFPPNso6ZJD1w_z$W=hJI0Q zMiS!%aZa=aIiGQY2Z^u#P(7nmUyRPy`+H{z)r`r|_FT$?3GnP&L=$PjSSC3sSBQ&^ zv_daALy8^1dJEOcgh~Q!)?~dT`>T$jx@POTO#wP_GZjQ_f2n=IKQJC#&x zJiEy-#whf42(pS*_j-UMl2ROzYvk8M-%s&B^EQTbsh^0dlS=CxG8Ljl=46RKU1I#a z_2m9CI_5sZDwm?O@H_aM>afKq?XauxvF)j4+{d0WEiQfL9~3)D0~X&J^P>#|4-liU zUxbU~O?Jm^7%Ax;Jqby7cZqDo7Y_Xj%(M+%l8sNg@vg%;sGDHB+veiLSzr^(!)9Px zFbfOBl2m;Wn#tkYL-EMrUiR&q{H(0+d6b5<09usj1THMJHruwszT)b}vLfZz*@U zL1Ro;VO!PR3>RKkdiUL#5s$2^?Nvy6f?S3Lr^>s^ZCQ-iTZI3eOvk0#*b(ud`IS@b zK;^6m@^zI#2&MNvs=|JYEERn$aJbtpV-v{89b0C=y#pO;S|!5WJ9E4{49um=r_Q&> zFLzJ(1MB*G(@E^SpEobHEeVGg1bWYVc;1|JmzT5DZ6@yTCypP?y?nzjBJ*Rj@Jrgp z$_d)d8qN*y$l>ZVQg7jO(oCsiDbAJ1hOWW6=O=i!`-`o^JH$1K-X-1(e%%9b;vq|aH=j;C|E>jOuLo%#3v{KVfOa(00fSX!Rnw%DOKph&k$NVjl zm|HC@I+JznNo-W=4wb3w-E^PnE^Tq@iBu_?H~ekap(g zfVfvTj_%&qXII;Ebv8ZK71FoIj4=dn>r1qwLwjaf0zz}!I*WoIX%Ivp;l|=knQ?f1 z;T0UK69yiHLgXJxop@&c>&@%w!%RG88n!U+E*E+VN?h82P`R*e)NU3E6Mg01yPd-^ zDodH37ASY%zsAN*F#pviHP^(;rl+{ddQ-`)?O=cr&2@u>OS@vMfxFy9MNusB1W);L zKz9;O0n?igk8m?{Whw8#-fqL7{88l5`_pi?z&$A~&*Dr*=78gl5e<2zccJ+R*e^SprO8$1wM8adtY5(L)*!=Oyuyv ztgSaM7?3Z|4m9iIyV{kkRz?1P8GxAd%(i>!xL{F%6Po)l5dqWW7d|wzc+1hy7|-F< zffeMPRgw4Gt=~LAu3RG2pu;JW`RAzI`QR?9JAXN;}zW z*-p$`V>xsizhZz9cv;>RDNqqqvSx8n_wcsw@iFpaGIX75{F~B;xAP;4K3-<8I*L9( zG~s>Zkf;y73sGpBUN}r_L%nO!5X&M=0lrnQ>kEo%d6zu)_W&Bi6Sp;e1iS}j*7!kK zIPqMtNN`#;NRmjQK-YqQSF8@tKjkOdOfFdYUjAM9iXle3@Uk=`tfW83$TkF~P3d9l z2Mp5Ga)c9vZ-9bfC*F3%xJ6V3rKV%yBes&CJ;FskqBflh1@E7#{^&R5ExPC8L%xz9 zJz~T~!C>ZI=-0rHqa5rLe7w}A>1BA}{p66=dm`5BgTmHZx*UM^5`WMy zhK_&j>8{ozlJ#D?!l0h{cXlLX%86nZe3Ho-){sA2d{637rTGL!Ny%V?fXDx)M%7k4 zD>F{OzCR<|1fv~e8a;xdQW*jx!{WdQta8=S{%$$$H%2BkBHU{Qi>iX}x~Nc&4VsMj z1nGi$_`Tr6^{qROko&n1vzoI{zLLI^E^j0k5Tp+3;k`*OLW{-wdh2&d3xxDt%X2jC zF7K|>-!CLuo^Q3Y-*5~y|30P=Hz-3LGM*)#ke;pK1ADEeQk^IfiprlHzvleCCkeST zq9jdEEiQ2Tzr1?#yvtkcCg}ISW2v2KoaEY8VL=x7HG_Xc&E~PVK!he``m4#+;v%u* z;H}$nDm=PQ^FDFCeaSlIHakq}5|`g*F&3>eE*|`6a*2wcZOwdC-h~6t4Ozbj47C1K z*oXHcWp^gU!}?5KRdJKu9@cw7e$^~2NFs7_`OnhMz_U4JT{)a<><;&p&jzX(MP;S0 zdn`HC&IKtDY%2(Czd6f(wwSmTE`IQ_|Hqn%xG}Y?5}^QAgLV0rv)S#5;vW*t454#g zwZb~X8|5lO0;pjj>$V@?{5;9u-yf!p-8(XO<=GwD!%5uMs7pDwNGxvXwH7we8=_gbe#8A` z%g(&&X3w>ao+I{j^=QL-R^@VhDY$rjGRL4KAvMbr`OVSBq$wu6zCF+R#^hk;dDZEz z@umAz_Wp*`0+wmTyA;M8Tg{qpS8YIHDvVP|*C+Vv`x>}1NW_6BY_ z4T|s#>Go&x$9~!ll#Ft_VXa$_k5wO?yLIeG0*HRuZlZiHG-%(9s9NlZ0A79!{Wv|x zAj5_1w2{a~pJ~YJK~UJvggKhI&pXlMm~_UA_v%EHdCD#JD)4-v(|AVZV5!rkd85ly zNh}gQe}=Db)2V{UMDd+Q?M$m(WK*kJ?TgD)qdJ*Lnh5IVbu!naU(G_7R*WeL8q-Gn zw`Z0|+MIOXnCwJHhABhXYpMEd8on7V{@Oqm#=c<qbKnL`I__e(4r7c2y5FCxNlM8>aMI)@ShBS}Zb)k4aL z61pQvH15^$+~2W8su9DBxS-ZPFuAdf1(AF%{xNg9)lSkH-C$R{gF8NVG}pia8yGPo z6;HI%$x0EfMTPZ2&R7rIP6M40H6o~lz~)6R7A3JI;Zo96%%c9&=PwT}Kj<}{Hlr0h zX!hAr!|k7}Y{>j7v~1B;w6US^11l^n7$K+rd|Ga_<7Zy5lfD3{IJ&tu*FzT)$;T6& zP0TfV?VMZ7_(JKf#Dt{S#7`ICggL!K<#0C4)H`~~g5uiH3@|7^%9h8Eau;yE`V2qA zQ>y&|YA?4S(PGJ=h;KOILe$Y*o_e)rBTv@KRt^$)(hmPt%tPQ*cq}X<@fw%^h5m=0 zoL(xq{OB{&pz$Ge7SC@C0uN=81d?0q=L$MxGx;6bD19?*HqzyJr}Uts5tjt5Lme=4 z-$#5L2xu>^+D>>stJB5DT-_amBA+UoP3cMm7aVfvgFLP}@6cOImS{0!DlwWqzhGNldC}q_ zoz%g8^bjw;6JlPfqL!eIG6)Ydr4&&rDqC_}p2i2HwR~!`nPolCR98@eE{T zV`5CzwqIphl?5i+K9;K`c@^DCAB8J7L&2>hH<%~>l1X{3>ZMbXC@)FY1eA??2<6yS z3w=UNdGYWy+={dT#i=~n3tr`sw_<6U)AfB%k76nnU3uFDB1A+#wPyEnQfFgV*jA_x zhFQ#@zts|Vq_0$Kr=8ZUv@Jzm`{EoFWST)8O-;Az-zTZQ?NG}+UP(Lr0!luroko7+ zbvC@*q4Zm)Lb&x;Ph?ls@NBHcjCqGkqhepk733Al>0z34X(Fj(Rs>LvN(Gm7!A!c# z4p0p4I(|U+7{wf_c_K))Kc2Ch6TUC|$OQ`>fjL%OY}+y%g?ZGPj0207peoOpV4^j! zUwTK7-X>T^Xf=YctwwZ4`&p0%TA(Vzj5+e#-GCpuK248J?8groSNSrSO*tPVsvVB1 zsun(;4mOJ8ed^FBXHD8cRxp8X-VmCQ|B_8inn-R4$tV658F3sAq$Hm}F_K#(OaoD{ zr}j~?MQ^?st|O|ZhB2J@5V}GxlqNE)r!u-(XDKT_;o^87HHOxVNyB>LqZ|+52}xDF zUn-%|DY)s0qS1-lDIZBnjYyBpeBwm4-zQVj9(L8B|h^L3mKH~3Ik zp^_l1dWjmtNtWE|ig3R~trCoeJ0C-$IIs%w{W767pU!{ zEYh3CJL4$^p=lh_b&@3#W0@{fU|XVK2FOtRtI5?|OfIF{Fquk4d@mM*?uaqw{Wve6 z9ydkJI^dLonyJ;fKQw-v=)9Yu_mI@(>r*r{7%UaP?$G zHi@ydVo%No8YXL4N$DZOXJXdAls?p9wpe+!-HJu#QvFC9 z4OJd1qrr5JY)UW!7%}NtTU5P>&Se$PoUjAKGc+4hHPITVoZ2{1DPV_vkgz{ez`Z;U zb2Pw?-91<~-g0$IxW1uMBJW}PnM~Ich=k z)8`_qt@=$)%z&p8Nvsm|4@jp`DI9|+5(5cK;h^@qPMn-b9G}HTKYfODkc6>PEiBJz zl05@w7Q%OsJC8|vWaYMeweU+W;`Lx_D3ycx2ecLkq8LO;y0=MT3ZIZT0{zjZ!++4- zm_Bt-e~5x8j0MjUj5s4jE}M^k92~irXyoMDQ)H8xG9xo&5MEU%W`x3ah_tC>9+#(d z;JyqQc}fv$Hhf~=THC2EDhgjYt~Lx z?%UObIsGy_+&%{u3e++gTnV~=7B+7e=B5KD!e!fA7FXj+mV&+L*|=8tY3?vAWWK-z z|3mr|Nea9~8^Kd?>Yd9|GFS4Z|Zl{r+du8c9^dX|}*u`Xb6( zXIaxdWg2{-{hGy=04JOanUGC4*we;YCIt)rrLkg126Eun_If$IuQfe5BslvYXI$+9 zeZ6=Ty0qm#bU(1cpnQ9TcS1%aC*C-us{PtgJMJl&eXi{S9Cqb<5`js6@gY9NUMOiY zTTMcC5;Mnqk>tbJGxp2tlQ(CspPTd<8)D~X8ofQ`hZ#a}rg$<9&Wo?Q-Oz8ZG?vQu zgm3*ChPA3(uI1Rwi+=v1w)rvWm~6Ea2;BX8yVsy|>)_39P||Q?aB-N4>b6hny>?<+ zqrcosnK4(IP_DA?$mK2c{G@=E=hbcVV-JVaJ=}7YL!z~lZ|$}VEX=8HTU zwGNhkk%FCWhuACQN5ViLMbZ!mC9q2P_vv;6Co|jsIqCjqC6M{|>u-8W_N%ODU&^a* zq1KfZo5nS)Y8pf*C0MR!O};6mp>a*C+5SA-cQb6zcwD2)MN{jDDl6(|WICLBzNpA6 z*kr(!t2=g>GFr6u3DZK-awsH4^U3Cx6Pt26I&Kn9y-}QEIzn6eT5h=k%COu!IFBHf z?Sx1}?7o5_^`J9CaY2I^>7z5~U!qj|#edGv=c%CEW1zTU?q88vT3Gl*?WUk! zZxb=EUQKKQU9-JZsCP)zN?6#qUTDZC6aRh0n63P)i`aZE-7S+_*TakV$L?bMA%qBD z&|@tO6tl~@^SM|mbU)7Va9a%V5xphg3Ed8jv{y~S!&bbF#X+crh33t}fX|4~s+$#s z3|m96UYSN+dN~~&QpN}1tOr^!(hYm*={b(2pTL-_ptA07g~5feX-kzNRg1B0KfqP+ zCHyGq`%R&bKvRgU@Qmo%S3z}k_$~Q>wK6MhYTuF`!dmb6;W4fLPsg;N0dd<;`~*M5 zcc<{@1TCII6Jw;33G%6GM_M9uq`;JWeX~ss`Mf@&s>D&BL?whF^(YXYDHjG?Fuvi` zqd;GUs+XadH!@C^|B*s@dHo4PHm0G&v^g#8XokdV%TRe_jiYq2kPpU2=MkZlMjlC> zlT^@b#Yg9;RBAd(0X@i_&o(|1SW~1$8`GMq3h=P?r|xA+6d41L@-NG~Qq~v2r z`g3$=mRzprejoDVX8R$VT5^-QFDx+Uly2MaQdzZ6yY|j<$AZ-a%M438?pe~)Hsr>$ zUvfL=-?=(!9|UzULXoe~>@>WR9n2ArAtuf>*ZpQZ$}yW$TwW+++Blk#m@;#WO&b?e zmP0b^II=R;Lh~Mdb|Nv-Hu=rzNzVf%Jd$Z%B|C*H=1M8Pj#|1vZMJp%lFsx(DnSX( zre67RoTSjP^=&a%TBE91|2hAI=DPH;jO%Pj4dkXn_*#a1am>%L)X-K?&qbbht4 zN6tRhby{8f7$cPtM@Zs(O0|bEPH0?x=R!`ybI(p{<=`sY6(Qd2K6P$CGL#n|X^d^` zC{=^I-yxOmZ!bAz;d-+=pZr;qy}PC_OzHii91a3`MgV~T|KI7)e=eV4W99t6tNOF7 z|G9vMaS4-_+z$<1bFNIaPQ6$oa;nQQsK%9O#{8|O=XnG&6ocJ&=?)lSkK^GB3$MB- z7+)Mr{P!5rB-x}JO+Mo+d~RE6W|D!E{yJKgukO~^=5BYmu)3RishMgq=d_20#;?2b z^-~j7M`gleYs!UV6itE`SS|_oVqz~SI^3P6{X1&Rpkv<$E zCJRv55^a7VWsi_zT(^wHHJs|zQN0EA5ktM+)5kbZ`?7woI{PuA%YIB4do{;_+zK(O zRogEO8tSA`O&(@wc0S7{W^ZY8ze>y>pKnrG<)o3k(QlxK3r}2PVtRw)GmO@>+Kw;> z>iXjd)wC|$JUpb)Fhx3YJs!5R?yr$HCLv@BCU?${PP#MIh?#%+aNzW5V3E2LFSau+ z?Q8;iXIa+=$)3R@GwwW7IN#{W^s&T2sSx|M+lhkBX}nsmi2FPF3NNIu=lS|p*E@BB zzS9?J>oFBb`CjaW8^{Z?2uEHavo)e}z-OEO&>ygsFu2=aTdi@-MiA}aS1yV; z^tZG}Q9l$=QqKV)LboW{@2-cwOb3`L;9tRy14 zvmUK6Cz|X9c5k1$@-Gc_UvD304sK_&cACH96G2{Cka%uOV!tw2Hm&D{TDNJiR3_rB zn2D9zoG)xZ(sV2EJh1sH`}sJ;llUsebf{5iskbM%hVaW#KW%OtlSGbBkDBcvZtaAu& zXv)F%7(-TJK@JWixln1B;vpW+_3<@d3dF!H`}DI8)dj<&(kaa7!yXyQuS`#&S#4{F zVIpWCc+a}T;4I=x3_}H?g0aY57>+KkWRJfGbl zBU0id&%mmZ$4JnY0CpJYttm=`%cgfGQ)W&AL=|d?TCA z(crh7l-jOQOf!t}L|%`iu(;T~G*-hW2)$0`y?g<%=?996PHON4vL9Now%qe6k~nv& ztp=&g6RJ6G#73QKyZ8vrMrv4#-T;3ETu{-RG>gHZu))T7a-r_R)XSg|UPPPXS(a$C>3ke&V!DnzyqTM0`p@VT&dVP!9josJfsJbz3g=*_22 zsnCuA3_nI>aV{D^x~m7Vl0?3}zELb%%F3ymA%XDZouAfNx*GH9Ubf+PFa1QC^}f&PWihd@(*k3I zT+)jG)sWE#WgGw%-!KQ7GJ?)B>U?GqN;PfpT zrNAzZ6mV8_ zJr6Mjl~O$|S4_bq@PX7rs&%UCQ-L^J9XloU1;Y2Qy*$$J!vitBJReUR!lM}eha8w@1@@TIZs zt}+jM5K#TfS5&w!UwJ&LvUh$qe>H+iKZ!JPZ7rQAyqa+MYTiYWsmxI!mjg$!hxB04 zMRGglNnV+uRhzp*2F}%&9KLzg8>e{>J{26cu5LS}4>@E<^=QZ2rJjzD zo{jAkE;8@<(k(oih&`B)ah*-H9F>{13O`co%4vbDSX2(Lx|*f2eR)omvf1V4$=bAw z^jzo741p|ZWu|@^!Ah% zk7!dIX-snxB7arTTyvi1xH%b7tfIeL@p1XncnHA4jI=_PCuhf zqxi2Bji(BYN1d@~mlQaJ?k>AIKc5W2xhmD>EUHuV-O@YSZfnNPa8R$9?*4o?J?kle zKaE9n`zd@uA=hjm$ms-8*XQpNIi#+jN3xz&V3^r1_Cy z;Fg?KnS*8;xPlnknO@8txCVz7vt%5(BD!0w_XmrhpstL$WSPZ8kdt@+mRTw!rhoq4@) zpD-9d>|e;}dtJBPR$_FG{f&Pkt!>-*=Sw%v3W40){o#`jxARMSjCN)FUYzgzck^;z zFs59bK~Iv1LVp# z7J077m?lr-vxGF%o^(8y|rBuh*FDlv~JT%_X6sFFfNi)xbiBHF04WswzAk`-I2rDpw{_78Fj zS>^bIRokl9#CTl~#H^HG98x3jf0<4rg8OTG46z`0zuqAoPAwW?m7h z=bSEF@UFO<6+*kAaXY==;+VqMR^wAB#!=xjpH4KcuejnnpCj30WQ2-4i^teqyJ2|! zSYI-0WshUt_K=+I_&s^6eT>{VIM&&$DkC)cl7aGq?6D_}R&G6qHHsF;kMnwjab_K@ z9Vu#RWA_+0*G#_hHR#EZwE2v-;?{1VUmw@)Is*!1V+nm|g?QTwX@Zld2t^0k-Kx^! zWott(IP#r!&Mtrn!2N7a8*GL*0NE4-l8gRVHtn6v{(mz6Nv21PnEf0plK(!;87XY~ zrmX8&2^taZLP#1;mJg=wv{LM}WGWLOMl9#8S9N;*56u(cS~^k^()cBzDQp4Jpt8e9 z8Ol@^%StBcOUxJMUli^5LJPl4YOEQxs-RsyKRlGMduEmbiOjYl&wAGr^evZt*LNRH zms*ljpwJ~Ps_n^f5n_!rL%U}6?5|N>wB$HvH5lt+wNR9#YRc%$XyEEfSJDq8hT%RB ztq<^|_~kl7amXhQ2N66s<#hxEYdFVe_PFL!viUw_<`VjMuQ@uUopJYgGkBFW#a{zo zt?^tF{#CSY?uZeb6tjNB%aALB=GJ8gA)E*Acel zDa+6D-Xmve;Z~=}%jk{bWD-rY6y(f9#Ux$?m!{2F6;2B&B$zSZB)WzoJ2)%^(p8ou zhPh1bj6}A+hSfD?@5e}{IWlK@ALGoGdQFs#i;lk+OG*RVPp7~|<^97W)5}wvh3{}o z*B9L>-Ai*OJY_KWeE5oa4oW+d)+13C<%tvTF40iFe7;u4qbvih_t&l}nU#=CTROtN z*Nt0&Z?2a@n}MVEpTt8!GeQ2jap)`jug+m$vaBZjdpy3o=}Oq!y)?6XY4G&5gPHU5 z-+e$;;coy_zsU?5=rl_J0^ES~uk8V_pz@!k&_4^HcXt%i#;Gg>?p}IJ4uPQlYc~i) z0Ql+utf(5>+uMNs)}O9K;eJ3j4Frn)d%@zx569VpD-%r{YRh7F97$717i z1(=HYedh1d2q=Rye@-RbWu9kuyuk(fSqN}(&)XpOgR-b&pBZ0%t%I+~5}tZ42}!W3;=aIn)DZKqI_CpZI|;n<@m|}E#DFuPDc(!n^E?EtR8cZG1DaygbbF~V zfZ4fMsnINO1~kQuSd97I0JC|Ii7NnSKvN72QyljTv~6O_z!}gKyMJ|IIs$E*&KgjL z12o06f_@PRpl!3)2+n|}80|S-02MH7sRQrTfA{c)c5ntX#hg%1xeNd!dym2C1!q80 zydUo;OAIjY?hT@DL*NW(ise2`sQzYx?=k)3;0$Pri;WN{WMCnXNtC;7LplS_fTkFa z)~tmYV8ZV)=?mZtXo_Ksj}-WUN}b%R6!a=M1DaxvxgHf|fZ4vsIB$Y8peYtT*9X4Z z4FZX{_a1(+1IloMrr0uQ4@U!FV(u|^$KVWTipPAiDFc8?y#ONocZz>rf-|5g&R$CV z5d$#J_n5j{a0WERzK-K$?|=h7eDBTI2M!8s7Rm{lV%*asUVnfYxySH71ZO}~jQDU3 zCL5^KbHclAbA|%WfTkEf6pgwNU^MPALs;MpXo|NAm|vL#j2SSi|NBUl5`Z(HDQ5HC zOmYBaRpM4GRpcz5z#S?H(iW7@Pr3am#2ZB{EQ& z#(P~;lNFo+O|d3$yMQdfe7VP@aDg+RDMs|%d1u#80 zcNt9)a0WERmA;QH9s-rR&jd+=GoUH{hQOiyo0-0MqnBax>V6 zXV4UL#jQ3r0}LY8-AajCf-|5gt_pwiwg;5qegV#ardXW3a1;$VQf>D-1D6vx1Daw= zMK{*p2mC(c;Reotrr6lcq6GzDHt)r+%LAMNO)>Sjb_N7s-rZv!`GPZ`DIT+pkzogz zBw(rJ@3B}s5S#%`vGlcumMADw90tySrkL@X04^6`n2GL|h9U-(;Q>vtkGlG03&6TSTUB(^?=xzv_exXR2F`${*!+>E#2&CHWqWT? z3a1;C;RQ|cqgSq0zu%|K?)7kiesBgf#W^p=x`+TK`yS&l0?vS@7{*`DUAlBH%z`tZDRv`75=sV|I0{(f{<|~$Tmol6Q_NqIFPj4}f{1sS zzBOwG{i(vdu;f?3^JYSF0=C(oB<6nuRQ)!1b|7q z#|Q$q>x0Z7`9MQVQ?>JO2WT6ddu{WEADjUVaZm(xTn@l60fPh}{cB4X1!dS+LC0eH zRfZ$<-!TS0`Tp&=N&goIG{><~B4U$3dGZ0|Z>L4^zc`>l?l3`oh6j|#>0WsT)&GkF zn&b=}64l=w;_6;@h;=|6KG5co$nc0X0vIZQ`MX+P2A~WZD`=EwrS=ssfaZAsOx*r< zaLxaV1DfS?RSeE(z!AQ8*kx@0ivt>Fh2w{biGU+`&p~tgFAiv$TXE5vlz~ps1q{i+ z`Hz2XOKyLhmzHKP%vk>X37Q-2A9Qi9zP}qM`WM=y0rIVGN1*mZMshIx|^oTHET^cm9cOUrkj}nIk zs(=Re?kz+AC`oj870?@q?wContents - -

    Introduction

    -

    FVSOnline is an interface to the -Forest Vegetation Simulator (FVS). FVS takes a file of commands and -input data and produces predictions of forest conditions in the -future. This interface is used to set up the file of commands, run -FVS, and then explore the outputs. The input data are measurements of -trees stored in an input database. Tools for installing and editing -that database are included.

    -

    These instructions assume that you are already familiar with FVS. - -Press here to view an essential background manual. -

    -

    The interface was designed to run in a true client/server -configuration, whereby the data and software are stored on a server -and the user interaction is through a web browser. However, the -software can also be installed on personal computer or in a -Citrix -(or similar) system. The interaction is still through a web browser, -but the software, inputs and outputs, are all stored on the personal computer. -This configuration is called FVSOnlocal. The system was built using -R, Shiny, -SQLite3, and many other -R packages. For more information on the -software and supporting software requirements see the - -wiki about FVSOnline software.

    -

    Hints for first time users:

    -
      -

    • The - FVS webpage contains links to training materials. -

      -

    • Use the default input database - while learning, load your own data once you're comfortable using the - interface. Note that there is a command under the Manage Projects menu - that lets you delete all runs and related outputs so you can easily - start fresh with your own data. -

      -

    • Use default settings and options - until you need to change them. -

      -

    • Exploring the system is the best way to learn while reading - this documentation might be helpful after you have some experience. -

      -
    -

    Back to contents -

    -

    Top menu items

    -
      -

    • Simulate: Set up and make FVS - simulations; the outputs go to an output database which contains all - the output for all the runs in a project. If you rerun a simulation, this - database is updated to reflect the most recent outputs. -

      -

    • View Outputs: Make - tables and graphs using the outputs stored in the output - database. -

      -

    • Visualize: Display 3d images of stands. -

      -

    • View On Maps: Display some outputs in a spatial context - if your stand locations are loaded. -

      -

    • Manage Projects: Access commands to manage projects, - import input data, and import runs and other items from other projects or backup files, and - download data from project. Under "Manage projects", you can - create new projects, open other projects, deleted outputs or entire projects, - make and manage backup files. -

      -

    • Help: Display this help. -

      -
    -

    Simulate

    -

    When the Simulate menu is selected the screen is divided into two regions, -left and right. The left side contains the Selected run -list and buttons to create new runs, reload a selected run, save it, duplicate it -(more on that later), or delete it. The title of the selected run is displayed in a text box -(you can change it to whatever you wish) and the run Contents -are listed below. There are buttons and other tools below the -Contents that are described below.

    -

    The right side contains a secondary menu, used to select -Stands and add Components. Stands are the simulation -units defined in the - -input database and components are sets of - -FVS keywords (also called commands) that that instruct FVS to invoke -options or to simulate management activities. The stands and -components will be added to the Contents list on the left. -

    -

    The first step in building a run is to select the initialization table -you wish to use in the input database (generally, FVS_StandInit is used). The -second step is to pick FVS variant you wish to -use. Only those stands that can be run with the selected variant will be listed -as possible choices. Select one or more groups and then select the stands from -the selected groups. You can add individually selected stands or all the stands -from selected groups using the buttons found below the list of stands.

    -

    Once stands are added, you can make a run using the Run tab on the right end -of the second level menu bar. Alternatively, before you make the run, you can -add run components control the simulation. Or do both, make a run and -then change it and run it again. Or, make a run and duplicate it, then modify -the duplicate. Once you make both runs, you can compare the outputs of the two -(or several, as you desire).

    -

    Note that you can add the same stand more than once and each is considered a -replicate. This can be done by selecting and adding the same stand more than -once or by specifying the number of replicates in the input box found below the -list of available stands. You can also specify a set -of relative weights of each replicate. These weights are used to modify the -stand sampling weights specified in the input database. Often these sampling -weights are stand sizes or the size of the land area represented by the stand. -The set of weights you enter is recycled if necessary so that each -replicate gets a weight. For example, if you say you want 5 replications of each -stand, and you enter 1,2 for the weights, the resulting set will be 1,2,1,2,1. -The logic includes a normalization step such that each weight is divided -by the sum of the weights. Note that this normalization happens when the run is -made using the Run tab. The normalized weights are then multiplied by the -sampling weight entered in the database and the results are entered into FVS so -that the sampling weights for each replicate are correctly reported in the FVS -output. Lastly note that there is no way to modify the weights once they are -entered. If you make a mistake, delete the entered stands and then redo the -process of adding them to the run.

    -

    New Components are added by selecting them, filling out the -associated form, and then saving them. Components are accessed by -first selecting component type:

    -
      -

    • Management for specifying - management actions -

      -

    • Modifiers for specify - changes in the FVS predictions -

      -

    • Event Monitor for adding FVS output - variables you define using FVS functions -

      -

    • Economic for setting parameters - of the Economic Extension of FVS -

      -

    • Keywords for direct - access to all FVS keywords -

      -

    • Editor to make and use custom freeform component sets you build - or load (also known as .kcp files). -

      -
    -

    The Time scope of a simulation is automatically set to 50 -or 100 years in 5 or 10 years cycles, both depending on the variant. -The parameters of time can be edited and specific years you want -included in the simulation can be specified as a list of years (separate -the years with a space).

    -

    Select Outputs is used to select which output tables you want FVS -to generate. A few, like the FVS_Summary statistics table, are automaticlly generated -every run. The others are selected using the check boxes displayed. You can -get a short description of each table using the Describe tables tool at the -bottom of the checkboxes. Note that FVSOnline the tree lists to generate -stand and stock tables; if you desire them, then check the tree lists box. -

    -

    Run simulations while you wait (great for under 20 stands -or so), or in the background as a separate process. Use the -checkboxes to specify sets of outputs without having to know the -keywords needed to get the outputs you desire. You can also select -alternative run scripts; these are used to implement alternative -models within the FVS framework. Note that when you rerun a run, the -interface clears the output from the previous time you made the run -so that the output database contains the most recently generated -output. If you use the Wait for run option, -the interface will scan the FVS output file for error messages and -display any it finds in the interface. The Run in -background option does not provide that service. However, -there is a download button useful for downloading the FVS “.out” file.

    - -

    Here -are more details on the left side elements when Runs -is selected in the main manu. -

    -

    The Duplicate command found near the top of the left side deserves -some explanation. Lets say you have made a simulation for a -collection of stands using set of components and you wish to make -another run with different components or different settings in -existing components (for example, setting different residual -densities on thinning options). Your idea is that you want to compare -the results. In this case you should duplicate -the first run, giving the duplicate a new name and then edit the -duplicate. You can run and rerun any of the runs as often as you wish -and you can compare the outputs after the simulations are run.

    -

    The -buttons found below the Contents list can be used to remove a stand, -group, or component. If a component is removed it is added to a paste -list. To paste one of these components into the run, first select the -component you want to paste, then select a stand, group, or another -component in the Contents list. The pasted component will be added to -the selected stand or group, or directly after the selected -component. You can also edit existing components or convert -components from there formatted state that allows them to be edited -using the same form used to create them or they can be converted to -freeform -that allows them to be directly modified (most useful for experts who -know the FVS -keywords). Sometimes components are in the freeform -state from the beginning. -

    -

    Back to contents -

    -

    View Outputs

    -

    View Outputs after you make one or more runs. There are two required -steps, the first is to Load outputs for the runs and output tables you -want to then Explore. For example, say you -have made two runs and you want to compare their projections. In that -case, you would select them both and then select the database tables -you wish to explore. The data in the selected output table(s) can be displayed as Tables -or Graphs depending on the selections on the right-hand -secondary menu.

    -

    Composite summary statistics tables are created for the runs (table name: CmpSummary, -CmpSummary2, or the "East" versions of these) where the composites are weighted averages -of corresponding tables grouped by management ids (not by run because -more than one run can have the same management id, -more than one management id can be within one run, or both). -If treelist tables exist, stand and stock tables are also created (table name StdStk; -CmpStdStk for the composites, also grouped by management id).

    -

    Explore Data menu item is used to further control which -data are being explored. Use the selection tools on the left to limit -the data used in the tables or graphs to specific runs, groups, -stands, management identification codes (set when you make a run), -years, species, and DBHClasses. You can also turn variables on or off -limiting the columns being displayed in tables and those available -for graphing. -

    -

    In summary, the two basic steps are to (1) Load the runs and FVS-generated -output tables, and (2) Explore those data as Tables or Graphs. -

    -

    When Tables are displayed, you can use tools to change a categorical -variable (such as stand or management identifications) into a set of columns and display -a variable's value under that column. Tables can be download as .xlsx or .csv -files (easily opened using Excel or other spreadsheet programs). Note that the -number of lines displayed in the table is limited, however, when the table is -downloaded, all lines are included (for .xlsx up to 1048576 rows). -

    -

    The Graphs menu item on the right provides -access to graphing tools that operate on the data displayed in the -table. FVSOnline contains logic that preselects graph settings -depending on the data being analyzed. Changes you make are kept until you -reselect the data you want to analyze. -

    -

    The best way to learn how the graphing tool works is to experiment. Note that making -some selections sometimes changes others. For example, if you change -the vertical facet to the same setting as the horizontal facet, your -horizotal facet selection will be automatically adjusted to None. -Also note that when there are too many levels for a variable (such -as too many stands) then the system blocks the use of the variable -for faceting. Similar limits control the size of the legend that is -created when you select a Plot by variable. -

    -

    The axis labels are automatically set to the variable name unless you specify -a new label. And the title is blank unless you type in a title. -Axis and title labels can optionally contain mathematical expressions. -Adding an expression to a label or title is done by entering an -expression() following the rules outlined in - -Mathematical Annotation in R, or -Understanding R: Mathematical Expressions. -For example, if you would like to display basal area -on the y-axis, you can simply select the variable BA and the y-axis label will be BA as that -is the name of the variable. You can type in the label Basal area per acre -and that will be the label. An alternative that shows the units in mathematical -notation would be expression(paste("Basal area ", (ft^2/a))) -and for merchantable volume you could code expression(paste("Merchantable ", (ft^3/a))). -Note that the label shown is exactly what you type until the expression is coded correctly. Once -you get it right, it will display correctly. -

    -

    Finished graphs can be copied to your computer clipboard to be inserted into -a document. If you want high resolution graphs, or otherwise -customize the apperance of a graph, then Show more controls and -change the settings as needed. -

    -

    -You can save the customizations of your graph and recall them to use in a future -graph. At the top of the graphics window there are tools to name and save your -customizations. For example, lets say you have some specific labels, line -colors, graph type, variable selections, and axis scales you have -selected for a graph. You can give those settings a name and save them. In -another run, they can be recalled and used on new data. -

    -

    Custom Query provides the ability to build and run SQL queries that run -on the output SQLite3 -database. The tabular output from those queries is displayed as -a table and data in that table can be graphed or downloaded.

    -

    -However, building custom database queries requires some knowledge of -SQL, the structure of the output database, and the mechanisms used by FVSOnline to create -and manipulate the database. Note that the entire the database structure is defined -in the Output Table Descriptions.

    -

    -The first table you need to understand is the FVS_Cases table which contains one row -for each simulation of each stand or replication of a stand over all the runs you have -made in the project. When each run is made, FVSOnline first creates a fresh database where -all the output tables are sent for the run. After each run is finished, FVSOnline -deletes all the output that may already exist for the same run in the permanent database -then the outputs in the fresh database are inserted into the permanent -database.

    -

    -The FVS_Cases table is key to this process. This table contains several columns -including the keyword file name that FVSOnline insures is unique to the run even if two -or more run names are identical. The result of a query of the FVS_Cases table -that selects all the cases that have a given keyword file name will contain one row -for each case where the CaseID column has a unique identifier for each case. -Here is a select statement that will result in just the cases for a given run:

    -

    -select CaseID from FVS_Cases where KeywordFile = 'name';

    -

    -A similar select statement is used by FVSOnline to build a temporary table that -contains a list of all the CaseID values associated with one or more KeywordFile values. -This table, called, temp.Cases, is automatically built or rebuilt every time the you -change the selections in "Runs to consider". In turn, when you desire to explore one of the -other FVS output tables, FVSOnline uses this table to limit the rows to include just the rows -related to runs that are loaded for exploration. For example, to select just the rows in the -FVS_Summary2 table that are related to the selected runs, FVSOnline uses this query: -

    -select * from FVS_Summary2 where CaseID in (select CaseID from temp.Cases);

    -

    -The Custom Query tab allows you to build and save your custom output -database queries. Queries like those show above can be used to select just the data -for a specific run or runs. Note that the FVS_Cases table also contains the RunTitle. -If you insure run titles are unique, they can be used in place of the KeywordFile -name to limit the cases to those of a give run or collection of runs. Here, for example, -is a complete query that selects all of the tree records from the FVS_TreeList_East -table associated with two runs names Run 1 and Run 2. -

    -select * from FVS_TreeList_East where CaseID in
    -     (select CaseID from FVS_Cases where RunTitle in ('Run 1', 'Run 2'));

    -

    -Note that SQLite3 allows the attachment other databases and tables from those -databases can be include in queries. -As a convenience, FVSOnline automatically attaches the FVS input database (FVS_Data.db) -to the output database when the Custom Query tab is used. This attached database is given -the alias input so that tables from the input can be joined to the output. -For example, the stand identification code from the input database might be -input.FVS_standInit.Stand_ID. -

    -A query can actually be several queries each separated by a semicolon. They can -be stored and recovered for later use. Lastly, comments can be included in -the query by surrounding it with /* */ character sequences. -

    -

    Back to contents -

    -

    Available output tables

    -

    The tables output generated from FVS are selected prior making a run using the -Select Outputs menu item under the Tabs tab. The available tables are -listed below, and below this list there is a set of addition tables that describe -the detailed contents of each of the tables. -

    -

    FVSOnline generates some composite tables by taking a weighted average over -the individual stands from the selected runs you selected in the Runs to consider -list box. The weights used in this calculation are the individual stand sampling weights -as specified in the input database. The names of these composite tables start with -Cmp and are listed below. -

    -

    Computing the composites is done by grouping all the stands accross all selected -runs by unique management ID (which can be set in the Runs tab or by using an -FVS Keyword). Individual stands that have the same stand ID, run using the same -management ID, are considered replications of the stand. Prior to computing the weighted -averages, the sampling weights for the are adjusted by dividing each by -the number of replications. This is a temporary adjustment that is recomputed every -time outputs are explored. The adjusted weights are reported as the SamplingWt -in the FVS_Cases table (described below). Remember that the number of replications for -each stand can change depending on how the management IDs are assigned and by which -runs are considered. Generally, however, unique management IDs are used for each run -and when that is the case, the replication counts will not change when different runs -are selected. -

    -**OUTPUTHTML** -

    Visualize

    -

    You can display two 3d images of stands if the output that support - -Stand Visualization System has been created (easily done by checking -Stand Visualization under the Select Outputs table). Pick a run, and within the Run, pick the stand and -time period you wish to display. It takes some time for the images to be created -and transferred to your browser. Once the transfer is completed, you can click -on the image and rotate it, flip it, and zoom in and out using your mouse. -

    -

    Back to contents -

    -

    View On Maps

    -

    You can display stand polygon boundaries of the stands in the Selected Run -over a Google satellite or other map. Select an Output Table and a Variable -from the table. When you point your mouse at a stand, a small table is displayed -showing the values of that variable over time. You can Display graphs rather -than tables. Note that if you have a very large run, it can take significant amounts of -time to generate the graphs. -

    -Note that the spatial polygons of the stand boundaries are -required to display boundaries. However, spatial points can alternatively be loaded and -when points are provided, a red dot is displayed at the point location. -See Map data under Manage Projects -to see now to load this spatial data. -

    -If spatial data are not loaded, an attempt is made to use the Latitude and Longitude -information from the FVS_StandInit table (failing that, the FVS_PlotInit table) -assuming WGS84 geographic coordinates are used. -

    -

    Back to contents -

    -

    Manage Projects

    -

    Under Manage project you can create new projects, open other projects, -delete output, runs or entire projects, as well as make and manage project backup files.

    -

    Import input data provides tools for loading an -FVS-Ready database that is stored as a SQLite3 -database (use the file suffix .db), as a Microsoft Access database -(.mdb or .accdb), or as an Excel (.xlsx) database where the sheet names are -the same as the target table names. The built-in training data or a blank database (and -FVS-Ready database that contains no rows but has predefined columns) -can be installed without uploading a file simply by pressing the -obvious buttons. Doing so also installs related spatial data.

    -

    You can Upload .csv data to add to existing tables. -This is done by uploading a .csv file that contains column -headings. Columns in the .csv file that are not in the existing table are added to -the existing tables. -Columns in the existing table that have no values in the .csv file are left -null.

    -

    You can View and edit existing tables. Use the Edit -mode to change values or delete rows. Make the changes and then -Commit them to the database. Use the New rows mode to -add new rows. You can limit the variables to consider in either mode; -those not considered are simply hid from view. If editing, they are not altered -and if adding new rows their values are set to null.

    -

    More information on the input and output database structure is -in the - -Users Guide to the Database Extension.

    -

    You can upload Map data that is used to display stand polygons on top of reference -maps using the View On Maps menu item. Many file formats are -supported, see this -list. To upload a map, first create a .zip file that contains a single directory (folder) -where the coverages are stored. Then upload the .zip file and let FVSOnline try to -load the appropriate files.

    -

    If the .zip file contains more than one layer, you can select the one that -contains stand polygons (the system will attempt to make a valid selection). Note that -the polygons must be identifiable by StandID but frequently the coverage data contains -this information under a different variable name. FVSOnline attempts to discover the -correct variable to match to StandID. You can set the variable here if necessary.

    -

    If the geographic projection of your data is not stored with the data (usually it -is part of the coverage data), or if it is set and is wrong, then you can set or reset -the projection. Select a projection from the list button or just -type in the proj4 string into the text box if you know what it is. Note the the -projection is set or reset here but the spatial data is not reprojected. -Any reprojection needed to display the data is done automatically.

    -

    The Import runs and other items tab allows you to import runs, -custom components (.kcp), graph settings, custom queries, FVS_Data.db (input data bases), -Spatial Data, or any combination of these from 1) an existing project, or 2) a backup -file or other downloaded file that contains the items you desire. You first specify -the source project or upload a zip file and then select the item(s) you wish to import -into your current project. -

    The Downloads tab provides the ability to download specific -files related to the project. Thre is also a facility for -setting up and downloading a .zip file that contains sevaral optional -elements. Note that tese downloaded files can be a source of items that can be -imported into other projects.

    -

    Back to contents -

    -

    Input tables

    -**INPUTHTML** - +

    Contents

    + +

    Introduction

    +

    FVSOnline is an interface to the +Forest Vegetation Simulator (FVS). FVS takes a file of commands and +input data and produces predictions of forest conditions in the +future. This interface is used to set up the file of commands, run +FVS, and then explore the outputs. The input data are measurements of +trees stored in an input database. Tools for installing and editing +that database are included.

    +

    These instructions assume that you are already familiar with FVS. + +Press here to view an essential background manual. +

    +

    The interface was designed to run in a true client/server +configuration, whereby the data and software are stored on a server +and the user interaction is through a web browser. However, the +software can also be installed on personal computer or in a +Citrix +(or similar) system. The interaction is still through a web browser, +but the software, inputs and outputs, are all stored on the personal computer. +This configuration is called FVSOnlocal. The system was built using +R, Shiny, +SQLite3, and many other +R packages. For more information on the +software and supporting software requirements see the + +wiki about FVSOnline software.

    +

    Hints for first time users:

    +
      +

    • The + FVS webpage contains links to training materials. +

      +

    • Use the default input database + while learning, load your own data once you're comfortable using the + interface. Note that there is a command under the Manage Projects menu + that lets you delete all runs and related outputs so you can easily + start fresh with your own data. +

      +

    • Use default settings and options + until you need to change them. +

      +

    • Exploring the system is the best way to learn while reading + this documentation might be helpful after you have some experience. +

      +
    +

    Back to contents +

    +

    Top menu items

    +
      +

    • Simulate: Set up and make FVS + simulations; the outputs go to an output database which contains all + the output for all the runs in a project. If you rerun a simulation, this + database is updated to reflect the most recent outputs. +

      +

    • View Outputs: Make + tables and graphs using the outputs stored in the output + database. +

      +

    • Visualize: Display 3d images of stands. +

      +

    • View On Maps: Display some outputs in a spatial context + if your stand locations are loaded. +

      +

    • Manage Projects: Access commands to manage projects, + import input data, and import runs and other items from other projects or backup files, and + download data from project. Under "Manage projects", you can + create new projects, open other projects, deleted outputs or entire projects, + make and manage backup files. +

      +

    • Help: Display this help. +

      +
    +

    Simulate

    +

    When the Simulate menu is selected the screen is divided into two regions, +left and right. The left side contains the Selected run +list and buttons to create new runs, reload a selected run, save it, duplicate it +(more on that later), or delete it. The title of the selected run is displayed in a text box +(you can change it to whatever you wish) and the run Contents +are listed below. There are buttons and other tools below the +Contents that are described below.

    +

    The right side contains a secondary menu, used to select +Stands and add Components. Stands are the simulation +units defined in the + +input database and components are sets of + +FVS keywords (also called commands) that that instruct FVS to invoke +options or to simulate management activities. The stands and +components will be added to the Contents list on the left. +

    +

    The first step in building a run is to select the initialization table +you wish to use in the input database (generally, FVS_StandInit is used). The +second step is to pick FVS variant you wish to +use. Only those stands that can be run with the selected variant will be listed +as possible choices. Select one or more groups and then select the stands from +the selected groups. You can add individually selected stands or all the stands +from selected groups using the buttons found below the list of stands.

    +

    Once stands are added, you can make a run using the Run tab on the right end +of the second level menu bar. Alternatively, before you make the run, you can +add run components control the simulation. Or do both, make a run and +then change it and run it again. Or, make a run and duplicate it, then modify +the duplicate. Once you make both runs, you can compare the outputs of the two +(or several, as you desire).

    +

    Note that you can add the same stand more than once and each is considered a +replicate. This can be done by selecting and adding the same stand more than +once or by specifying the number of replicates in the input box found below the +list of available stands. You can also specify a set +of relative weights of each replicate. These weights are used to modify the +stand sampling weights specified in the input database. Often these sampling +weights are stand sizes or the size of the land area represented by the stand. +The set of weights you enter is recycled if necessary so that each +replicate gets a weight. For example, if you say you want 5 replications of each +stand, and you enter 1,2 for the weights, the resulting set will be 1,2,1,2,1. +The logic includes a normalization step such that each weight is divided +by the sum of the weights. Note that this normalization happens when the run is +made using the Run tab. The normalized weights are then multiplied by the +sampling weight entered in the database and the results are entered into FVS so +that the sampling weights for each replicate are correctly reported in the FVS +output. Lastly note that there is no way to modify the weights once they are +entered. If you make a mistake, delete the entered stands and then redo the +process of adding them to the run.

    +

    New Components are added by selecting them, filling out the +associated form, and then saving them. Components are accessed by +first selecting component type:

    +
      +

    • Management for specifying + management actions +

      +

    • Modifiers for specify + changes in the FVS predictions +

      +

    • Event Monitor for adding FVS output + variables you define using FVS functions +

      +

    • Economic for setting parameters + of the Economic Extension of FVS +

      +

    • Keywords for direct + access to all FVS keywords +

      +

    • Editor to make and use custom freeform component sets you build + or load (also known as .kcp files). +

      +
    +

    The Time scope of a simulation is automatically set to 50 +or 100 years in 5 or 10 years cycles, both depending on the variant. +The parameters of time can be edited and specific years you want +included in the simulation can be specified as a list of years (separate +the years with a space).

    +

    Select Outputs is used to select which output tables you want FVS +to generate. A few, like the FVS_Summary statistics table, are automaticlly generated +every run. The others are selected using the check boxes displayed. You can +get a short description of each table using the Describe tables tool at the +bottom of the checkboxes. Note that FVSOnline the tree lists to generate +stand and stock tables; if you desire them, then check the tree lists box. +

    +

    Run simulations while you wait (great for under 20 stands +or so), or in the background as a separate process. Use the +checkboxes to specify sets of outputs without having to know the +keywords needed to get the outputs you desire. You can also select +alternative run scripts; these are used to implement alternative +models within the FVS framework. Note that when you rerun a run, the +interface clears the output from the previous time you made the run +so that the output database contains the most recently generated +output. If you use the Wait for run option, +the interface will scan the FVS output file for error messages and +display any it finds in the interface. The Run in +background option does not provide that service. However, +there is a download button useful for downloading the FVS “.out” file.

    + +

    Here +are more details on the left side elements when Runs +is selected in the main manu. +

    +

    The Duplicate command found near the top of the left side deserves +some explanation. Lets say you have made a simulation for a +collection of stands using set of components and you wish to make +another run with different components or different settings in +existing components (for example, setting different residual +densities on thinning options). Your idea is that you want to compare +the results. In this case you should duplicate +the first run, giving the duplicate a new name and then edit the +duplicate. You can run and rerun any of the runs as often as you wish +and you can compare the outputs after the simulations are run.

    +

    The +buttons found below the Contents list can be used to remove a stand, +group, or component. If a component is removed it is added to a paste +list. To paste one of these components into the run, first select the +component you want to paste, then select a stand, group, or another +component in the Contents list. The pasted component will be added to +the selected stand or group, or directly after the selected +component. You can also edit existing components or convert +components from there formatted state that allows them to be edited +using the same form used to create them or they can be converted to +freeform +that allows them to be directly modified (most useful for experts who +know the FVS +keywords). Sometimes components are in the freeform +state from the beginning. +

    +

    Back to contents +

    +

    View Outputs

    +

    View Outputs after you make one or more runs. There are two required +steps, the first is to Load outputs for the runs and output tables you +want to then Explore. For example, say you +have made two runs and you want to compare their projections. In that +case, you would select them both and then select the database tables +you wish to explore. The data in the selected output table(s) can be displayed as Tables +or Graphs depending on the selections on the right-hand +secondary menu.

    +

    Composite summary statistics tables are created for the runs (table name: CmpSummary, +CmpSummary2, or the "East" versions of these) where the composites are weighted averages +of corresponding tables grouped by management ids (not by run because +more than one run can have the same management id, +more than one management id can be within one run, or both). +If treelist tables exist, stand and stock tables are also created (table name StdStk; +CmpStdStk for the composites, also grouped by management id).

    +

    Explore Data menu item is used to further control which +data are being explored. Use the selection tools on the left to limit +the data used in the tables or graphs to specific runs, groups, +stands, management identification codes (set when you make a run), +years, species, and DBHClasses. You can also turn variables on or off +limiting the columns being displayed in tables and those available +for graphing. +

    +

    In summary, the two basic steps are to (1) Load the runs and FVS-generated +output tables, and (2) Explore those data as Tables or Graphs. +

    +

    When Tables are displayed, you can use tools to change a categorical +variable (such as stand or management identifications) into a set of columns and display +a variable's value under that column. Tables can be download as .xlsx or .csv +files (easily opened using Excel or other spreadsheet programs). Note that the +number of lines displayed in the table is limited, however, when the table is +downloaded, all lines are included (for .xlsx up to 1048576 rows). +

    +

    The Graphs menu item on the right provides +access to graphing tools that operate on the data displayed in the +table. FVSOnline contains logic that preselects graph settings +depending on the data being analyzed. Changes you make are kept until you +reselect the data you want to analyze. +

    +

    The best way to learn how the graphing tool works is to experiment. Note that making +some selections sometimes changes others. For example, if you change +the vertical facet to the same setting as the horizontal facet, your +horizotal facet selection will be automatically adjusted to None. +Also note that when there are too many levels for a variable (such +as too many stands) then the system blocks the use of the variable +for faceting. Similar limits control the size of the legend that is +created when you select a Plot by variable. +

    +

    The axis labels are automatically set to the variable name unless you specify +a new label. And the title is blank unless you type in a title. +Axis and title labels can optionally contain mathematical expressions. +Adding an expression to a label or title is done by entering an +expression() following the rules outlined in + +Mathematical Annotation in R, or +Understanding R: Mathematical Expressions. +For example, if you would like to display basal area +on the y-axis, you can simply select the variable BA and the y-axis label will be BA as that +is the name of the variable. You can type in the label Basal area per acre +and that will be the label. An alternative that shows the units in mathematical +notation would be expression(paste("Basal area ", (ft^2/a))) +and for merchantable volume you could code expression(paste("Merchantable ", (ft^3/a))). +Note that the label shown is exactly what you type until the expression is coded correctly. Once +you get it right, it will display correctly. +

    +

    Finished graphs can be copied to your computer clipboard to be inserted into +a document. If you want high resolution graphs, or otherwise +customize the apperance of a graph, then Show more controls and +change the settings as needed. +

    +

    +You can save the customizations of your graph and recall them to use in a future +graph. At the top of the graphics window there are tools to name and save your +customizations. For example, lets say you have some specific labels, line +colors, graph type, variable selections, and axis scales you have +selected for a graph. You can give those settings a name and save them. In +another run, they can be recalled and used on new data. +

    +

    Custom Query provides the ability to build and run SQL queries that run +on the output SQLite3 +database. The tabular output from those queries is displayed as +a table and data in that table can be graphed or downloaded.

    +

    +However, building custom database queries requires some knowledge of +SQL, the structure of the output database, and the mechanisms used by FVSOnline to create +and manipulate the database. Note that the entire the database structure is defined +in the Output Table Descriptions.

    +

    +The first table you need to understand is the FVS_Cases table which contains one row +for each simulation of each stand or replication of a stand over all the runs you have +made in the project. When each run is made, FVSOnline first creates a fresh database where +all the output tables are sent for the run. After each run is finished, FVSOnline +deletes all the output that may already exist for the same run in the permanent database +then the outputs in the fresh database are inserted into the permanent +database.

    +

    +The FVS_Cases table is key to this process. This table contains several columns +including the keyword file name that FVSOnline insures is unique to the run even if two +or more run names are identical. The result of a query of the FVS_Cases table +that selects all the cases that have a given keyword file name will contain one row +for each case where the CaseID column has a unique identifier for each case. +Here is a select statement that will result in just the cases for a given run:

    +

    +select CaseID from FVS_Cases where KeywordFile = 'name';

    +

    +A similar select statement is used by FVSOnline to build a temporary table that +contains a list of all the CaseID values associated with one or more KeywordFile values. +This table, called, temp.Cases, is automatically built or rebuilt every time the you +change the selections in "Runs to consider". In turn, when you desire to explore one of the +other FVS output tables, FVSOnline uses this table to limit the rows to include just the rows +related to runs that are loaded for exploration. For example, to select just the rows in the +FVS_Summary2 table that are related to the selected runs, FVSOnline uses this query: +

    +select * from FVS_Summary2 where CaseID in (select CaseID from temp.Cases);

    +

    +The Custom Query tab allows you to build and save your custom output +database queries. Queries like those show above can be used to select just the data +for a specific run or runs. Note that the FVS_Cases table also contains the RunTitle. +If you insure run titles are unique, they can be used in place of the KeywordFile +name to limit the cases to those of a give run or collection of runs. Here, for example, +is a complete query that selects all of the tree records from the FVS_TreeList_East +table associated with two runs names Run 1 and Run 2. +

    +select * from FVS_TreeList_East where CaseID in
    +     (select CaseID from FVS_Cases where RunTitle in ('Run 1', 'Run 2'));

    +

    +Note that SQLite3 allows the attachment other databases and tables from those +databases can be include in queries. +As a convenience, FVSOnline automatically attaches the FVS input database (FVS_Data.db) +to the output database when the Custom Query tab is used. This attached database is given +the alias input so that tables from the input can be joined to the output. +For example, the stand identification code from the input database might be +input.FVS_standInit.Stand_ID. +

    +A query can actually be several queries each separated by a semicolon. They can +be stored and recovered for later use. Lastly, comments can be included in +the query by surrounding it with /* */ character sequences. +

    +

    Back to contents +

    +

    Available output tables

    +

    The tables output generated from FVS are selected prior making a run using the +Select Outputs menu item under the Tabs tab. The available tables are +listed below, and below this list there is a set of addition tables that describe +the detailed contents of each of the tables. +

    +

    FVSOnline generates some composite tables by taking a weighted average over +the individual stands from the selected runs you selected in the Runs to consider +list box. The weights used in this calculation are the individual stand sampling weights +as specified in the input database. The names of these composite tables start with +Cmp and are listed below. +

    +

    Computing the composites is done by grouping all the stands accross all selected +runs by unique management ID (which can be set in the Runs tab or by using an +FVS Keyword). Individual stands that have the same stand ID, run using the same +management ID, are considered replications of the stand. Prior to computing the weighted +averages, the sampling weights for the are adjusted by dividing each by +the number of replications. This is a temporary adjustment that is recomputed every +time outputs are explored. The adjusted weights are reported as the SamplingWt +in the FVS_Cases table (described below). Remember that the number of replications for +each stand can change depending on how the management IDs are assigned and by which +runs are considered. Generally, however, unique management IDs are used for each run +and when that is the case, the replication counts will not change when different runs +are selected. +

    +**OUTPUTHTML** +

    Visualize

    +

    You can display two 3d images of stands if the output that support + +Stand Visualization System has been created (easily done by checking +Stand Visualization under the Select Outputs table). Pick a run, and within the Run, pick the stand and +time period you wish to display. It takes some time for the images to be created +and transferred to your browser. Once the transfer is completed, you can click +on the image and rotate it, flip it, and zoom in and out using your mouse. +

    +

    Back to contents +

    +

    View On Maps

    +

    You can display stand polygon boundaries of the stands in the Selected Run +over a Google satellite or other map. Select an Output Table and a Variable +from the table. When you point your mouse at a stand, a small table is displayed +showing the values of that variable over time. You can Display graphs rather +than tables. Note that if you have a very large run, it can take significant amounts of +time to generate the graphs. +

    +Note that the spatial polygons of the stand boundaries are +required to display boundaries. However, spatial points can alternatively be loaded and +when points are provided, a red dot is displayed at the point location. +See Map data under Manage Projects +to see now to load this spatial data. +

    +If spatial data are not loaded, an attempt is made to use the Latitude and Longitude +information from the FVS_StandInit table (failing that, the FVS_PlotInit table) +assuming WGS84 geographic coordinates are used. +

    +

    Back to contents +

    +

    Manage Projects

    +

    Under Manage project you can create new projects, open other projects, +delete output, runs or entire projects, as well as make and manage project backup files.

    +

    Import input data provides tools for loading an +FVS-Ready database that is stored as a SQLite3 +database (use the file suffix .db), as a Microsoft Access database +(.mdb or .accdb), or as an Excel (.xlsx) database where the sheet names are +the same as the target table names. The built-in training data or a blank database (and +FVS-Ready database that contains no rows but has predefined columns) +can be installed without uploading a file simply by pressing the +obvious buttons. Doing so also installs related spatial data.

    +

    You can Upload .csv data to add to existing tables. +This is done by uploading a .csv file that contains column +headings. Columns in the .csv file that are not in the existing table are added to +the existing tables. +Columns in the existing table that have no values in the .csv file are left +null.

    +

    You can View and edit existing tables. Use the Edit +mode to change values or delete rows. Make the changes and then +Commit them to the database. Use the New rows mode to +add new rows. You can limit the variables to consider in either mode; +those not considered are simply hid from view. If editing, they are not altered +and if adding new rows their values are set to null.

    +

    More information on the input and output database structure is +in the + +Users Guide to the Database Extension.

    +

    You can upload Map data that is used to display stand polygons on top of reference +maps using the View On Maps menu item. Many file formats are +supported, see this +list. To upload a map, first create a .zip file that contains a single directory (folder) +where the coverages are stored. Then upload the .zip file and let FVSOnline try to +load the appropriate files.

    +

    If the .zip file contains more than one layer, you can select the one that +contains stand polygons (the system will attempt to make a valid selection). Note that +the polygons must be identifiable by StandID but frequently the coverage data contains +this information under a different variable name. FVSOnline attempts to discover the +correct variable to match to StandID. You can set the variable here if necessary.

    +

    If the geographic projection of your data is not stored with the data (usually it +is part of the coverage data), or if it is set and is wrong, then you can set or reset +the projection. Select a projection from the list button or just +type in the proj4 string into the text box if you know what it is. Note the the +projection is set or reset here but the spatial data is not reprojected. +Any reprojection needed to display the data is done automatically.

    +

    The Import runs and other items tab allows you to import runs, +custom components (.kcp), graph settings, custom queries, FVS_Data.db (input data bases), +Spatial Data, or any combination of these from 1) an existing project, or 2) a backup +file or other downloaded file that contains the items you desire. You first specify +the source project or upload a zip file and then select the item(s) you wish to import +into your current project. +

    The Downloads tab provides the ability to download specific +files related to the project. Thre is also a facility for +setting up and downloading a .zip file that contains sevaral optional +elements. Note that tese downloaded files can be a source of items that can be +imported into other projects.

    +

    Back to contents +

    +

    Input tables

    +**INPUTHTML** + \ No newline at end of file diff --git a/fvsOL/inst/extdata/mkhelp.R b/fvsOL/inst/extdata/mkhelp.R index 8516e8a..afce053 100644 --- a/fvsOL/inst/extdata/mkhelp.R +++ b/fvsOL/inst/extdata/mkhelp.R @@ -1,93 +1,93 @@ -require(openxlsx) - -xlsx2html <- function(tab=NULL,xlsxfile=NULL,cols=NULL,addLink=FALSE,sdat=NULL) -{ - if (is.null(xlsxfile) || !file.exists(xlsxfile)) return(NULL) - cleanlines=function(line) - { - line=gsub(pattern="\n",replacement="",x=line,fixed=TRUE) - gsub(pattern="\r",replacement="",x=line,fixed=TRUE) - } - if (is.null(tab)) return(NULL) - if (tab %in% getSheetNames(xlsxfile)) - { - if (is.null(sdat)) sdat = try(read.xlsx(xlsxFile=xlsxfile,sheet=tab)) - if (class(sdat) == "try-error") return (NULL) - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - if (!is.null(cols) && max(cols)<=ncol(sdat)) sdat = sdat[,cols] - sdat[sdat == " "]=NA - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - sdat = sdat[,!apply(sdat,2,function(x) all(is.na(x)))] - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - sdat = sdat[ !apply(sdat,1,function(x) all(is.na(x))),] - if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) - html = paste0("",tab,"") - html = paste0(html,'

    ") - for (i in 1:nrow(sdat)) - { - tbrow=cleanlines(as.character(sdat[i,])) - if (addLink) tbrow[1] = paste0('',tbrow[1],'') - html = paste0(html,"") - } - html = paste0(html,"
    ', - paste0(cleanlines(colnames(sdat)),collapse=""),"
    ",paste0(tbrow,collapse=""),"

    ") - return (html) - } else return (NULL) -} - -fr = "data/fvsOnlineHelpRender.RData" -fn = "inst/extdata/fvsOnlineHelp.html" -xlsxfile="inst/extdata/databaseDescription.xlsx" -cat ("Erase ",fr,"\n") -unlink(fr) -fvshelp = readChar(fn, file.size(fn)) -cat ("Process OutputTableDescriptions\n") -tabs = try(read.xlsx(xlsxFile=xlsxfile,sheet="OutputTableDescriptions")) - -if (class(tabs)!="try-error") -{ - metr = grep("Metric",tabs$Table,ignore.case=TRUE) - if (length(metr)) - { - theMetr = tabs[metr,] - tabs = tabs[-metr,] - tabs = rbind(tabs,theMetr) - } - tablist=xlsx2html(tab="OutputTableDescriptions",xlsxfile=xlsxfile,addLink=TRUE,sdat=tabs) - if (length(metr)) tablist=sub("OutputTableDescriptions", - "OutputTableDescriptions

    Note: metric table descriptions are listed below.

    ",tablist) - - morehtml=paste0(tablist,'

    Back to Contents

    ') - for (tab in tabs$Table) - { - cat ("Processing output table description for tab=",tab,"\n") - morehtml=paste0(morehtml,'', - xlsx2html(tab=tab,xlsxfile=xlsxfile), - '

    Back to Output Table Descriptions  ', - 'Back to Contents

    ') - } - if (!is.null(morehtml)) fvshelp = sub(x=fvshelp,fixed=TRUE, - pattern="**OUTPUTHTML**",replacement=morehtml) -} -cat ("Process InputTableDescriptions\n") -tabs = try(read.xlsx(xlsxFile=xlsxfile,sheet="InputTableDescriptions")) -if (class(tabs)!="try-error") -{ - morehtml=paste0(xlsx2html(tab="InputTableDescriptions",xlsxfile=xlsxfile,addLink=TRUE), - '

    Back to Contents

    ') - for (tab in tabs$Table) - { - cat ("Processing input table description for tab=",tab,"\n") - morehtml=paste0(morehtml,'', - xlsx2html(tab=tab,xlsxfile=xlsxfile), - '

    Back to Input Table Descriptions  ', - 'Back to Contents

    ') - } - if (!is.null(morehtml)) fvshelp = sub(x=fvshelp,fixed=TRUE, - pattern="**INPUTHTML**",replacement=morehtml) -} -cat ("Saving fvshelp file ",fr,"\n") -save(fvshelp,file=fr) - - - +require(openxlsx) + +xlsx2html <- function(tab=NULL,xlsxfile=NULL,cols=NULL,addLink=FALSE,sdat=NULL) +{ + if (is.null(xlsxfile) || !file.exists(xlsxfile)) return(NULL) + cleanlines=function(line) + { + line=gsub(pattern="\n",replacement="",x=line,fixed=TRUE) + gsub(pattern="\r",replacement="",x=line,fixed=TRUE) + } + if (is.null(tab)) return(NULL) + if (tab %in% getSheetNames(xlsxfile)) + { + if (is.null(sdat)) sdat = try(read.xlsx(xlsxFile=xlsxfile,sheet=tab)) + if (class(sdat) == "try-error") return (NULL) + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + if (!is.null(cols) && max(cols)<=ncol(sdat)) sdat = sdat[,cols] + sdat[sdat == " "]=NA + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + sdat = sdat[,!apply(sdat,2,function(x) all(is.na(x)))] + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + sdat = sdat[ !apply(sdat,1,function(x) all(is.na(x))),] + if (nrow(sdat)==0 || ncol(sdat)==0) return (NULL) + html = paste0("",tab,"") + html = paste0(html,'

    ") + for (i in 1:nrow(sdat)) + { + tbrow=cleanlines(as.character(sdat[i,])) + if (addLink) tbrow[1] = paste0('',tbrow[1],'') + html = paste0(html,"") + } + html = paste0(html,"
    ', + paste0(cleanlines(colnames(sdat)),collapse=""),"
    ",paste0(tbrow,collapse=""),"

    ") + return (html) + } else return (NULL) +} + +fr = "data/fvsOnlineHelpRender.RData" +fn = "inst/extdata/fvsOnlineHelp.html" +xlsxfile="inst/extdata/databaseDescription.xlsx" +cat ("Erase ",fr,"\n") +unlink(fr) +fvshelp = readChar(fn, file.size(fn)) +cat ("Process OutputTableDescriptions\n") +tabs = try(read.xlsx(xlsxFile=xlsxfile,sheet="OutputTableDescriptions")) + +if (class(tabs)!="try-error") +{ + metr = grep("Metric",tabs$Table,ignore.case=TRUE) + if (length(metr)) + { + theMetr = tabs[metr,] + tabs = tabs[-metr,] + tabs = rbind(tabs,theMetr) + } + tablist=xlsx2html(tab="OutputTableDescriptions",xlsxfile=xlsxfile,addLink=TRUE,sdat=tabs) + if (length(metr)) tablist=sub("OutputTableDescriptions", + "OutputTableDescriptions

    Note: metric table descriptions are listed below.

    ",tablist) + + morehtml=paste0(tablist,'

    Back to Contents

    ') + for (tab in tabs$Table) + { + cat ("Processing output table description for tab=",tab,"\n") + morehtml=paste0(morehtml,'', + xlsx2html(tab=tab,xlsxfile=xlsxfile), + '

    Back to Output Table Descriptions  ', + 'Back to Contents

    ') + } + if (!is.null(morehtml)) fvshelp = sub(x=fvshelp,fixed=TRUE, + pattern="**OUTPUTHTML**",replacement=morehtml) +} +cat ("Process InputTableDescriptions\n") +tabs = try(read.xlsx(xlsxFile=xlsxfile,sheet="InputTableDescriptions")) +if (class(tabs)!="try-error") +{ + morehtml=paste0(xlsx2html(tab="InputTableDescriptions",xlsxfile=xlsxfile,addLink=TRUE), + '

    Back to Contents

    ') + for (tab in tabs$Table) + { + cat ("Processing input table description for tab=",tab,"\n") + morehtml=paste0(morehtml,'', + xlsx2html(tab=tab,xlsxfile=xlsxfile), + '

    Back to Input Table Descriptions  ', + 'Back to Contents

    ') + } + if (!is.null(morehtml)) fvshelp = sub(x=fvshelp,fixed=TRUE, + pattern="**INPUTHTML**",replacement=morehtml) +} +cat ("Saving fvshelp file ",fr,"\n") +save(fvshelp,file=fr) + + + diff --git a/fvsOL/inst/extdata/runScripts.R b/fvsOL/inst/extdata/runScripts.R index eef6fd0..992e2cd 100644 --- a/fvsOL/inst/extdata/runScripts.R +++ b/fvsOL/inst/extdata/runScripts.R @@ -1,23 +1,23 @@ - -# List custom run scripts that are available here. - -# The string displayed in the selectInput list (on the Run tab) is on the left, -# the script "name" is on the right. - - -# The "name" map to scripts named: "customRun_[name].R" -# where name is a left-hand side in the list. If a script by that -# name (case sensitive) is not found, then the list item is removed -# prior to the server.R script startup (that is, only "available" -# optional scripts will be listed). - -# NOTE: it is very important NOT to allow users to upload their own scripts when -# the system is running in a client/server environment. On "local" it is just -# fine! - -customRunScripts=list( - "AcadianGY (Weiskittel et al.) normally run with FVSne" = "fvsRunAcadian", - "AdirondackGY (Weiskittel et al.) normally run with FVSne" = "fvsRunAdirondack" - ) - - + +# List custom run scripts that are available here. + +# The string displayed in the selectInput list (on the Run tab) is on the left, +# the script "name" is on the right. + + +# The "name" map to scripts named: "customRun_[name].R" +# where name is a left-hand side in the list. If a script by that +# name (case sensitive) is not found, then the list item is removed +# prior to the server.R script startup (that is, only "available" +# optional scripts will be listed). + +# NOTE: it is very important NOT to allow users to upload their own scripts when +# the system is running in a client/server environment. On "local" it is just +# fine! + +customRunScripts=list( + "AcadianGY (Weiskittel et al.) normally run with FVSne" = "fvsRunAcadian", + "AdirondackGY (Weiskittel et al.) normally run with FVSne" = "fvsRunAdirondack" + ) + + diff --git a/fvsOL/inst/extdata/sqlQueries.R b/fvsOL/inst/extdata/sqlQueries.R index 0e68e46..827dc07 100644 --- a/fvsOL/inst/extdata/sqlQueries.R +++ b/fvsOL/inst/extdata/sqlQueries.R @@ -217,7 +217,7 @@ drop table if exists temp.CmpStdStkAllAll; create table temp.CmpSmpWt as select MgmtID,sum(SamplingWt) as CmpSmpWt from FVS_Cases where CaseID in (select CaseID from temp.Cases) - group by MgmtID; + group by MgmtID; create table temp.CmpStdStkDBHSp as select MgmtID,Year,Species,DBHClass, sum(LiveTPA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveTPA, @@ -575,7 +575,6 @@ create table CmpSummary2_East as drop table if exists temp.CmpSummary2_EastA; drop table if exists temp.CmpSummary2_EastB;" - Create_CmpCompute = " drop table if exists CmpCompute; create table CmpCompute as @@ -599,3 +598,52 @@ from FVS_Down_Wood_Cov inner join FVS_Down_Wood_Vol on FVS_Down_Wood_Cov.CaseID = FVS_Down_Wood_Vol.CaseID and FVS_Down_Wood_Cov.Year = FVS_Down_Wood_Vol.Year;" +Create_CmpCalibStats = " +drop table if exists temp.CmpCalibStatsLG; +create table temp.CmpCalibStatsLG as + select MgmtID,asSpecies,'LG' as TreeSize, + COUNT(TreeSize) as NumStands, + MIN(ScaleFactor) as MinSF, + MAX(ScaleFactor) as MaxSF, + AVG(ScaleFactor) as MeanSF, + SQRT(((sum(ScaleFactor * ScaleFactor) - + (sum(ScaleFactor) * sum(ScaleFactor))/count(TreeSize))/ + (count(TreeSize)-1))) as StDevSF, + SUM(NumTrees) as TotNumTrees, + SUM(NumTrees*ReadCorMult)/sum(NumTrees) as MeanReadCorMult + from (select * from FVS_CalibStats where TreeSize == 'LG' and + CaseID in (select CaseID from temp.Cases)) + join FVS_Cases using (CaseID) + group by MgmtID,Species; + +drop table if exists temp.CmpCalibStatsSM; +create table temp.CmpCalibStatsSM as + select MgmtID,asSpecies,'SM' as TreeSize, + COUNT(TreeSize) as NumStands, + MIN(ScaleFactor) as MinSF, + MAX(ScaleFactor) as MaxSF, + AVG(ScaleFactor) as MeanSF, + SQRT(((sum(ScaleFactor * ScaleFactor) - + (sum(ScaleFactor) * sum(ScaleFactor))/count(TreeSize))/ + (count(TreeSize)-1))) as StDevSF, + SUM(NumTrees) as TotNumTrees, + SUM(NumTrees*ReadCorMult)/sum(NumTrees) as MeanReadCorMult + from (select * from FVS_CalibStats where TreeSize == 'SM' and + CaseID in (select CaseID from temp.Cases)) + join FVS_Cases using (CaseID) + group by MgmtID,Species; + +insert into temp.CmpCalibStatsLG + select MgmtID,Species,TreeSize,NumStands,MinSF,MaxSF,MeanSF,StDevSF, + TotNumTrees,MeanReadCorMult + from temp.CmpCalibStatsSM + group by MgmtID,Species; + +drop table if exists CmpCalibStats; +create table CmpCalibStats as + select distinct MgmtID,Species,TreeSize,NumStands,MinSF,MaxSF, + MeanSF,StDevSF,TotNumTrees,MeanReadCorMult + from temp.CmpCalibStatsLG + order by MgmtID,Species; +drop table if exists temp.CmpCalibStatsLG; +drop table if exists temp.CmpCalibStatsSM;" diff --git a/fvsOL/inst/extdata/sqlQueries_Metric.R b/fvsOL/inst/extdata/sqlQueries_Metric.R index 202843a..784cbc4 100644 --- a/fvsOL/inst/extdata/sqlQueries_Metric.R +++ b/fvsOL/inst/extdata/sqlQueries_Metric.R @@ -1,414 +1,414 @@ - -exqury = function (dbcon,x,subExpression=NULL,asSpecies=NULL) -{ - # return value: TRUE=worked, FALSE=error - if (!is.null(subExpression)) x = gsub("subExpression",subExpression,x) - if (!is.null(asSpecies)) x = gsub("asSpecies",paste0(asSpecies," as Species"),x) - for (qry in scan(text=gsub("\n"," ",x),sep=";",what="",quote="",quiet=TRUE)) - { -cat ("exqury qry1=",qry,"\n") - res = if (nchar(qry) > 5) try(dbExecute(dbcon,qry)) else NULL - if (!is.null(res) && class(res) == "try-error") - { -cat ("exqury qry2=",qry,"\n") - qry = gsub(paste0(asSpecies," as Species")," Species ",qry) - res = try(dbExecute(dbcon,qry)) - if (class(res) == "try-error") return(FALSE) - } - } - return(TRUE) -} - -mkdbhCase = function (stpdbh=5,lgdbh=100) -{ - stpdbh=if (is.na(stpdbh) || as.numeric(stpdbh)==0 || - as.character(stpdbh)=="") 5 else ceiling(stpdbh) - if (is.na(lgdbh ) || as.numeric(lgdbh )==0 || as.character(lgdbh )=="") lgdbh =100 - if (stpdbh<1) stpdbh=1 - if (lgdbh= ",lb[i]," and dbh < ", - lb[i+1],") then '", chrclasses[i],"'") - } - subExpression = paste0(subExpression," else '",lb[length(lb)],"+' end ") - subExpression -} - -Create_CmpMetaData = " -drop table if exists CmpMetaData; -create table CmpMetaData as - select RunTitle,RunDateTime,Variant, - sum(SamplingWt) as TotalSamplingWt, - count(*) as NumOfCases, - Version, RV, KeywordFile from FVS_Cases - where CaseID in (select CaseID from temp.Cases) - group by KeywordFile - order by RunTitle, RunDateTime;" - -Create_StdStkDBHSp = " -drop table if exists temp.StdStkDBHSp; -drop table if exists temp.StdStkAllDBH; -drop table if exists temp.StdStkAllSp; -drop table if exists temp.StdStkAllAll; -create table temp.StdStkDBHSp as - select CaseID,Year,asSpecies, - subExpression as DBHClass, - sum(TPH) as LiveTPH, - sum(DBH*DBH*7.853982E-05*TPH) as LiveBA, - sum(TCuM*TPH) as LiveTCuM, - sum(MCuM*TPH) as LiveMCuM, - sum(MortPH) as MrtTPH, - sum(DBH*DBH*7.853982E-05*MortPH) as MrtBA, - sum(TCuM*MortPH) as MrtTCuM, - sum(MCuM*MortPH) as MrtMCuM - from FVS_TreeList_Metric - where CaseID in (select CaseID from temp.Cases) - group by CaseID,Year,DBHClass,Species - order by CaseID,Year,DBHClass,Species; -create table temp.StdStkAllDBH as - select CaseID,Year,Species,'All' as DBHClass, - sum(LiveTPH) as LiveTPH, - sum(LiveBA) as LiveBA, - sum(LiveTCuM) as LiveTCuM, - sum(LiveMCuM) as LiveMCuM, - sum(MrtTPH) as MrtTPH, - sum(MrtBA) as MrtBA, - sum(MrtTCuM) as MrtTCuM, - sum(MrtMCuM) as MrtMCuM - from temp.StdStkDBHSp - group by CaseID,Year,Species - order by CaseID,Year,Species,DBHClass; -create table temp.StdStkAllSp as - select CaseID,Year,'All' as Species, DBHClass, - sum(LiveTPH) as LiveTPH, - sum(LiveBA) as LiveBA, - sum(LiveTCuM) as LiveTCuM, - sum(LiveMCuM) as LiveMCuM, - sum(MrtTPH) as MrtTPH, - sum(MrtBA) as MrtBA, - sum(MrtTCuM) as MrtTCuM, - sum(MrtMCuM) as MrtMCuM - from temp.StdStkDBHSp - group by CaseID,Year,DBHClass - order by CaseID,Year,Species,DBHClass; -create table temp.StdStkAllAll as - select CaseID,Year,'All' as Species, 'All' as DBHClass, - sum(LiveTPH) as LiveTPH, - sum(LiveBA) as LiveBA, - sum(LiveTCuM) as LiveTCuM, - sum(LiveMCuM) as LiveMCuM, - sum(MrtTPH) as MrtTPH, - sum(MrtBA) as MrtBA, - sum(MrtTCuM) as MrtTCuM, - sum(MrtMCuM) as MrtMCuM - from temp.StdStkDBHSp - group by CaseID,Year - order by CaseID,Year,Species,DBHClass; -insert into temp.StdStkDBHSp select * from temp.StdStkAllSp; -insert into temp.StdStkDBHSp select * from temp.StdStkAllDBH; -insert into temp.StdStkDBHSp select * from temp.StdStkAllAll;" - - -Create_HrvStdStk = " -drop table if exists temp.HrvStdStk; -drop table if exists temp.HrvStdStkAllDBH; -drop table if exists temp.HrvStdStkAllSp; -drop table if exists temp.HrvStdStkAllAll; -create table temp.HrvStdStk as - select CaseID,Year,asSpecies, - subExpression as dbhclass, - sum(TPH) as HrvTPH, - sum(DBH*DBH*7.853982E-05*TPH) as HrvBA, - sum(TCuM*TPH) as HrvTCuM, - sum(MCuM*TPH) as HrvMCuM - from FVS_CutList_Metric - where CaseID in (select CaseID from temp.Cases) - group by CaseID,Year,Species,DBHClass; -create table temp.HrvStdStkAllDBH as - select CaseID,Year,Species,'All' as DBHClass, - sum(HrvTPH) as HrvTPH, - sum(HrvBA) as HrvBA, - sum(HrvTCuM) as HrvTCuM, - sum(HrvMCuM) as HrvMCuM - from temp.HrvStdStk - group by CaseID,Year,Species; -create table temp.HrvStdStkAllSp as - select CaseID,Year,'All' as Species, DBHClass, - sum(HrvTPH) as HrvTPH, - sum(HrvBA) as HrvBA, - sum(HrvTCuM) as HrvTCuM, - sum(HrvMCuM) as HrvMCuM - from temp.HrvStdStk - group by CaseID,Year,DBHClass; -create table temp.HrvStdStkAllAll as - select CaseID,Year,'All' as Species, 'All' as DBHClass, - sum(HrvTPH) as HrvTPH, - sum(HrvBA) as HrvBA, - sum(HrvTCuM) as HrvTCuM, - sum(HrvMCuM) as HrvMCuM - from temp.HrvStdStk - group by CaseID,Year; -insert into temp.HrvStdStk select * from temp.HrvStdStkAllSp; -insert into temp.HrvStdStk select * from temp.HrvStdStkAllDBH; -insert into temp.HrvStdStk select * from temp.HrvStdStkAllAll;" - -Create_StdStk1Hrv = " -drop table if exists temp.StdStk2; -create table temp.StdStk2 as select * from temp.StdStkDBHSp - left join temp.HrvStdStk using (CaseID,Year,Species,DBHClass); -drop table if exists temp.StdStk1; -create table temp.StdStk1 as -select Year,Species,DBHClass, - LiveTPH, LiveBA, LiveTCuM, LiveMCuM, - case when HrvTPH is not null then HrvTPH else 0 end as HrvTPH, - case when HrvBA is not null then HrvBA else 0 end as HrvBA, - case when HrvTCuM is not null then HrvTCuM else 0 end as HrvTCuM, - case when HrvMCuM is not null then HrvMCuM else 0 end as HrvMCuM, - MrtTPH, MrtBA, MrtTCuM, MrtMCuM, CaseID -from temp.StdStk2;" - -Create_StdStk1NoHrv = " -drop table if exists temp.StdStk1; -create table temp.StdStk1 as -select Year,Species,DBHClass, - LiveTPH, LiveBA, LiveTCuM, LiveMCuM, - 0 as HrvTPH, 0 as HrvBA, 0 as HrvTCuM, 0 as HrvMCuM, - MrtTPH, MrtBA, MrtTCuM, MrtMCuM, CaseID -from temp.StdStkDBHSp;" - -Create_StdStkFinal = " -drop table if exists StdStk_Metric; -create table StdStk_Metric as select Year, Species, DBHClass, - LiveTPH, MrtTPH, HrvTPH, LiveTPH - HrvTPH as RsdTPH, - LiveBA, MrtBA, HrvBA, LiveBA - HrvBA as RsdBA, - LiveTCuM, MrtTCuM, HrvTCuM, LiveTCuM - HrvTCuM as RsdTCuM, - LiveMCuM, MrtMCuM, HrvMCuM, LiveMCuM - HrvMCuM as RsdMCuM, - CaseID from temp.StdStk1;" - -Create_CmpStdStk = " -drop table if exists CmpSmpWt; -drop table if exists CmpStdStk_Metric; -drop table if exists temp.CmpStdStkDBHSp; -drop table if exists temp.CmpStdStkDBHAll; -drop table if exists temp.CmpStdStkAllSp; -drop table if exists temp.CmpStdStkAllAll; -create table temp.CmpSmpWt as - select MgmtID,sum(SamplingWt) as CmpSmpWt from FVS_Cases where - CaseID in (select CaseID from temp.Cases) - group by MgmtID; -create table temp.CmpStdStkDBHSp as - select MgmtID,Year,Species,DBHClass, - sum(LiveTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveTPH, - sum(MrtTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtTPH, - sum(HrvTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvTPH, - sum(RsdTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdTPH, - sum(LiveBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveBA, - sum(MrtBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtBA, - sum(HrvBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvBA, - sum(RsdBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdBA, - sum(LiveTCuM*SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveTCuM, - sum(MrtTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtTCuM, - sum(HrvTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvTCuM, - sum(RsdTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdTCuM, - sum(LiveMCuM*SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveMCuM, - sum(MrtMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtMCuM, - sum(HrvMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvMCuM, - sum(RsdMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdMCuM - from (select * from StdStk_Metric where Species != 'All' and DBHClass != 'All' and - CaseID in (select CaseID from temp.Cases)) - join FVS_Cases using (CaseID) - join temp.CmpSmpWt using (MgmtID) - group by MgmtID,Year,Species,DBHClass; -create table temp.CmpStdStkDBHAll as - select MgmtID,Year,Species,'All' as DBHClass, - round(sum(CmpLiveTPH),2) as CmpLiveTPH, - round(sum(CmpMrtTPH),2) as CmpMrtTPH, - round(sum(CmpHrvTPH),2) as CmpHrvTPH, - round(sum(CmpRsdTPH),2) as CmpRsdTPH, - round(sum(CmpLiveBA),2) as CmpLiveBA, - round(sum(CmpMrtBA),2) as CmpMrtBA, - round(sum(CmpHrvBA),2) as CmpHrvBA, - round(sum(CmpRsdBA),2) as CmpRsdBA, - round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, - round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, - round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, - round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, - round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, - round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, - round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, - round(sum(CmpRsdMCuM),2) as CmpRsdMCuM - from temp.CmpStdStkDBHSp - group by MgmtID,Year,Species; -create table temp.CmpStdStkAllSp as - select MgmtID,Year,'All' as Species,DBHClass, - round(sum(CmpLiveTPH),2) as CmpLiveTPH, - round(sum(CmpMrtTPH),2) as CmpMrtTPH, - round(sum(CmpHrvTPH),2) as CmpHrvTPH, - round(sum(CmpRsdTPH),2) as CmpRsdTPH, - round(sum(CmpLiveBA),2) as CmpLiveBA, - round(sum(CmpMrtBA),2) as CmpMrtBA, - round(sum(CmpHrvBA),2) as CmpHrvBA, - round(sum(CmpRsdBA),2) as CmpRsdBA, - round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, - round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, - round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, - round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, - round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, - round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, - round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, - round(sum(CmpRsdMCuM),2) as CmpRsdMCuM - from temp.CmpStdStkDBHSp - group by MgmtID,Year,DBHClass; -create table temp.CmpStdStkAllAll as - select MgmtID,Year,'All' as Species,'All' as DBHClass, - round(sum(CmpLiveTPH),2) as CmpLiveTPH, - round(sum(CmpMrtTPH),2) as CmpMrtTPH, - round(sum(CmpHrvTPH),2) as CmpHrvTPH, - round(sum(CmpRsdTPH),2) as CmpRsdTPH, - round(sum(CmpLiveBA),2) as CmpLiveBA, - round(sum(CmpMrtBA),2) as CmpMrtBA, - round(sum(CmpHrvBA),2) as CmpHrvBA, - round(sum(CmpRsdBA),2) as CmpRsdBA, - round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, - round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, - round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, - round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, - round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, - round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, - round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, - round(sum(CmpRsdMCuM),2) as CmpRsdMCuM - from temp.CmpStdStkDBHSp - group by MgmtID,Year; -create table CmpStdStk_Metric as - select MgmtID,Year,Species,DBHClass, - round(CmpLiveTPH ,2) as CmpLiveTPH, - round(CmpMrtTPH ,2) as CmpMrtTPH, - round(CmpHrvTPH ,2) as CmpHrvTPH, - round(CmpRsdTPH ,2) as CmpRsdTPH, - round(CmpLiveBA ,2) as CmpLiveBA, - round(CmpMrtBA ,2) as CmpMrtBA, - round(CmpHrvBA ,2) as CmpHrvBA, - round(CmpRsdBA ,2) as CmpRsdBA, - round(CmpLiveTCuM,2) as CmpLiveTCuM, - round(CmpMrtTCuM ,2) as CmpMrtTCuM, - round(CmpHrvTCuM ,2) as CmpHrvTCuM, - round(CmpRsdTCuM ,2) as CmpRsdTCuM, - round(CmpLiveMCuM,2) as CmpLiveMCuM, - round(CmpMrtMCuM ,2) as CmpMrtMCuM, - round(CmpHrvMCuM ,2) as CmpHrvMCuM, - round(CmpRsdMCuM ,2) as CmpRsdMCuM - from temp.CmpStdStkDBHSp; -insert into CmpStdStk_Metric select * from temp.CmpStdStkAllSp; -insert into CmpStdStk_Metric select * from temp.CmpStdStkDBHAll; -insert into CmpStdStk_Metric select * from temp.CmpStdStkAllAll;" - -Create_CmpSummary2 = " -drop table if exists temp.CmpSummary2A; -create table temp.CmpSummary2A as - select MgmtID,Year,RmvCode, - round(sum(Age *SamplingWt)/sum(SamplingWt),2) as CmpAge, - round(sum(TPH *SamplingWT)/sum(SamplingWt),2) as CmpTPH, - round(sum(TprdTPH *SamplingWT)/sum(SamplingWt),2) as CmpTprdTPH, - round(sum(BA *SamplingWT)/sum(SamplingWt),2) as CmpBA, - round(sum(SDI *SamplingWT)/sum(SamplingWt),2) as CmpSDI, - round(sum(CCF *SamplingWT)/sum(SamplingWt),2) as CmpCCF, - round(sum(TopHt *SamplingWT)/sum(SamplingWt),2) as CmpTopHt, - round(sum(QMD *SamplingWT)/sum(SamplingWt),2) as CmpQMD, - round(sum(TCuM *SamplingWT)/sum(SamplingWt),2) as CmpTCuM, - round(sum(TprdTCuM*SamplingWT)/sum(SamplingWt),2) as CmpTprdTCuM, - round(sum(MCuM *SamplingWT)/sum(SamplingWt),2) as CmpMCuM, - round(sum(TprdMCuM*SamplingWT)/sum(SamplingWt),2) as CmpTprdMCuM, - round(sum(RTPH *SamplingWT)/sum(SamplingWt),2) as CmpRTPH, - round(sum(RTCuM *SamplingWT)/sum(SamplingWt),2) as CmpRTCuM, - round(sum(RMCuM *SamplingWT)/sum(SamplingWt),2) as CmpRMCuM, - round(sum(SamplingWt ),2) as CmpSamplingWt - from (select * from FVS_Summary2_Metric where CaseID in (select CaseID from temp.Cases)) - join FVS_Cases using (CaseID) - group by MgmtID,Year,RmvCode order by MgmtID,Year,RmvCode; - -drop table if exists temp.CmpSummary2B; -create table temp.CmpSummary2B as - select MgmtID,Year,RmvCode,max(RmvCode) as newRmv, - round(sum(CmpAge *CmpSamplingWt)/sum(CmpSamplingWt),2) as CmpAge, - round(sum(CmpTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTPH, - round(sum(CmpTprdTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTPH, - round(sum(CmpBA *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpBA, - round(sum(CmpSDI *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpSDI, - round(sum(CmpCCF *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpCCF, - round(sum(CmpTopHt *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTopHt, - round(sum(CmpQMD *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpQMD, - round(sum(CmpTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTCuM, - round(sum(CmpTprdTCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTCuM, - round(sum(CmpMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpMCuM, - round(sum(CmpTprdMCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdMCuM, - round(sum(CmpRTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTPH, - round(sum(CmpRTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTCuM, - round(sum(CmpRMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRMCuM, - round(sum(CmpSamplingWt ),2) as CmpSamplingWt - from temp.CmpSummary2A where RmvCode in (0,1) - group by MgmtID,Year order by MgmtID,Year; - -insert into temp.CmpSummary2B - select MgmtID,Year,RmvCode,max(RmvCode) as newRmv, - round(sum(CmpAge *CmpSamplingWt)/sum(CmpSamplingWt),2) as CmpAge, - round(sum(CmpTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTPH, - round(sum(CmpTprdTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTPH, - round(sum(CmpBA *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpBA, - round(sum(CmpSDI *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpSDI, - round(sum(CmpCCF *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpCCF, - round(sum(CmpTopHt *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTopHt, - round(sum(CmpQMD *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpQMD, - round(sum(CmpTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTCuM, - round(sum(CmpTprdTCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTCuM, - round(sum(CmpMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpMCuM, - round(sum(CmpTprdMCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdMCuM, - round(sum(CmpRTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTPH, - round(sum(CmpRTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTCuM, - round(sum(CmpRMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRMCuM, - round(sum(CmpSamplingWt ),2) as CmpSamplingWt - from temp.CmpSummary2A where RmvCode in (0,2) - group by MgmtID,Year order by MgmtID,Year; - -drop table if exists CmpSummary2_Metric; -create table CmpSummary2_Metric as - select distinct MgmtID,Year,newRmv as RmvCode,CmpAge,CmpTPH,CmpTprdTPH, - CmpBA,CmpSDI,CmpCCF,CmpTopHt,CmpQMD,CmpTCuM, - CmpTprdTCuM,CmpMCuM,CmpTprdMCuM, - CmpRTPH,CmpRTCuM,CmpRMCuM,CmpSamplingWt - from temp.CmpSummary2B - order by MgmtID,Year,RmvCode; -drop table if exists temp.CmpSummary2A; -drop table if exists temp.CmpSummary2B;" - - -Create_CmpCompute = " -drop table if exists CmpCompute; -create table CmpCompute as - select MgmtID,Year,subExpression, - round(sum(SamplingWt),2) as CmpSamplingWt - from (select * from FVS_Compute where CaseID in (select CaseID from temp.Cases)) - join FVS_Cases using (CaseID) - group by MgmtID,Year;" - -Create_View_DWN_Required = c("FVS_Down_Wood_Cov","FVS_Down_Wood_Vol") -Create_View_DWN = " -drop view if exists View_DWN; -create temp view View_DWN as -select FVS_Down_Wood_Cov.CaseID,FVS_Down_Wood_Cov.StandID, - FVS_Down_Wood_Cov.Year, - DWD_Cover_Total_Hard, DWD_Cover_Total_Soft, - DWD_Cover_Total_Hard+DWD_Cover_Total_Soft as DWD_Total_Cover, - DWD_Volume_Total_Hard, DWD_Volume_Total_Soft, - DWD_Volume_Total_Hard+DWD_Volume_Total_Soft as DWD_Total_Volume -from FVS_Down_Wood_Cov inner join FVS_Down_Wood_Vol - on FVS_Down_Wood_Cov.CaseID = FVS_Down_Wood_Vol.CaseID and - FVS_Down_Wood_Cov.Year = FVS_Down_Wood_Vol.Year;" - + +exqury = function (dbcon,x,subExpression=NULL,asSpecies=NULL) +{ + # return value: TRUE=worked, FALSE=error + if (!is.null(subExpression)) x = gsub("subExpression",subExpression,x) + if (!is.null(asSpecies)) x = gsub("asSpecies",paste0(asSpecies," as Species"),x) + for (qry in scan(text=gsub("\n"," ",x),sep=";",what="",quote="",quiet=TRUE)) + { +cat ("exqury qry1=",qry,"\n") + res = if (nchar(qry) > 5) try(dbExecute(dbcon,qry)) else NULL + if (!is.null(res) && class(res) == "try-error") + { +cat ("exqury qry2=",qry,"\n") + qry = gsub(paste0(asSpecies," as Species")," Species ",qry) + res = try(dbExecute(dbcon,qry)) + if (class(res) == "try-error") return(FALSE) + } + } + return(TRUE) +} + +mkdbhCase = function (stpdbh=5,lgdbh=100) +{ + stpdbh=if (is.na(stpdbh) || as.numeric(stpdbh)==0 || + as.character(stpdbh)=="") 5 else ceiling(stpdbh) + if (is.na(lgdbh ) || as.numeric(lgdbh )==0 || as.character(lgdbh )=="") lgdbh =100 + if (stpdbh<1) stpdbh=1 + if (lgdbh= ",lb[i]," and dbh < ", + lb[i+1],") then '", chrclasses[i],"'") + } + subExpression = paste0(subExpression," else '",lb[length(lb)],"+' end ") + subExpression +} + +Create_CmpMetaData = " +drop table if exists CmpMetaData; +create table CmpMetaData as + select RunTitle,RunDateTime,Variant, + sum(SamplingWt) as TotalSamplingWt, + count(*) as NumOfCases, + Version, RV, KeywordFile from FVS_Cases + where CaseID in (select CaseID from temp.Cases) + group by KeywordFile + order by RunTitle, RunDateTime;" + +Create_StdStkDBHSp = " +drop table if exists temp.StdStkDBHSp; +drop table if exists temp.StdStkAllDBH; +drop table if exists temp.StdStkAllSp; +drop table if exists temp.StdStkAllAll; +create table temp.StdStkDBHSp as + select CaseID,Year,asSpecies, + subExpression as DBHClass, + sum(TPH) as LiveTPH, + sum(DBH*DBH*7.853982E-05*TPH) as LiveBA, + sum(TCuM*TPH) as LiveTCuM, + sum(MCuM*TPH) as LiveMCuM, + sum(MortPH) as MrtTPH, + sum(DBH*DBH*7.853982E-05*MortPH) as MrtBA, + sum(TCuM*MortPH) as MrtTCuM, + sum(MCuM*MortPH) as MrtMCuM + from FVS_TreeList_Metric + where CaseID in (select CaseID from temp.Cases) + group by CaseID,Year,DBHClass,Species + order by CaseID,Year,DBHClass,Species; +create table temp.StdStkAllDBH as + select CaseID,Year,Species,'All' as DBHClass, + sum(LiveTPH) as LiveTPH, + sum(LiveBA) as LiveBA, + sum(LiveTCuM) as LiveTCuM, + sum(LiveMCuM) as LiveMCuM, + sum(MrtTPH) as MrtTPH, + sum(MrtBA) as MrtBA, + sum(MrtTCuM) as MrtTCuM, + sum(MrtMCuM) as MrtMCuM + from temp.StdStkDBHSp + group by CaseID,Year,Species + order by CaseID,Year,Species,DBHClass; +create table temp.StdStkAllSp as + select CaseID,Year,'All' as Species, DBHClass, + sum(LiveTPH) as LiveTPH, + sum(LiveBA) as LiveBA, + sum(LiveTCuM) as LiveTCuM, + sum(LiveMCuM) as LiveMCuM, + sum(MrtTPH) as MrtTPH, + sum(MrtBA) as MrtBA, + sum(MrtTCuM) as MrtTCuM, + sum(MrtMCuM) as MrtMCuM + from temp.StdStkDBHSp + group by CaseID,Year,DBHClass + order by CaseID,Year,Species,DBHClass; +create table temp.StdStkAllAll as + select CaseID,Year,'All' as Species, 'All' as DBHClass, + sum(LiveTPH) as LiveTPH, + sum(LiveBA) as LiveBA, + sum(LiveTCuM) as LiveTCuM, + sum(LiveMCuM) as LiveMCuM, + sum(MrtTPH) as MrtTPH, + sum(MrtBA) as MrtBA, + sum(MrtTCuM) as MrtTCuM, + sum(MrtMCuM) as MrtMCuM + from temp.StdStkDBHSp + group by CaseID,Year + order by CaseID,Year,Species,DBHClass; +insert into temp.StdStkDBHSp select * from temp.StdStkAllSp; +insert into temp.StdStkDBHSp select * from temp.StdStkAllDBH; +insert into temp.StdStkDBHSp select * from temp.StdStkAllAll;" + + +Create_HrvStdStk = " +drop table if exists temp.HrvStdStk; +drop table if exists temp.HrvStdStkAllDBH; +drop table if exists temp.HrvStdStkAllSp; +drop table if exists temp.HrvStdStkAllAll; +create table temp.HrvStdStk as + select CaseID,Year,asSpecies, + subExpression as dbhclass, + sum(TPH) as HrvTPH, + sum(DBH*DBH*7.853982E-05*TPH) as HrvBA, + sum(TCuM*TPH) as HrvTCuM, + sum(MCuM*TPH) as HrvMCuM + from FVS_CutList_Metric + where CaseID in (select CaseID from temp.Cases) + group by CaseID,Year,Species,DBHClass; +create table temp.HrvStdStkAllDBH as + select CaseID,Year,Species,'All' as DBHClass, + sum(HrvTPH) as HrvTPH, + sum(HrvBA) as HrvBA, + sum(HrvTCuM) as HrvTCuM, + sum(HrvMCuM) as HrvMCuM + from temp.HrvStdStk + group by CaseID,Year,Species; +create table temp.HrvStdStkAllSp as + select CaseID,Year,'All' as Species, DBHClass, + sum(HrvTPH) as HrvTPH, + sum(HrvBA) as HrvBA, + sum(HrvTCuM) as HrvTCuM, + sum(HrvMCuM) as HrvMCuM + from temp.HrvStdStk + group by CaseID,Year,DBHClass; +create table temp.HrvStdStkAllAll as + select CaseID,Year,'All' as Species, 'All' as DBHClass, + sum(HrvTPH) as HrvTPH, + sum(HrvBA) as HrvBA, + sum(HrvTCuM) as HrvTCuM, + sum(HrvMCuM) as HrvMCuM + from temp.HrvStdStk + group by CaseID,Year; +insert into temp.HrvStdStk select * from temp.HrvStdStkAllSp; +insert into temp.HrvStdStk select * from temp.HrvStdStkAllDBH; +insert into temp.HrvStdStk select * from temp.HrvStdStkAllAll;" + +Create_StdStk1Hrv = " +drop table if exists temp.StdStk2; +create table temp.StdStk2 as select * from temp.StdStkDBHSp + left join temp.HrvStdStk using (CaseID,Year,Species,DBHClass); +drop table if exists temp.StdStk1; +create table temp.StdStk1 as +select Year,Species,DBHClass, + LiveTPH, LiveBA, LiveTCuM, LiveMCuM, + case when HrvTPH is not null then HrvTPH else 0 end as HrvTPH, + case when HrvBA is not null then HrvBA else 0 end as HrvBA, + case when HrvTCuM is not null then HrvTCuM else 0 end as HrvTCuM, + case when HrvMCuM is not null then HrvMCuM else 0 end as HrvMCuM, + MrtTPH, MrtBA, MrtTCuM, MrtMCuM, CaseID +from temp.StdStk2;" + +Create_StdStk1NoHrv = " +drop table if exists temp.StdStk1; +create table temp.StdStk1 as +select Year,Species,DBHClass, + LiveTPH, LiveBA, LiveTCuM, LiveMCuM, + 0 as HrvTPH, 0 as HrvBA, 0 as HrvTCuM, 0 as HrvMCuM, + MrtTPH, MrtBA, MrtTCuM, MrtMCuM, CaseID +from temp.StdStkDBHSp;" + +Create_StdStkFinal = " +drop table if exists StdStk_Metric; +create table StdStk_Metric as select Year, Species, DBHClass, + LiveTPH, MrtTPH, HrvTPH, LiveTPH - HrvTPH as RsdTPH, + LiveBA, MrtBA, HrvBA, LiveBA - HrvBA as RsdBA, + LiveTCuM, MrtTCuM, HrvTCuM, LiveTCuM - HrvTCuM as RsdTCuM, + LiveMCuM, MrtMCuM, HrvMCuM, LiveMCuM - HrvMCuM as RsdMCuM, + CaseID from temp.StdStk1;" + +Create_CmpStdStk = " +drop table if exists CmpSmpWt; +drop table if exists CmpStdStk_Metric; +drop table if exists temp.CmpStdStkDBHSp; +drop table if exists temp.CmpStdStkDBHAll; +drop table if exists temp.CmpStdStkAllSp; +drop table if exists temp.CmpStdStkAllAll; +create table temp.CmpSmpWt as + select MgmtID,sum(SamplingWt) as CmpSmpWt from FVS_Cases where + CaseID in (select CaseID from temp.Cases) + group by MgmtID; +create table temp.CmpStdStkDBHSp as + select MgmtID,Year,Species,DBHClass, + sum(LiveTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveTPH, + sum(MrtTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtTPH, + sum(HrvTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvTPH, + sum(RsdTPH *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdTPH, + sum(LiveBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveBA, + sum(MrtBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtBA, + sum(HrvBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvBA, + sum(RsdBA *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdBA, + sum(LiveTCuM*SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveTCuM, + sum(MrtTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtTCuM, + sum(HrvTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvTCuM, + sum(RsdTCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdTCuM, + sum(LiveMCuM*SamplingWt)/CmpSmpWt.CmpSmpWt as CmpLiveMCuM, + sum(MrtMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpMrtMCuM, + sum(HrvMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpHrvMCuM, + sum(RsdMCuM *SamplingWt)/CmpSmpWt.CmpSmpWt as CmpRsdMCuM + from (select * from StdStk_Metric where Species != 'All' and DBHClass != 'All' and + CaseID in (select CaseID from temp.Cases)) + join FVS_Cases using (CaseID) + join temp.CmpSmpWt using (MgmtID) + group by MgmtID,Year,Species,DBHClass; +create table temp.CmpStdStkDBHAll as + select MgmtID,Year,Species,'All' as DBHClass, + round(sum(CmpLiveTPH),2) as CmpLiveTPH, + round(sum(CmpMrtTPH),2) as CmpMrtTPH, + round(sum(CmpHrvTPH),2) as CmpHrvTPH, + round(sum(CmpRsdTPH),2) as CmpRsdTPH, + round(sum(CmpLiveBA),2) as CmpLiveBA, + round(sum(CmpMrtBA),2) as CmpMrtBA, + round(sum(CmpHrvBA),2) as CmpHrvBA, + round(sum(CmpRsdBA),2) as CmpRsdBA, + round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, + round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, + round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, + round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, + round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, + round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, + round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, + round(sum(CmpRsdMCuM),2) as CmpRsdMCuM + from temp.CmpStdStkDBHSp + group by MgmtID,Year,Species; +create table temp.CmpStdStkAllSp as + select MgmtID,Year,'All' as Species,DBHClass, + round(sum(CmpLiveTPH),2) as CmpLiveTPH, + round(sum(CmpMrtTPH),2) as CmpMrtTPH, + round(sum(CmpHrvTPH),2) as CmpHrvTPH, + round(sum(CmpRsdTPH),2) as CmpRsdTPH, + round(sum(CmpLiveBA),2) as CmpLiveBA, + round(sum(CmpMrtBA),2) as CmpMrtBA, + round(sum(CmpHrvBA),2) as CmpHrvBA, + round(sum(CmpRsdBA),2) as CmpRsdBA, + round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, + round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, + round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, + round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, + round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, + round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, + round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, + round(sum(CmpRsdMCuM),2) as CmpRsdMCuM + from temp.CmpStdStkDBHSp + group by MgmtID,Year,DBHClass; +create table temp.CmpStdStkAllAll as + select MgmtID,Year,'All' as Species,'All' as DBHClass, + round(sum(CmpLiveTPH),2) as CmpLiveTPH, + round(sum(CmpMrtTPH),2) as CmpMrtTPH, + round(sum(CmpHrvTPH),2) as CmpHrvTPH, + round(sum(CmpRsdTPH),2) as CmpRsdTPH, + round(sum(CmpLiveBA),2) as CmpLiveBA, + round(sum(CmpMrtBA),2) as CmpMrtBA, + round(sum(CmpHrvBA),2) as CmpHrvBA, + round(sum(CmpRsdBA),2) as CmpRsdBA, + round(sum(CmpLiveTCuM),2) as CmpLiveTCuM, + round(sum(CmpMrtTCuM),2) as CmpMrtTCuM, + round(sum(CmpHrvTCuM),2) as CmpHrvTCuM, + round(sum(CmpRsdTCuM),2) as CmpRsdTCuM, + round(sum(CmpLiveMCuM),2) as CmpLiveMCuM, + round(sum(CmpMrtMCuM),2) as CmpMrtMCuM, + round(sum(CmpHrvMCuM),2) as CmpHrvMCuM, + round(sum(CmpRsdMCuM),2) as CmpRsdMCuM + from temp.CmpStdStkDBHSp + group by MgmtID,Year; +create table CmpStdStk_Metric as + select MgmtID,Year,Species,DBHClass, + round(CmpLiveTPH ,2) as CmpLiveTPH, + round(CmpMrtTPH ,2) as CmpMrtTPH, + round(CmpHrvTPH ,2) as CmpHrvTPH, + round(CmpRsdTPH ,2) as CmpRsdTPH, + round(CmpLiveBA ,2) as CmpLiveBA, + round(CmpMrtBA ,2) as CmpMrtBA, + round(CmpHrvBA ,2) as CmpHrvBA, + round(CmpRsdBA ,2) as CmpRsdBA, + round(CmpLiveTCuM,2) as CmpLiveTCuM, + round(CmpMrtTCuM ,2) as CmpMrtTCuM, + round(CmpHrvTCuM ,2) as CmpHrvTCuM, + round(CmpRsdTCuM ,2) as CmpRsdTCuM, + round(CmpLiveMCuM,2) as CmpLiveMCuM, + round(CmpMrtMCuM ,2) as CmpMrtMCuM, + round(CmpHrvMCuM ,2) as CmpHrvMCuM, + round(CmpRsdMCuM ,2) as CmpRsdMCuM + from temp.CmpStdStkDBHSp; +insert into CmpStdStk_Metric select * from temp.CmpStdStkAllSp; +insert into CmpStdStk_Metric select * from temp.CmpStdStkDBHAll; +insert into CmpStdStk_Metric select * from temp.CmpStdStkAllAll;" + +Create_CmpSummary2 = " +drop table if exists temp.CmpSummary2A; +create table temp.CmpSummary2A as + select MgmtID,Year,RmvCode, + round(sum(Age *SamplingWt)/sum(SamplingWt),2) as CmpAge, + round(sum(TPH *SamplingWT)/sum(SamplingWt),2) as CmpTPH, + round(sum(TprdTPH *SamplingWT)/sum(SamplingWt),2) as CmpTprdTPH, + round(sum(BA *SamplingWT)/sum(SamplingWt),2) as CmpBA, + round(sum(SDI *SamplingWT)/sum(SamplingWt),2) as CmpSDI, + round(sum(CCF *SamplingWT)/sum(SamplingWt),2) as CmpCCF, + round(sum(TopHt *SamplingWT)/sum(SamplingWt),2) as CmpTopHt, + round(sum(QMD *SamplingWT)/sum(SamplingWt),2) as CmpQMD, + round(sum(TCuM *SamplingWT)/sum(SamplingWt),2) as CmpTCuM, + round(sum(TprdTCuM*SamplingWT)/sum(SamplingWt),2) as CmpTprdTCuM, + round(sum(MCuM *SamplingWT)/sum(SamplingWt),2) as CmpMCuM, + round(sum(TprdMCuM*SamplingWT)/sum(SamplingWt),2) as CmpTprdMCuM, + round(sum(RTPH *SamplingWT)/sum(SamplingWt),2) as CmpRTPH, + round(sum(RTCuM *SamplingWT)/sum(SamplingWt),2) as CmpRTCuM, + round(sum(RMCuM *SamplingWT)/sum(SamplingWt),2) as CmpRMCuM, + round(sum(SamplingWt ),2) as CmpSamplingWt + from (select * from FVS_Summary2_Metric where CaseID in (select CaseID from temp.Cases)) + join FVS_Cases using (CaseID) + group by MgmtID,Year,RmvCode order by MgmtID,Year,RmvCode; + +drop table if exists temp.CmpSummary2B; +create table temp.CmpSummary2B as + select MgmtID,Year,RmvCode,max(RmvCode) as newRmv, + round(sum(CmpAge *CmpSamplingWt)/sum(CmpSamplingWt),2) as CmpAge, + round(sum(CmpTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTPH, + round(sum(CmpTprdTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTPH, + round(sum(CmpBA *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpBA, + round(sum(CmpSDI *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpSDI, + round(sum(CmpCCF *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpCCF, + round(sum(CmpTopHt *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTopHt, + round(sum(CmpQMD *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpQMD, + round(sum(CmpTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTCuM, + round(sum(CmpTprdTCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTCuM, + round(sum(CmpMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpMCuM, + round(sum(CmpTprdMCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdMCuM, + round(sum(CmpRTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTPH, + round(sum(CmpRTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTCuM, + round(sum(CmpRMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRMCuM, + round(sum(CmpSamplingWt ),2) as CmpSamplingWt + from temp.CmpSummary2A where RmvCode in (0,1) + group by MgmtID,Year order by MgmtID,Year; + +insert into temp.CmpSummary2B + select MgmtID,Year,RmvCode,max(RmvCode) as newRmv, + round(sum(CmpAge *CmpSamplingWt)/sum(CmpSamplingWt),2) as CmpAge, + round(sum(CmpTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTPH, + round(sum(CmpTprdTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTPH, + round(sum(CmpBA *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpBA, + round(sum(CmpSDI *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpSDI, + round(sum(CmpCCF *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpCCF, + round(sum(CmpTopHt *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTopHt, + round(sum(CmpQMD *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpQMD, + round(sum(CmpTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTCuM, + round(sum(CmpTprdTCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdTCuM, + round(sum(CmpMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpMCuM, + round(sum(CmpTprdMCuM*CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpTprdMCuM, + round(sum(CmpRTPH *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTPH, + round(sum(CmpRTCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRTCuM, + round(sum(CmpRMCuM *CmpSamplingWT)/sum(CmpSamplingWt),2) as CmpRMCuM, + round(sum(CmpSamplingWt ),2) as CmpSamplingWt + from temp.CmpSummary2A where RmvCode in (0,2) + group by MgmtID,Year order by MgmtID,Year; + +drop table if exists CmpSummary2_Metric; +create table CmpSummary2_Metric as + select distinct MgmtID,Year,newRmv as RmvCode,CmpAge,CmpTPH,CmpTprdTPH, + CmpBA,CmpSDI,CmpCCF,CmpTopHt,CmpQMD,CmpTCuM, + CmpTprdTCuM,CmpMCuM,CmpTprdMCuM, + CmpRTPH,CmpRTCuM,CmpRMCuM,CmpSamplingWt + from temp.CmpSummary2B + order by MgmtID,Year,RmvCode; +drop table if exists temp.CmpSummary2A; +drop table if exists temp.CmpSummary2B;" + + +Create_CmpCompute = " +drop table if exists CmpCompute; +create table CmpCompute as + select MgmtID,Year,subExpression, + round(sum(SamplingWt),2) as CmpSamplingWt + from (select * from FVS_Compute where CaseID in (select CaseID from temp.Cases)) + join FVS_Cases using (CaseID) + group by MgmtID,Year;" + +Create_View_DWN_Required = c("FVS_Down_Wood_Cov","FVS_Down_Wood_Vol") +Create_View_DWN = " +drop view if exists View_DWN; +create temp view View_DWN as +select FVS_Down_Wood_Cov.CaseID,FVS_Down_Wood_Cov.StandID, + FVS_Down_Wood_Cov.Year, + DWD_Cover_Total_Hard, DWD_Cover_Total_Soft, + DWD_Cover_Total_Hard+DWD_Cover_Total_Soft as DWD_Total_Cover, + DWD_Volume_Total_Hard, DWD_Volume_Total_Soft, + DWD_Volume_Total_Hard+DWD_Volume_Total_Soft as DWD_Total_Volume +from FVS_Down_Wood_Cov inner join FVS_Down_Wood_Vol + on FVS_Down_Wood_Cov.CaseID = FVS_Down_Wood_Vol.CaseID and + FVS_Down_Wood_Cov.Year = FVS_Down_Wood_Vol.Year;" + diff --git a/fvsOL/inst/extdata/www/message-handler.js b/fvsOL/inst/extdata/www/message-handler.js index 6097125..88069ef 100644 --- a/fvsOL/inst/extdata/www/message-handler.js +++ b/fvsOL/inst/extdata/www/message-handler.js @@ -1,166 +1,166 @@ -(function() { - -// This recieves messages of type "dialogContentUpdate" from the server. -Shiny.addCustomMessageHandler("dialogContentUpdate", - function(data) { - $('#' + data.id).find(".modal-body").html(data.message); - } -); - -// This recieves messages of type "infomessage" from the server. -Shiny.addCustomMessageHandler("infomessage", - function(message) { alert(message); } -); - -// Refocus "eltid" -Shiny.addCustomMessageHandler("refocus", - function(eltid) { document.getElementById(eltid).focus(); } -); - - - -// This gets the cursor postion from eltid -Shiny.addCustomMessageHandler("getStartEnd", - function(eltid) - { - if (document.getElementById(eltid)) - { - document.getElementById(eltid).onmouseout = function() - { - Shiny.onInputChange("selectionStart", document.getElementById(eltid).selectionStart); - Shiny.onInputChange("selectionEnd", document.getElementById(eltid).selectionEnd); - } - } - } -); - -// This will attempt to open a new tab with the provided URL -// add: session$sendCustomMessage(type = "openURL",url) anywhere in the server code. -Shiny.addCustomMessageHandler("openURL", - function (url) { window.open(url); } -); - -// This will close the window, it causes onSessionEnded to be called as well. -// add: session$sendCustomMessage(type = "closeWindow"," ") anywhere in the server code. -Shiny.addCustomMessageHandler("closeWindow", - function (dummy) { window.close(); } -); - -// this function load causes a shiny variable "signalClosing" to be set to 1 if the -// browser is being closed for any reason. NB: return null will suppress the "do you -// really want to exit" dialog automatically created by the browser. -window.onbeforeunload = function(e) -{ - Shiny.onInputChange("signalClosing", 1); - return null; -}; - - -// copy an items content to the clipboard. -Shiny.addCustomMessageHandler("copyEltToClipboard", - function(eltid) - { - const elt = document.getElementById(eltid); - const selection = window.getSelection(); - selection.removeAllRanges(); - range = document.createRange(); - range.selectNodeContents(elt); - selection.addRange(range); - document.execCommand('copy'); - selection.removeAllRanges(); - } -); - - - -// should work but doesn't because of a bug in javascript. -//Shiny.addCustomMessageHandler("copyWebGLShapshotToClipboard", -// function(eltid) -// { -// const elt = document.getElementById(eltid); -// const myImageData = elt.firstChild.toDataURL(); -// const imgBlob = new Blob([myImageData], { type: "image/png;base64" }); -// const item = new ClipboardItem({[imgBlob.type]: imgBlob}); -// navigator.clipboard.write([item]); -// } -//); - -Shiny.addCustomMessageHandler("copyWebGLSnapshotToClipboard", - function(eltid) - { - const elt = document.getElementById(eltid); - const imageData = elt.firstChild.toDataURL('image/png', 1.0); - var imageElt = document.createElement("IMG"); - imageElt.setAttribute("src", imageData); - imageElt.setAttribute("alt", eltid); - document.body.appendChild(imageElt); - const selection = window.getSelection(); - selection.removeAllRanges(); - range = document.createRange(); - range.selectNode(imageElt); - selection.addRange(range); - document.execCommand('copy'); - selection.removeAllRanges(); - document.body.removeChild(imageElt); - } -); - - -Shiny.addCustomMessageHandler("makeTopSideImages", - function(eltIds) - { - var eltid=eltIds[0]; - var persid=eltIds[1]; - var topid=eltIds[2]; - var sidid=eltIds[3]; - const elt = document.getElementById(eltid); - const pers = document.getElementById(persid); - const top = document.getElementById(topid); - const ssid = document.getElementById(sidid); - var rglinst = elt.rglinstance; - if (rglinst == null) return; - var sid = rglinst.scene.rootSubscene; - if (sid == null) return; - let p3d = rglinst.getObj(sid).par3d; - if (p3d == null) return; - let cpy3d = JSON.parse(JSON.stringify(p3d)); - cpy3d.userMatrix.m11=1; - cpy3d.userMatrix.m12=0; - cpy3d.userMatrix.m13=0; - cpy3d.userMatrix.m14=0; - cpy3d.userMatrix.m21=0; - cpy3d.userMatrix.m22=0; - cpy3d.userMatrix.m23=1; - cpy3d.userMatrix.m24=0; - cpy3d.userMatrix.m31=0; - cpy3d.userMatrix.m32=1; - cpy3d.userMatrix.m33=0; - cpy3d.userMatrix.m34=0; - cpy3d.userMatrix.m41=0; - cpy3d.userMatrix.m42=0; - cpy3d.userMatrix.m43=0; - cpy3d.userMatrix.m44=1; - rglinst.getObj(sid).par3d = cpy3d; - rglinst.drawScene(); - var imageData = elt.firstChild.toDataURL('image/png', 1.0); - ssid.setAttribute("src", imageData); - cpy3d.userMatrix.m22=1; - cpy3d.userMatrix.m23=0; - cpy3d.userMatrix.m32=0; - cpy3d.userMatrix.m33=1; - rglinst.getObj(sid).par3d = cpy3d; - rglinst.drawScene(); - imageData = elt.firstChild.toDataURL('image/png', 1.0); - top.setAttribute("src", imageData); - rglinst.getObj(sid).par3d = p3d; - rglinst.drawScene(); - var imageData = elt.firstChild.toDataURL('image/png', 1.0); - pers.setAttribute("src", imageData); - } -); - - -})(); - - +(function() { + +// This recieves messages of type "dialogContentUpdate" from the server. +Shiny.addCustomMessageHandler("dialogContentUpdate", + function(data) { + $('#' + data.id).find(".modal-body").html(data.message); + } +); + +// This recieves messages of type "infomessage" from the server. +Shiny.addCustomMessageHandler("infomessage", + function(message) { alert(message); } +); + +// Refocus "eltid" +Shiny.addCustomMessageHandler("refocus", + function(eltid) { document.getElementById(eltid).focus(); } +); + + + +// This gets the cursor postion from eltid +Shiny.addCustomMessageHandler("getStartEnd", + function(eltid) + { + if (document.getElementById(eltid)) + { + document.getElementById(eltid).onmouseout = function() + { + Shiny.onInputChange("selectionStart", document.getElementById(eltid).selectionStart); + Shiny.onInputChange("selectionEnd", document.getElementById(eltid).selectionEnd); + } + } + } +); + +// This will attempt to open a new tab with the provided URL +// add: session$sendCustomMessage(type = "openURL",url) anywhere in the server code. +Shiny.addCustomMessageHandler("openURL", + function (url) { window.open(url); } +); + +// This will close the window, it causes onSessionEnded to be called as well. +// add: session$sendCustomMessage(type = "closeWindow"," ") anywhere in the server code. +Shiny.addCustomMessageHandler("closeWindow", + function (dummy) { window.close(); } +); + +// this function load causes a shiny variable "signalClosing" to be set to 1 if the +// browser is being closed for any reason. NB: return null will suppress the "do you +// really want to exit" dialog automatically created by the browser. +window.onbeforeunload = function(e) +{ + Shiny.onInputChange("signalClosing", 1); + return null; +}; + + +// copy an items content to the clipboard. +Shiny.addCustomMessageHandler("copyEltToClipboard", + function(eltid) + { + const elt = document.getElementById(eltid); + const selection = window.getSelection(); + selection.removeAllRanges(); + range = document.createRange(); + range.selectNodeContents(elt); + selection.addRange(range); + document.execCommand('copy'); + selection.removeAllRanges(); + } +); + + + +// should work but doesn't because of a bug in javascript. +//Shiny.addCustomMessageHandler("copyWebGLShapshotToClipboard", +// function(eltid) +// { +// const elt = document.getElementById(eltid); +// const myImageData = elt.firstChild.toDataURL(); +// const imgBlob = new Blob([myImageData], { type: "image/png;base64" }); +// const item = new ClipboardItem({[imgBlob.type]: imgBlob}); +// navigator.clipboard.write([item]); +// } +//); + +Shiny.addCustomMessageHandler("copyWebGLSnapshotToClipboard", + function(eltid) + { + const elt = document.getElementById(eltid); + const imageData = elt.firstChild.toDataURL('image/png', 1.0); + var imageElt = document.createElement("IMG"); + imageElt.setAttribute("src", imageData); + imageElt.setAttribute("alt", eltid); + document.body.appendChild(imageElt); + const selection = window.getSelection(); + selection.removeAllRanges(); + range = document.createRange(); + range.selectNode(imageElt); + selection.addRange(range); + document.execCommand('copy'); + selection.removeAllRanges(); + document.body.removeChild(imageElt); + } +); + + +Shiny.addCustomMessageHandler("makeTopSideImages", + function(eltIds) + { + var eltid=eltIds[0]; + var persid=eltIds[1]; + var topid=eltIds[2]; + var sidid=eltIds[3]; + const elt = document.getElementById(eltid); + const pers = document.getElementById(persid); + const top = document.getElementById(topid); + const ssid = document.getElementById(sidid); + var rglinst = elt.rglinstance; + if (rglinst == null) return; + var sid = rglinst.scene.rootSubscene; + if (sid == null) return; + let p3d = rglinst.getObj(sid).par3d; + if (p3d == null) return; + let cpy3d = JSON.parse(JSON.stringify(p3d)); + cpy3d.userMatrix.m11=1; + cpy3d.userMatrix.m12=0; + cpy3d.userMatrix.m13=0; + cpy3d.userMatrix.m14=0; + cpy3d.userMatrix.m21=0; + cpy3d.userMatrix.m22=0; + cpy3d.userMatrix.m23=1; + cpy3d.userMatrix.m24=0; + cpy3d.userMatrix.m31=0; + cpy3d.userMatrix.m32=1; + cpy3d.userMatrix.m33=0; + cpy3d.userMatrix.m34=0; + cpy3d.userMatrix.m41=0; + cpy3d.userMatrix.m42=0; + cpy3d.userMatrix.m43=0; + cpy3d.userMatrix.m44=1; + rglinst.getObj(sid).par3d = cpy3d; + rglinst.drawScene(); + var imageData = elt.firstChild.toDataURL('image/png', 1.0); + ssid.setAttribute("src", imageData); + cpy3d.userMatrix.m22=1; + cpy3d.userMatrix.m23=0; + cpy3d.userMatrix.m32=0; + cpy3d.userMatrix.m33=1; + rglinst.getObj(sid).par3d = cpy3d; + rglinst.drawScene(); + imageData = elt.firstChild.toDataURL('image/png', 1.0); + top.setAttribute("src", imageData); + rglinst.getObj(sid).par3d = p3d; + rglinst.drawScene(); + var imageData = elt.firstChild.toDataURL('image/png', 1.0); + pers.setAttribute("src", imageData); + } +); + + +})(); + + \ No newline at end of file diff --git a/fvsOL/makefile b/fvsOL/makefile index 0d4a737..406b504 100644 --- a/fvsOL/makefile +++ b/fvsOL/makefile @@ -13,5 +13,5 @@ fvsOLmadeTag: makefile DESCRIPTION R/* inst/extdata/* inst/extdata/www/* data/* touch fvsOLmadeTag clean: - rm data/prms.RData data/fvsOnlineHelpRender.RData fvsOLmadeTag - + rm data/prms.RData data/fvsOnlineHelpRender.RData fvsOLmadeTag + \ No newline at end of file diff --git a/fvsOL/parms/HabPa_oc.prm b/fvsOL/parms/HabPa_oc.prm index ff872a8..701fbe1 100644 --- a/fvsOL/parms/HabPa_oc.prm +++ b/fvsOL/parms/HabPa_oc.prm @@ -1,95 +1,95 @@ -//start HabPa_oc - -{blank}:{} - 1:{CDC411 PSME-ABCO-PIJE} - 2:{CDC412 PSME-ABCO-PIPO} - 3:{CDC421 PSME-ABCO} - 4:{CDC431 PSME-ABCO/HODI} - 5:{CDC432 PSME-ABCO/BENE} - 6:{CDC511 PSME-PIPO} - 7:{CDC521 PSME-PIJE} - 8:{CDF911 PSME/DEPAUPERATE} - 9:{CDH111 PSME-LIDE3/GASH} - 10:{CDH112 PSME/RHMA} - 11:{CDH121 PSME-LIDE3-PILA} - 12:{CDH131 PSME-LIDE3} - 13:{CDH141 PSME-LIDE3-QUCH} - 14:{CDH142 PSME-LIDE3/RHDI} - 15:{CDH511 PSME-QUSA} - 16:{CDS111 PSME/RHDI-BEPI} - 17:{CDS112 PSME/RHDI} - 18:{CDS511 PSME/BENE} - 19:{CDS521 PSME/BERE} - 20:{CHC111 TSHE-CHLA} - 21:{CHC412 TSHE-THPL/HIGH ELEV} - 22:{CHC461 TSHE-THPL} - 23:{CHC611 TSHE-ABCO} - 24:{CHH111 TSHE-UMCA} - 25:{CHH511 TSHE-QUSA} - 26:{CHS131 TSHE/GASH (SWO)} - 27:{CHS331 TSHE/RHMA (SWO)} - 28:{CMF211 TSME/POPU} - 29:{CPC411 PIPO-PSME} - 30:{CPC511 PIJE-PIMO} - 31:{CPG141 PIJE/FEID} - 32:{CPH411 PIJE-QUVA} - 33:{CPS321 PIJE/CEPU} - 34:{CPS611 PIJE/GRASS} - 35:{CQF111 PIMO/XETE} - 36:{CRF211 ABMAS/POPU} - 37:{CRF311 ABMAS/SHEEP} - 38:{CRH111 ABMAS-QUSA} - 39:{CRS211 ABMAS/SYMO} - 40:{CTH111 CHLA-QUVA} - 41:{CTH211 CHLA-ACMA} - 42:{CTS111 CHLA/BENE/ACTR} - 43:{CTS112 CHLA/BENE/LIBOL} - 44:{CTS211 CHLA/GASH} - 45:{CTS311 CHLA/GABU} - 46:{CWC221 ABCO-PSME} - 47:{CWC231 ABCO-PSME/BENE} - 48:{CWC232 ABCO-PSME/HODI} - 49:{CWC233 ABCO-PSME/DEPAUPERATE} - 50:{CWC241 ABCO-PIPO} - 51:{CWC521 ABCO-PIBR/VAME} - 52:{CWC522 ABCO-PIBR/GAOV} - 53:{CWC523 ABCO-PIBR/CHUM} - 54:{CWC611 ABCO-CHLA} - 55:{CWC612 ABCO-CHLA/DEPAUPERATE} - 56:{CWC721 ABCO-ABMAS/RIBES} - 57:{CWC722 ABCO-ABMAS/ROGY} - 58:{CWC723 ABCO-ABMAS/SYMO} - 59:{CWC811 ABCO-TABR} - 60:{CWC911 ABCO-CHNO} - 61:{CWF911 ABCO/HERB} - 62:{CWH312 ABCO-LIDE3} - 63:{CWH413 ABCO-ACGL} - 64:{CWH511 ABCO-QUSA/CHUM} - 65:{CWH521 ABCO-QUSA/BENE-PAMY} - 66:{CWH522 ABCO-QUSA/BENE} - 67:{CWH531 ABCO-QUSA-CACH} - 68:{CWS331 ABCO/SYMO} - 69:{CWS523 ABCO/BENE} - 70:{HTC111 LIDE3-SESE2} - 71:{HTC211 LIDE3-TSHE} - 72:{HTC311 LIDE3-CHLA} - 73:{HTC411 LIDE3-ABCO-ACCI} - 74:{HTC412 LIDE3-ABCO} - 75:{HTH111 LIDE3-QUCH} - 76:{HTH112 LIDE3-QUCH/BENE} - 77:{HTH211 LIDE3-UMCA} - 78:{HTH311 LIDE3-ACCI} - 79:{HTS111 LIDE3/VAOV2-GASH} - 80:{HTS112 LIDE3/VAOV2} - 81:{HTS221 LIDE3/RHMA} - 82:{HTS222 LIDE3/RHMA-VAOV2} - 83:{HTS223 LIDE3/RHMA-GASH} - 84:{HTS311 LIDE3/BENE} - 85:{HTS312 LIDE3/BENE-RHDI} - 86:{HTS321 LIDE3/GASH} - 87:{HTS331 LIDE3/GASH-RHMA} - 88:{HTS341 LIDE3/GASH-BENE} - 89:{HTS411 LIDE3/RHDI-LOHI} - 90:{HTS511 LIDE3/RHCA} - -//end HabPa_oc +//start HabPa_oc + +{blank}:{} + 1:{CDC411 PSME-ABCO-PIJE} + 2:{CDC412 PSME-ABCO-PIPO} + 3:{CDC421 PSME-ABCO} + 4:{CDC431 PSME-ABCO/HODI} + 5:{CDC432 PSME-ABCO/BENE} + 6:{CDC511 PSME-PIPO} + 7:{CDC521 PSME-PIJE} + 8:{CDF911 PSME/DEPAUPERATE} + 9:{CDH111 PSME-LIDE3/GASH} + 10:{CDH112 PSME/RHMA} + 11:{CDH121 PSME-LIDE3-PILA} + 12:{CDH131 PSME-LIDE3} + 13:{CDH141 PSME-LIDE3-QUCH} + 14:{CDH142 PSME-LIDE3/RHDI} + 15:{CDH511 PSME-QUSA} + 16:{CDS111 PSME/RHDI-BEPI} + 17:{CDS112 PSME/RHDI} + 18:{CDS511 PSME/BENE} + 19:{CDS521 PSME/BERE} + 20:{CHC111 TSHE-CHLA} + 21:{CHC412 TSHE-THPL/HIGH ELEV} + 22:{CHC461 TSHE-THPL} + 23:{CHC611 TSHE-ABCO} + 24:{CHH111 TSHE-UMCA} + 25:{CHH511 TSHE-QUSA} + 26:{CHS131 TSHE/GASH (SWO)} + 27:{CHS331 TSHE/RHMA (SWO)} + 28:{CMF211 TSME/POPU} + 29:{CPC411 PIPO-PSME} + 30:{CPC511 PIJE-PIMO} + 31:{CPG141 PIJE/FEID} + 32:{CPH411 PIJE-QUVA} + 33:{CPS321 PIJE/CEPU} + 34:{CPS611 PIJE/GRASS} + 35:{CQF111 PIMO/XETE} + 36:{CRF211 ABMAS/POPU} + 37:{CRF311 ABMAS/SHEEP} + 38:{CRH111 ABMAS-QUSA} + 39:{CRS211 ABMAS/SYMO} + 40:{CTH111 CHLA-QUVA} + 41:{CTH211 CHLA-ACMA} + 42:{CTS111 CHLA/BENE/ACTR} + 43:{CTS112 CHLA/BENE/LIBOL} + 44:{CTS211 CHLA/GASH} + 45:{CTS311 CHLA/GABU} + 46:{CWC221 ABCO-PSME} + 47:{CWC231 ABCO-PSME/BENE} + 48:{CWC232 ABCO-PSME/HODI} + 49:{CWC233 ABCO-PSME/DEPAUPERATE} + 50:{CWC241 ABCO-PIPO} + 51:{CWC521 ABCO-PIBR/VAME} + 52:{CWC522 ABCO-PIBR/GAOV} + 53:{CWC523 ABCO-PIBR/CHUM} + 54:{CWC611 ABCO-CHLA} + 55:{CWC612 ABCO-CHLA/DEPAUPERATE} + 56:{CWC721 ABCO-ABMAS/RIBES} + 57:{CWC722 ABCO-ABMAS/ROGY} + 58:{CWC723 ABCO-ABMAS/SYMO} + 59:{CWC811 ABCO-TABR} + 60:{CWC911 ABCO-CHNO} + 61:{CWF911 ABCO/HERB} + 62:{CWH312 ABCO-LIDE3} + 63:{CWH413 ABCO-ACGL} + 64:{CWH511 ABCO-QUSA/CHUM} + 65:{CWH521 ABCO-QUSA/BENE-PAMY} + 66:{CWH522 ABCO-QUSA/BENE} + 67:{CWH531 ABCO-QUSA-CACH} + 68:{CWS331 ABCO/SYMO} + 69:{CWS523 ABCO/BENE} + 70:{HTC111 LIDE3-SESE2} + 71:{HTC211 LIDE3-TSHE} + 72:{HTC311 LIDE3-CHLA} + 73:{HTC411 LIDE3-ABCO-ACCI} + 74:{HTC412 LIDE3-ABCO} + 75:{HTH111 LIDE3-QUCH} + 76:{HTH112 LIDE3-QUCH/BENE} + 77:{HTH211 LIDE3-UMCA} + 78:{HTH311 LIDE3-ACCI} + 79:{HTS111 LIDE3/VAOV2-GASH} + 80:{HTS112 LIDE3/VAOV2} + 81:{HTS221 LIDE3/RHMA} + 82:{HTS222 LIDE3/RHMA-VAOV2} + 83:{HTS223 LIDE3/RHMA-GASH} + 84:{HTS311 LIDE3/BENE} + 85:{HTS312 LIDE3/BENE-RHDI} + 86:{HTS321 LIDE3/GASH} + 87:{HTS331 LIDE3/GASH-RHMA} + 88:{HTS341 LIDE3/GASH-BENE} + 89:{HTS411 LIDE3/RHDI-LOHI} + 90:{HTS511 LIDE3/RHCA} + +//end HabPa_oc diff --git a/fvsOL/parms/forest.prm b/fvsOL/parms/forest.prm index 8d0fd03..1f02e22 100644 --- a/fvsOL/parms/forest.prm +++ b/fvsOL/parms/forest.prm @@ -327,6 +327,7 @@ 606:{Mount Hood} 608:{Okanogan} 617:{Wenatchee} + 621:{Colville} 699:{Okanogan (Tonasket RD)} 613:{Mt Baker-Snowualmie (mapped to Wenatchee)} 8106:{Colville Reservation} diff --git a/fvsOL/parms/habpa_op.prm b/fvsOL/parms/habpa_op.prm index a5cfa98..a23cbb2 100644 --- a/fvsOL/parms/habpa_op.prm +++ b/fvsOL/parms/habpa_op.prm @@ -1,82 +1,82 @@ - -//start HabPa_op - -{blank}:{} - 1:{CDS221 PSME/HODI-ROGY} - 2:{CDS255 PSME/GASH} - 3:{CDS651 PSME/ARUV} - 4:{CEF321 ABLA2/LULA} - 5:{CES212 ABLA2/RHAL-OLY} - 6:{CES321 ABLA2/VAME-OLY} - 7:{CES621 ABLA2/JUCO4} - 8:{CFF111 ABAM/OXOR-OLY} - 9:{CFF211 ABAM/ACTR-TIUN} - 10:{CFF311 ABAM/XETE} - 11:{CFF611 ABAM/POMU} - 12:{CFF612 ABAM/POMU-OXOR} - 13:{CFF911 ABAM/Dep.} - 14:{CFS156 ABAM/GASH/OXOR} - 15:{CFS211 ABAM/VAME/XETE-OLY} - 16:{CFS212 ABAM/VAAL-OLY} - 17:{CFS213 ABAM/VAAL/ERMO} - 18:{CFS214 ABAM/VAAL/XETE} - 19:{CFS215 ABAM/VAAL/TIUN} - 20:{CFS217 ABAM/VAAL/OXOR} - 21:{CFS218 ABAM/VAAL/CLUN} - 22:{CFS219 ABAM/VAAL/LIBO2} - 23:{CFS311 ABAM/OPHO-OLY} - 24:{CFS611 ABAM/RHMA-OLY} - 25:{CFS612 ABAM/RHMA-VAAL} - 26:{CHF112 TSHE/OXOR-OLY} - 27:{CHF121 TSHE/OXOR-COAST} - 28:{CHF122 TSHE/POMU-COAST} - 29:{CHF131 TSHE/POMU-OXOR-OLY} - 30:{CHF132 TSHE/POMU-TITR} - 31:{CHF211 TSHE/ACTR-OLY} - 32:{CHF511 TSHE/XETE-OLY} - 33:{CHF911 TSHE/Dep.} - 34:{CHM111 TSHE/LYAM-OLY} - 35:{CHS121 TSHE/BENE-COAST} - 36:{CHS122 TSHE/BENE-GASH-COAST} - 37:{CHS123 TSHE/GASH-COAST} - 38:{CHS131 TSHE/GASH-OLY} - 39:{CHS132 TSHE/GASH/XETE} - 40:{CHS133 TSHE/GASH-VAOV2} - 41:{CHS134 TSHE/GASH-HODI} - 42:{CHS136 TSHE/GASH/OXOR} - 43:{CHS137 TSHE/GASH/POMU} - 44:{CHS138 TSHE/BENE-OLY} - 45:{CHS139 TSHE/BENE/POMU-OLY} - 46:{CHS221 TSHE/ACCI-GASH-COAST} - 47:{CHS222 TSHE/ACCI/POMU-COAST} - 48:{CHS321 TSHE/RHMA-BENE-COAST} - 49:{CHS322 TSHE/RHMA-GASH-COAST} - 50:{CHS323 TSHE/RHMA/POMU-COAST} - 51:{CHS324 TSHE/RHMA/VAOV2-COAST} - 52:{CHS331 TSHE/RHMA-OLY} - 53:{CHS332 TSHE/RHMA/XETE-OLY} - 54:{CHS333 TSHE/RHMA-BENE-OLY} - 55:{CHS334 TSHE/RHMA-GASH-OLY} - 56:{CHS335 TSHE/RHMA/POMU-OLY} - 57:{CHS421 TSHE/RUSP-COAST} - 58:{CHS422 TSHE/RUSP-ACCI-COAST} - 59:{CHS423 TSHE/RUSP-GASH-COAST} - 60:{CHS512 TSHE/OPHO-OLY} - 61:{CHS521 TSHE/OPHO-COAST} - 62:{CHS610 TSHE/VAOV2-COAST} - 63:{CHS621 TSHE/VAAL} - 64:{CHS622 TSHE/VAAL/XETE} - 65:{CHS623 TSHE/VAAL/OXOR-OLY} - 66:{CHS624 TSHE/VAAL-GASH-OLY} - 67:{CMS242 TSME/VAAL/ERMO} - 68:{CSF111 PISI/POMU-OXOR} - 69:{CSF121 PISI/POMU-COAST} - 70:{CSF321 PISI/OXOR-COAST} - 71:{CSS221 PISI/MEFE-VAPA-COAST} - 72:{CSS321 PISI/GASH-COAST} - 73:{CSS521 PISI/RUSP-COAST} - 74:{CSS522 PISI/RUSP-GASH-COAST} - 75:{CSS621 PISI/OPHO-COAST} - -//end HabPa_op - + +//start HabPa_op + +{blank}:{} + 1:{CDS221 PSME/HODI-ROGY} + 2:{CDS255 PSME/GASH} + 3:{CDS651 PSME/ARUV} + 4:{CEF321 ABLA2/LULA} + 5:{CES212 ABLA2/RHAL-OLY} + 6:{CES321 ABLA2/VAME-OLY} + 7:{CES621 ABLA2/JUCO4} + 8:{CFF111 ABAM/OXOR-OLY} + 9:{CFF211 ABAM/ACTR-TIUN} + 10:{CFF311 ABAM/XETE} + 11:{CFF611 ABAM/POMU} + 12:{CFF612 ABAM/POMU-OXOR} + 13:{CFF911 ABAM/Dep.} + 14:{CFS156 ABAM/GASH/OXOR} + 15:{CFS211 ABAM/VAME/XETE-OLY} + 16:{CFS212 ABAM/VAAL-OLY} + 17:{CFS213 ABAM/VAAL/ERMO} + 18:{CFS214 ABAM/VAAL/XETE} + 19:{CFS215 ABAM/VAAL/TIUN} + 20:{CFS217 ABAM/VAAL/OXOR} + 21:{CFS218 ABAM/VAAL/CLUN} + 22:{CFS219 ABAM/VAAL/LIBO2} + 23:{CFS311 ABAM/OPHO-OLY} + 24:{CFS611 ABAM/RHMA-OLY} + 25:{CFS612 ABAM/RHMA-VAAL} + 26:{CHF112 TSHE/OXOR-OLY} + 27:{CHF121 TSHE/OXOR-COAST} + 28:{CHF122 TSHE/POMU-COAST} + 29:{CHF131 TSHE/POMU-OXOR-OLY} + 30:{CHF132 TSHE/POMU-TITR} + 31:{CHF211 TSHE/ACTR-OLY} + 32:{CHF511 TSHE/XETE-OLY} + 33:{CHF911 TSHE/Dep.} + 34:{CHM111 TSHE/LYAM-OLY} + 35:{CHS121 TSHE/BENE-COAST} + 36:{CHS122 TSHE/BENE-GASH-COAST} + 37:{CHS123 TSHE/GASH-COAST} + 38:{CHS131 TSHE/GASH-OLY} + 39:{CHS132 TSHE/GASH/XETE} + 40:{CHS133 TSHE/GASH-VAOV2} + 41:{CHS134 TSHE/GASH-HODI} + 42:{CHS136 TSHE/GASH/OXOR} + 43:{CHS137 TSHE/GASH/POMU} + 44:{CHS138 TSHE/BENE-OLY} + 45:{CHS139 TSHE/BENE/POMU-OLY} + 46:{CHS221 TSHE/ACCI-GASH-COAST} + 47:{CHS222 TSHE/ACCI/POMU-COAST} + 48:{CHS321 TSHE/RHMA-BENE-COAST} + 49:{CHS322 TSHE/RHMA-GASH-COAST} + 50:{CHS323 TSHE/RHMA/POMU-COAST} + 51:{CHS324 TSHE/RHMA/VAOV2-COAST} + 52:{CHS331 TSHE/RHMA-OLY} + 53:{CHS332 TSHE/RHMA/XETE-OLY} + 54:{CHS333 TSHE/RHMA-BENE-OLY} + 55:{CHS334 TSHE/RHMA-GASH-OLY} + 56:{CHS335 TSHE/RHMA/POMU-OLY} + 57:{CHS421 TSHE/RUSP-COAST} + 58:{CHS422 TSHE/RUSP-ACCI-COAST} + 59:{CHS423 TSHE/RUSP-GASH-COAST} + 60:{CHS512 TSHE/OPHO-OLY} + 61:{CHS521 TSHE/OPHO-COAST} + 62:{CHS610 TSHE/VAOV2-COAST} + 63:{CHS621 TSHE/VAAL} + 64:{CHS622 TSHE/VAAL/XETE} + 65:{CHS623 TSHE/VAAL/OXOR-OLY} + 66:{CHS624 TSHE/VAAL-GASH-OLY} + 67:{CMS242 TSME/VAAL/ERMO} + 68:{CSF111 PISI/POMU-OXOR} + 69:{CSF121 PISI/POMU-COAST} + 70:{CSF321 PISI/OXOR-COAST} + 71:{CSS221 PISI/MEFE-VAPA-COAST} + 72:{CSS321 PISI/GASH-COAST} + 73:{CSS521 PISI/RUSP-COAST} + 74:{CSS522 PISI/RUSP-GASH-COAST} + 75:{CSS621 PISI/OPHO-COAST} + +//end HabPa_op + diff --git a/fvsOL/parms/mkpkeys.R b/fvsOL/parms/mkpkeys.R index 3b8aa7b..3c2d46e 100644 --- a/fvsOL/parms/mkpkeys.R +++ b/fvsOL/parms/mkpkeys.R @@ -1,325 +1,325 @@ -# $Id: mkpkeys.R 3335 2020-12-24 20:21:09Z nickcrookston $ - -rdparms <- function(parms) -{ - prms = list() - parms = file.path(parms) - files = dir(parms) - for (fn in files) - { - file = file.path(parms,fn) - cat ("processing file=",file,"\n") - raw = scan(file=file,sep="\n",what="character", - blank.lines.skip = FALSE,quiet=TRUE) - strs = grep("^//start",raw) - if (length(strs)) - { - for (i in 1:length(strs)) - { - p = strs[i] - n = scan(text=raw[p],what="character",quiet=TRUE)[2] - p = p+1 - e = if (i == length(strs)) length(raw) else strs[i+1]-1 - sec = raw[p:e] - e = grep("^//end",sec) - if (!is.na(e)) sec=sec[1:(e-1)] - prms[[n]] = paste(sec,collapse="\n") - } - } - } - prms -} - -mkpkeys = function (mstext) -{ - # maybe this one is already parsed! - if (class(mstext)=="list") return(mstext) - cat("mstext=",names(get("X",envir=parent.frame()))[get("i",envir=parent.frame())],"\n") - pkeys = list() - pkeqs = list() # pkeys that are "equal" other pkeys. - state = 1 - buffer = "" - lineNumber=1 - for (i in 1:nchar(mstext)) - { - thechar = substr(mstext,i,i) - if (thechar == '\n') lineNumber=lineNumber+1 -## if (state!= 15) cat ("state=",state," lineNumber=",lineNumber," thechar=",thechar,"\n") - if (state == 1) - { - # looking for the beginning of a pkey or a - # comment (starts with !, ends with newline) - - if (thechar == " " || thechar == "\t" || thechar == "\n") next - - if(thechar == "!") # we have a comment. - { - state = 15 - } - else - { - state=2 - buffer = paste0(buffer,thechar) - } - next - } - else if (state == 2) # looking for the end of a pkey. - { - # if a printing char but not { : = the char is part of pkey. - - if (thechar != '{' && thechar != '=' && - thechar != ':' && thechar != ' ') - { - buffer = paste0(buffer,thechar) - next - } - - # otherwise, we found the end of the pkey...save the buffer as pkey - # unless it has zero length. - - if (nchar(buffer) == 0) - { - state = 1 - next - } -## cat("end of pkey, buffer=",buffer,"\n") - pkey=buffer - buffer = "" - ns = switch (thechar, - "{" = 4, - ":" = 7, - "=" = 11, - " " = 3, - 99) - - if (ns == 99) - { - cat("Error: expecting { : = and found ", thechar, - " mstext=",mstext," line=",lineNumber," state=",state,"\n") -## stop("error") - state=1 - } else state = ns - next - } - else if (state == 3) # looking for beginning of ATList or Pstring - { - if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; -## cat ("thechar1=",thechar," buffer=",buffer," pkey=",pkey,"\n") - ns = switch (thechar, - "{" = 4, - ":" = 7, - "=" = 11, - 99) - - if (ns == 99) - { - cat("Error: expecting { : = and found ", thechar, - " nearby=",substr(mstext,max(1,i-20),min(i+20,nchar(mstext))), - " line=",lineNumber," state=",state,"\n") -## stop("error") - state=1 - } else state = ns - next - } - else if (state == 4) # looking for the end of the ATList. - { - if (thechar == "\n") next - if (thechar == "\t") thechar=" " - if (thechar != '}') - { - state = 5; - buffer = paste0(buffer,thechar) - } - else if (thechar == '}') # we found the end of the atlist...before is started! - { - atlist = "" - buffer = "" - state = 6 - } - next - } - else if (state == 5) # looking for the end of the ATList. - { - if (thechar == '}') # we found the end of the atlist. - { - attr(pkey,"atlist") = scan (text=buffer,what=" ",quiet=TRUE) - buffer = "" - state = 6; - } - else - { - buffer = paste0(buffer,thechar) - } - next - } - else if (state == 6) # looking for : = - { - if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; - ns = switch (thechar, - ":" = 7, - "=" = 11, - 99) - if (ns == 99) - { - cat("Error: expecting : = and found ", thechar, - " nearby=",substr(mstext,max(1,i-20),min(i+20,nchar(mstext))), - " line=",lineNumber," state=",state,"\n") -## stop("error") - state=1 - } else state = ns - next - } - else if (state == 7) # looking for the beginning of the pstring. - { - if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; - if (thechar == '{') - { - state = 9 - buffer = "" - next - } - else - { - state = 8; - buffer = thechar - } - next - } - else if (state == 8) # looking for the end of the single-token pstring. - { - if (thechar != ' ' && thechar != "\t" && thechar != "\n" && - i != nchar(mstext)) - { - buffer = paste0(buffer,thechar) - } - else - { -## cat ("state=",state," buffer=",buffer,"\n") - attr(pkey,"pstring") = buffer - pkeys[[length(pkeys)+1]] = pkey - buffer="" - state = 1 - } - next - } - else if (state == 9) # looking for the end of the pstring...keep all blanks. - # use the backslash char to escape the following char. - { - if (thechar == "\\") - { - state=10 - } - else if (thechar == '}') # we found the end of the pstring. - { -## cat ("state=",state," buffer=",buffer,"\n") - attr(pkey,"pstring") = buffer - pkeys[[length(pkeys)+1]] = pkey - buffer = "" - state = 1 - } else - { - buffer = paste0(buffer,thechar) - } - next - } - else if (state == 10) # last char was a backslash - { - if (thechar == 'n') # we have a new line requested. - { - buffer = paste0(buffer,'\n') - } - else if (thechar == 't') # we have a horizontal tab requesed. - { - buffer = paste0(buffer,'\t') - } - else if (thechar != '\n') # if the char is not newline, save it. - { - buffer = paste0(buffer,thechar) - } # otherwise it will be skipped. - state=9 - next - } - else if (state == 11) # found equal sign, looking for pkey_r - { - if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; - state=12 - buffer = paste0(buffer,thechar); - next - } - else if (state == 12) # looking for the end of the pkey_r - { -## cat ("state=",state," buffer=",buffer,"\n") - if (thechar == ' ' || thechar == "\t") next - if (thechar == "\n"|| i == nchar(mstext)) - { - pkeqs[[length(pkeqs)+1]] = paste(pkey,buffer) - buffer = "" - state=1 - next - } - else if (thechar == '{') - { - thechar = " " - state = 13 - } - buffer = paste0(buffer,thechar) - next - } - - else if (state == 13) # looking for the end of the atlist for the pkey_r - { -## cat ("state=",state," buffer=",buffer," pkey=",pkey,"\n") - if (thechar == "\n" || thechar == "\t") thechar == " " - if (thechar == '}') - { - pkeqs[[length(pkeqs)+1]] = paste(pkey,buffer) - buffer = "" - state = 1 - } - else - { - buffer = paste0(buffer,thechar); - } - next - } - - else if (state == 15) # looking for the end of a comment. - { - if (thechar == '\n' || i == nchar(mstext)) state = 1 - next - } - } - if (length(pkeqs) > 0) - { - for (pkeq in pkeqs) - { - toks = scan (text=pkeq,what=" ",quiet=TRUE) - pkey = toks[1]; pkr = toks[2] - atl = if (length(toks) > 2) toks[3:length(toks)] else NULL - for (i in 1:length(pkeys)) - { - if (pkr == pkeys[[i]]) - { - if ((is.null(atl) && is.null(attr(pkeys[[i]],"atlist"))) || - length(intersect(atl,attr(pkeys[[i]],"atlist"))) > 0) - { - attributes(pkey) = attributes(pkeys[[i]]) - pkeys[[length(pkeys)+1]] = pkey - break - } - } - } - } - } - pkeys -} - -prms = rdparms("parms") -prms = lapply(prms,mkpkeys) - -save(file="data/prms.RData",prms) - - - - - +# $Id: mkpkeys.R 3335 2020-12-24 20:21:09Z nickcrookston $ + +rdparms <- function(parms) +{ + prms = list() + parms = file.path(parms) + files = dir(parms) + for (fn in files) + { + file = file.path(parms,fn) + cat ("processing file=",file,"\n") + raw = scan(file=file,sep="\n",what="character", + blank.lines.skip = FALSE,quiet=TRUE) + strs = grep("^//start",raw) + if (length(strs)) + { + for (i in 1:length(strs)) + { + p = strs[i] + n = scan(text=raw[p],what="character",quiet=TRUE)[2] + p = p+1 + e = if (i == length(strs)) length(raw) else strs[i+1]-1 + sec = raw[p:e] + e = grep("^//end",sec) + if (!is.na(e)) sec=sec[1:(e-1)] + prms[[n]] = paste(sec,collapse="\n") + } + } + } + prms +} + +mkpkeys = function (mstext) +{ + # maybe this one is already parsed! + if (class(mstext)=="list") return(mstext) + cat("mstext=",names(get("X",envir=parent.frame()))[get("i",envir=parent.frame())],"\n") + pkeys = list() + pkeqs = list() # pkeys that are "equal" other pkeys. + state = 1 + buffer = "" + lineNumber=1 + for (i in 1:nchar(mstext)) + { + thechar = substr(mstext,i,i) + if (thechar == '\n') lineNumber=lineNumber+1 +## if (state!= 15) cat ("state=",state," lineNumber=",lineNumber," thechar=",thechar,"\n") + if (state == 1) + { + # looking for the beginning of a pkey or a + # comment (starts with !, ends with newline) + + if (thechar == " " || thechar == "\t" || thechar == "\n") next + + if(thechar == "!") # we have a comment. + { + state = 15 + } + else + { + state=2 + buffer = paste0(buffer,thechar) + } + next + } + else if (state == 2) # looking for the end of a pkey. + { + # if a printing char but not { : = the char is part of pkey. + + if (thechar != '{' && thechar != '=' && + thechar != ':' && thechar != ' ') + { + buffer = paste0(buffer,thechar) + next + } + + # otherwise, we found the end of the pkey...save the buffer as pkey + # unless it has zero length. + + if (nchar(buffer) == 0) + { + state = 1 + next + } +## cat("end of pkey, buffer=",buffer,"\n") + pkey=buffer + buffer = "" + ns = switch (thechar, + "{" = 4, + ":" = 7, + "=" = 11, + " " = 3, + 99) + + if (ns == 99) + { + cat("Error: expecting { : = and found ", thechar, + " mstext=",mstext," line=",lineNumber," state=",state,"\n") +## stop("error") + state=1 + } else state = ns + next + } + else if (state == 3) # looking for beginning of ATList or Pstring + { + if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; +## cat ("thechar1=",thechar," buffer=",buffer," pkey=",pkey,"\n") + ns = switch (thechar, + "{" = 4, + ":" = 7, + "=" = 11, + 99) + + if (ns == 99) + { + cat("Error: expecting { : = and found ", thechar, + " nearby=",substr(mstext,max(1,i-20),min(i+20,nchar(mstext))), + " line=",lineNumber," state=",state,"\n") +## stop("error") + state=1 + } else state = ns + next + } + else if (state == 4) # looking for the end of the ATList. + { + if (thechar == "\n") next + if (thechar == "\t") thechar=" " + if (thechar != '}') + { + state = 5; + buffer = paste0(buffer,thechar) + } + else if (thechar == '}') # we found the end of the atlist...before is started! + { + atlist = "" + buffer = "" + state = 6 + } + next + } + else if (state == 5) # looking for the end of the ATList. + { + if (thechar == '}') # we found the end of the atlist. + { + attr(pkey,"atlist") = scan (text=buffer,what=" ",quiet=TRUE) + buffer = "" + state = 6; + } + else + { + buffer = paste0(buffer,thechar) + } + next + } + else if (state == 6) # looking for : = + { + if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; + ns = switch (thechar, + ":" = 7, + "=" = 11, + 99) + if (ns == 99) + { + cat("Error: expecting : = and found ", thechar, + " nearby=",substr(mstext,max(1,i-20),min(i+20,nchar(mstext))), + " line=",lineNumber," state=",state,"\n") +## stop("error") + state=1 + } else state = ns + next + } + else if (state == 7) # looking for the beginning of the pstring. + { + if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; + if (thechar == '{') + { + state = 9 + buffer = "" + next + } + else + { + state = 8; + buffer = thechar + } + next + } + else if (state == 8) # looking for the end of the single-token pstring. + { + if (thechar != ' ' && thechar != "\t" && thechar != "\n" && + i != nchar(mstext)) + { + buffer = paste0(buffer,thechar) + } + else + { +## cat ("state=",state," buffer=",buffer,"\n") + attr(pkey,"pstring") = buffer + pkeys[[length(pkeys)+1]] = pkey + buffer="" + state = 1 + } + next + } + else if (state == 9) # looking for the end of the pstring...keep all blanks. + # use the backslash char to escape the following char. + { + if (thechar == "\\") + { + state=10 + } + else if (thechar == '}') # we found the end of the pstring. + { +## cat ("state=",state," buffer=",buffer,"\n") + attr(pkey,"pstring") = buffer + pkeys[[length(pkeys)+1]] = pkey + buffer = "" + state = 1 + } else + { + buffer = paste0(buffer,thechar) + } + next + } + else if (state == 10) # last char was a backslash + { + if (thechar == 'n') # we have a new line requested. + { + buffer = paste0(buffer,'\n') + } + else if (thechar == 't') # we have a horizontal tab requesed. + { + buffer = paste0(buffer,'\t') + } + else if (thechar != '\n') # if the char is not newline, save it. + { + buffer = paste0(buffer,thechar) + } # otherwise it will be skipped. + state=9 + next + } + else if (state == 11) # found equal sign, looking for pkey_r + { + if (thechar == ' ' || thechar == "\t" || thechar == "\n") next; + state=12 + buffer = paste0(buffer,thechar); + next + } + else if (state == 12) # looking for the end of the pkey_r + { +## cat ("state=",state," buffer=",buffer,"\n") + if (thechar == ' ' || thechar == "\t") next + if (thechar == "\n"|| i == nchar(mstext)) + { + pkeqs[[length(pkeqs)+1]] = paste(pkey,buffer) + buffer = "" + state=1 + next + } + else if (thechar == '{') + { + thechar = " " + state = 13 + } + buffer = paste0(buffer,thechar) + next + } + + else if (state == 13) # looking for the end of the atlist for the pkey_r + { +## cat ("state=",state," buffer=",buffer," pkey=",pkey,"\n") + if (thechar == "\n" || thechar == "\t") thechar == " " + if (thechar == '}') + { + pkeqs[[length(pkeqs)+1]] = paste(pkey,buffer) + buffer = "" + state = 1 + } + else + { + buffer = paste0(buffer,thechar); + } + next + } + + else if (state == 15) # looking for the end of a comment. + { + if (thechar == '\n' || i == nchar(mstext)) state = 1 + next + } + } + if (length(pkeqs) > 0) + { + for (pkeq in pkeqs) + { + toks = scan (text=pkeq,what=" ",quiet=TRUE) + pkey = toks[1]; pkr = toks[2] + atl = if (length(toks) > 2) toks[3:length(toks)] else NULL + for (i in 1:length(pkeys)) + { + if (pkr == pkeys[[i]]) + { + if ((is.null(atl) && is.null(attr(pkeys[[i]],"atlist"))) || + length(intersect(atl,attr(pkeys[[i]],"atlist"))) > 0) + { + attributes(pkey) = attributes(pkeys[[i]]) + pkeys[[length(pkeys)+1]] = pkey + break + } + } + } + } + } + pkeys +} + +prms = rdparms("parms") +prms = lapply(prms,mkpkeys) + +save(file="data/prms.RData",prms) + + + + + diff --git a/fvsOL/parms/org.kwd b/fvsOL/parms/org.kwd index 817f158..6b4aac9 100644 --- a/fvsOL/parms/org.kwd +++ b/fvsOL/parms/org.kwd @@ -1,140 +1,140 @@ -//start keyword.organon.INPFile - -description: {Reads-in the ORGANON *.inp text file} - -f1:{fileBrowse Enter the *.inp file name} -f1v:{} - -answerForm:{INPFile -!1!} - -parmsForm = answerForm - -//end keyword.organon.INPFile - -//start keyword.organon.ORGInfo - -description: {Sets the ORGANON specific parameters -} - -f1:{listButton Select ORGANON Version:} -f1v{oc}:{\ -1 = Southwest Oregon (SWO)} -f1v{op}:{\ -2 = Northwest Oregon (NWO) -3 = Stand Management Co-op (SMC)} - -f2title: -{If stand is even-aged, make sure to specify age in input} -f2:{longListButton IS stand even-age:} -f2v:{\ ->0 = No -1 = Yes} - -f3title: -{If using SDIMAX specify value in input data} -f3:{longListButton Use SDIMAX to determine mortality:} -f3v:{\ -0 = No ->1 = Yes} - -f4:{longListButton Include ORGANON height calibration:} -f4v:{\ -0 = No ->1 = Yes} - -f5:{longListButton Include ORGANON height-to-crown base calibration:} -f5v:{\ -0 = No ->1 = Yes} - -f6:{longListButton Include ORGANON diamater growth calibration:} -f6v:{\ -0 = No ->1 = Yes} - -answerForm{oc}:{ORGInfo !1,10,version!!2,10!!3,10!!4,10!!5,10!!6,10!} -version:{1} -parmsForm{oc} = answerForm{oc} - -answerForm{op}:{ORGInfo !1,10,versions!!2,10!!3,10!!4,10!!5,10!!6,10!} -versions:{2 3} -parmsForm{op} = answerForm{op} - -//end keyword.organon.ORGInfo - -//start keyword.organon.ORGVols - -description: {Changes the volume equation method. -NOTE: For BLM specific volume equations this keyword is not needed as long as you -specify the BLM location code in the input data, FVS will automatically select -the BLM volume equations from the National Volume Estimator library for the specified RA.} - -f1:{longListButton Select Volume Equations} -f1v:{\ ->0 = use FVS volume equations (NVEL) based on location -1 = use ORGANON OSU developed volume equations} - -parmsForm = answerForm - -//end keyword.organon.ORGVols - -//start keyword.organon.OSUBFVOL - -description: {This keyword is used to change the merchanibility limits for the -ORGANON OSU board foot volume equations} - -f1:{numberBox Board foot top DIB (inches). Minimum 2.0} -f1v:{6.0} - -f2:{numberBox Board foot log trim allowance (inches).} -f2v:{8.0} - -f3:{numberBox Board foot stump height, less than 4.5 feet} -f3v:{0.5} - -f4:{numberBox Target log Length (feet)} -f4v:{32.0} - -f5:{numberBox Minimum log length (feet).} -f5v:{8.0} - -answerForm:{OSUBFVOL !1,10!!2,10!!3,10!!4,10!!5,10!} - -parmsForm = answerForm - -//end keyword.organon.OSUBFVOL - -//start keyword.organon.OSUCFVOL - -description: {This keyword is used to change the merchanibility limits for the -ORGANON OSU cubic foot volume equations} - -f1:{numberBox Softwood cubic foot top DIB (inches). 0.0==6.0} -f1v:{0.0} - -f2:{numberBox Softwood cubic foot stump height, less than 4.5 feet} -f2v:{0.0} - -f3:{numberBox Hardwood cubic foot top DIB (inches).} -f3v:{0.0} - - -answerForm:{OSUCFVOL !1,10!!2,10!!3,10!} - -parmsForm = answerForm - -//end keyword.organon.OSUCFVOL - -//start keyword.organon.ORGOFF - -description: {Switches off the ORGANON growth and mortality component, and -runs the model using only the FVS equations.} - - -answerForm:{ORGOFF} - -parmsForm = answerForm - -//end keyword.organon.ORGOFF - +//start keyword.organon.INPFile + +description: {Reads-in the ORGANON *.inp text file} + +f1:{fileBrowse Enter the *.inp file name} +f1v:{} + +answerForm:{INPFile +!1!} + +parmsForm = answerForm + +//end keyword.organon.INPFile + +//start keyword.organon.ORGInfo + +description: {Sets the ORGANON specific parameters +} + +f1:{listButton Select ORGANON Version:} +f1v{oc}:{\ +1 = Southwest Oregon (SWO)} +f1v{op}:{\ +2 = Northwest Oregon (NWO) +3 = Stand Management Co-op (SMC)} + +f2title: +{If stand is even-aged, make sure to specify age in input} +f2:{longListButton IS stand even-age:} +f2v:{\ +>0 = No +1 = Yes} + +f3title: +{If using SDIMAX specify value in input data} +f3:{longListButton Use SDIMAX to determine mortality:} +f3v:{\ +0 = No +>1 = Yes} + +f4:{longListButton Include ORGANON height calibration:} +f4v:{\ +0 = No +>1 = Yes} + +f5:{longListButton Include ORGANON height-to-crown base calibration:} +f5v:{\ +0 = No +>1 = Yes} + +f6:{longListButton Include ORGANON diamater growth calibration:} +f6v:{\ +0 = No +>1 = Yes} + +answerForm{oc}:{ORGInfo !1,10,version!!2,10!!3,10!!4,10!!5,10!!6,10!} +version:{1} +parmsForm{oc} = answerForm{oc} + +answerForm{op}:{ORGInfo !1,10,versions!!2,10!!3,10!!4,10!!5,10!!6,10!} +versions:{2 3} +parmsForm{op} = answerForm{op} + +//end keyword.organon.ORGInfo + +//start keyword.organon.ORGVols + +description: {Changes the volume equation method. +NOTE: For BLM specific volume equations this keyword is not needed as long as you +specify the BLM location code in the input data, FVS will automatically select +the BLM volume equations from the National Volume Estimator library for the specified RA.} + +f1:{longListButton Select Volume Equations} +f1v:{\ +>0 = use FVS volume equations (NVEL) based on location +1 = use ORGANON OSU developed volume equations} + +parmsForm = answerForm + +//end keyword.organon.ORGVols + +//start keyword.organon.OSUBFVOL + +description: {This keyword is used to change the merchanibility limits for the +ORGANON OSU board foot volume equations} + +f1:{numberBox Board foot top DIB (inches). Minimum 2.0} +f1v:{6.0} + +f2:{numberBox Board foot log trim allowance (inches).} +f2v:{8.0} + +f3:{numberBox Board foot stump height, less than 4.5 feet} +f3v:{0.5} + +f4:{numberBox Target log Length (feet)} +f4v:{32.0} + +f5:{numberBox Minimum log length (feet).} +f5v:{8.0} + +answerForm:{OSUBFVOL !1,10!!2,10!!3,10!!4,10!!5,10!} + +parmsForm = answerForm + +//end keyword.organon.OSUBFVOL + +//start keyword.organon.OSUCFVOL + +description: {This keyword is used to change the merchanibility limits for the +ORGANON OSU cubic foot volume equations} + +f1:{numberBox Softwood cubic foot top DIB (inches). 0.0==6.0} +f1v:{0.0} + +f2:{numberBox Softwood cubic foot stump height, less than 4.5 feet} +f2v:{0.0} + +f3:{numberBox Hardwood cubic foot top DIB (inches).} +f3v:{0.0} + + +answerForm:{OSUCFVOL !1,10!!2,10!!3,10!} + +parmsForm = answerForm + +//end keyword.organon.OSUCFVOL + +//start keyword.organon.ORGOFF + +description: {Switches off the ORGANON growth and mortality component, and +runs the model using only the FVS equations.} + + +answerForm:{ORGOFF} + +parmsForm = answerForm + +//end keyword.organon.ORGOFF + diff --git a/rFVS/DESCRIPTION b/rFVS/DESCRIPTION index 7ce7c12..0a0f855 100644 --- a/rFVS/DESCRIPTION +++ b/rFVS/DESCRIPTION @@ -8,4 +8,4 @@ Description: Provides a set of R functions that interface with the Depends: R (>= 4.0.0) License: MIT Roxygen: list(markdown = TRUE) -RoxygenNote: 7.2.1 +RoxygenNote: 7.2.3 diff --git a/rFVS/R/fvsAddActivity.R b/rFVS/R/fvsAddActivity.R index 007a572..3a998e9 100644 --- a/rFVS/R/fvsAddActivity.R +++ b/rFVS/R/fvsAddActivity.R @@ -1,84 +1,84 @@ -#' Add an an FVS Activity to the activity schedule -#' -#' Pass in an activity code and parameters to the FVS activity schedule. A list of -#' possible activity codes is returned if no arguments are passed. -#' -#' @param year year the activity is to be scheduled -#' @param activity activity code as a number or character string -#' @param parms a numeric vector of parameters for the activity -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsAddActivity() # a list of all possible activities is return -#' fvsAddActivity(1993,"base_yardloss",c(0.50, 0.70, 0.50)) -#' fvsAddActivity(1993,"base_thindbh",c(0.00,12.00,1.00,0.00,0.00)) -#' @return invisable return code with the value 0 if the activity was added and 1 if there was some error -#' or, in the case where no arguments are specified, a named vector of possible activity codes. -#' @export - -fvsAddActivity <- -function(year,activity,parms=NULL) -{ - activities <- c(BASE_TREELIST= 80,BASE_CRNMULT = 81, - BASE_MANAGED = 82,BASE_FIXCW = 90,BASE_BAIMULT = 91,BASE_HTGMULT = 92, - BASE_REGHMULT= 93,BASE_MORTMULT= 94,ESTB_SPECMULT= 95,BASE_REGDMULT= 96, - BASE_FIXMORT = 97,BASE_FIXDG = 98,BASE_FIXHTG = 99,BASE_SYSTEM = 100, - DBIN_SQLIN = 101,DBIN_SQLOUT = 102,BASE_HTGSTOP = 110,BASE_TOPKILL = 111, - BASE_SETSITE = 120,BASE_ATRTLIST= 198,BASE_CUTLIST = 199,BASE_MINHARV = 200, - BASE_SPECPREF= 201,BASE_TCONDMLT= 202,BASE_YARDLOSS= 203,BASE_FVSSTAND= 204, - BASE_CRUZFILE= 205,BASE_MCDEFECT= 215,BASE_BFDEFECT= 216,BASE_VOLUME = 217, - BASE_BFVOLUME= 218,BASE_THINAUTO= 222,BASE_THINBTA = 223,BASE_THINATA = 224, - BASE_THINBBA = 225,BASE_THINABA = 226,BASE_THINPRSC= 227,BASE_THINDBH = 228, - BASE_SALVAGE = 229,BASE_THINSDI = 230,BASE_THINCC = 231,BASE_THINHT = 232, - BASE_THINMIST= 233,BASE_THINRDEN= 234,BASE_THINPT = 235,BASE_THINRDSL= 236, - BASE_SETPTHIN= 248,BASE_PRUNE = 249,BASE_COMPRESS= 250,BASE_FERTILIZ= 260, - ESTB_TALLY = 427,ESTB_TALLYONE= 428,ESTB_TALLYTWO= 429,ESTB_PLANT = 430, - ESTB_NATURAL = 431,ESTB_ADDTREES= 432,ESTB_STOCKADJ= 440,ESTB_HTADJ = 442, - BASE_RESETAGE= 443,ESTB_SPROUT = 450,ESTB_NATURAL = 490,ESTB_BURNPREP= 491, - ESTB_MECHPREP= 493,COVR_COVER = 900,MIST_MISTMULT=2001,MIST_MISTPREF=2002, - MIST_MISTMORT=2003,MIST_MISTHMOD=2004,MIST_MISTGMOD=2005,MIST_MISTPINF=2006, - MIST_MISTABLE=2007,FIRE_SALVSP =2501,FIRE_SOILHEAT=2503,FIRE_BURNREPT=2504, - FIRE_MOISTURE=2505,FIRE_SIMFIRE =2506,FIRE_FLAMEADJ=2507,FIRE_POTFIRE =2508, - FIRE_SNAGOUT =2512,FIRE_FUELOUT =2515,FIRE_SALVAGE =2520,FIRE_FUELINIT=2521, - FIRE_SNAGINIT=2522,FIRE_PILEBURN=2523,FIRE_FUELTRET=2525,FIRE_FUELREPT=2527, - FIRE_MORTREPT=2528,FIRE_DROUGHT =2529,FIRE_FUELMOVE=2530,FIRE_FUELMODL=2538, - FIRE_DEFULMOD=2539,FIRE_CARBREPT=2544,FIRE_CARBCUT =2545,FIRE_CANFPROF=2547, - FIRE_FUELFOTO=2548,FIRE_FIRECALC=2549,FIRE_FMODLIST=2550,FIRE_DWDVLOUT=2551, - FIRE_DWDCVOUT=2552,FIRE_FUELSOFT=2553,ECON_PRETEND =2605,ECON_SEVSTART=2606, - ECON_SPECCST =2607,ECON_SPECRVN =2608,ECON_STRTECON=2609) - - if (missing(year) & missing(activity)) return (activities) - - if (missing(year)) stop ("year must be specified.") - if (missing(activity)) stop ("activity must be specified.") - if (class(activity) == "character") - { - item=grep (activity,names(activities),ignore.case=TRUE) - if (length(item) > 1) stop(activity," is matching: ", - paste(names(activities)[item],collapse=", ")) - iactk = if (length(item) > 0) as.integer(activities[item]) else NA - if (is.na(iactk)) stop(activity," could not be translated to a code.") - } - else - { - iactk = as.integer(activity) - } - if (is.null(parms)) - { - inprms = as.numeric(0) - nprms = as.integer(0) - } - else - { - if (any(is.na(parms))) stop ("parms can not contain NAs") - inprms = as.numeric(parms) - nprms = length(parms) - } - if (is.na(year)) stop ("year may not be an NA") - year = as.integer(year) - rtnCode = as.integer(0) - rtn = .Fortran("fvsAddActivity",year,iactk,inprms,nprms,rtnCode, - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - invisible(rtn[[5]]) -} - +#' Add an an FVS Activity to the activity schedule +#' +#' Pass in an activity code and parameters to the FVS activity schedule. A list of +#' possible activity codes is returned if no arguments are passed. +#' +#' @param year year the activity is to be scheduled +#' @param activity activity code as a number or character string +#' @param parms a numeric vector of parameters for the activity +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsAddActivity() # a list of all possible activities is return +#' fvsAddActivity(1993,"base_yardloss",c(0.50, 0.70, 0.50)) +#' fvsAddActivity(1993,"base_thindbh",c(0.00,12.00,1.00,0.00,0.00)) +#' @return invisable return code with the value 0 if the activity was added and 1 if there was some error +#' or, in the case where no arguments are specified, a named vector of possible activity codes. +#' @export + +fvsAddActivity <- +function(year,activity,parms=NULL) +{ + activities <- c(BASE_TREELIST= 80,BASE_CRNMULT = 81, + BASE_MANAGED = 82,BASE_FIXCW = 90,BASE_BAIMULT = 91,BASE_HTGMULT = 92, + BASE_REGHMULT= 93,BASE_MORTMULT= 94,ESTB_SPECMULT= 95,BASE_REGDMULT= 96, + BASE_FIXMORT = 97,BASE_FIXDG = 98,BASE_FIXHTG = 99,BASE_SYSTEM = 100, + DBIN_SQLIN = 101,DBIN_SQLOUT = 102,BASE_HTGSTOP = 110,BASE_TOPKILL = 111, + BASE_SETSITE = 120,BASE_ATRTLIST= 198,BASE_CUTLIST = 199,BASE_MINHARV = 200, + BASE_SPECPREF= 201,BASE_TCONDMLT= 202,BASE_YARDLOSS= 203,BASE_FVSSTAND= 204, + BASE_CRUZFILE= 205,BASE_MCDEFECT= 215,BASE_BFDEFECT= 216,BASE_VOLUME = 217, + BASE_BFVOLUME= 218,BASE_THINAUTO= 222,BASE_THINBTA = 223,BASE_THINATA = 224, + BASE_THINBBA = 225,BASE_THINABA = 226,BASE_THINPRSC= 227,BASE_THINDBH = 228, + BASE_SALVAGE = 229,BASE_THINSDI = 230,BASE_THINCC = 231,BASE_THINHT = 232, + BASE_THINMIST= 233,BASE_THINRDEN= 234,BASE_THINPT = 235,BASE_THINRDSL= 236, + BASE_SETPTHIN= 248,BASE_PRUNE = 249,BASE_COMPRESS= 250,BASE_FERTILIZ= 260, + ESTB_TALLY = 427,ESTB_TALLYONE= 428,ESTB_TALLYTWO= 429,ESTB_PLANT = 430, + ESTB_NATURAL = 431,ESTB_ADDTREES= 432,ESTB_STOCKADJ= 440,ESTB_HTADJ = 442, + BASE_RESETAGE= 443,ESTB_SPROUT = 450,ESTB_NATURAL = 490,ESTB_BURNPREP= 491, + ESTB_MECHPREP= 493,COVR_COVER = 900,MIST_MISTMULT=2001,MIST_MISTPREF=2002, + MIST_MISTMORT=2003,MIST_MISTHMOD=2004,MIST_MISTGMOD=2005,MIST_MISTPINF=2006, + MIST_MISTABLE=2007,FIRE_SALVSP =2501,FIRE_SOILHEAT=2503,FIRE_BURNREPT=2504, + FIRE_MOISTURE=2505,FIRE_SIMFIRE =2506,FIRE_FLAMEADJ=2507,FIRE_POTFIRE =2508, + FIRE_SNAGOUT =2512,FIRE_FUELOUT =2515,FIRE_SALVAGE =2520,FIRE_FUELINIT=2521, + FIRE_SNAGINIT=2522,FIRE_PILEBURN=2523,FIRE_FUELTRET=2525,FIRE_FUELREPT=2527, + FIRE_MORTREPT=2528,FIRE_DROUGHT =2529,FIRE_FUELMOVE=2530,FIRE_FUELMODL=2538, + FIRE_DEFULMOD=2539,FIRE_CARBREPT=2544,FIRE_CARBCUT =2545,FIRE_CANFPROF=2547, + FIRE_FUELFOTO=2548,FIRE_FIRECALC=2549,FIRE_FMODLIST=2550,FIRE_DWDVLOUT=2551, + FIRE_DWDCVOUT=2552,FIRE_FUELSOFT=2553,ECON_PRETEND =2605,ECON_SEVSTART=2606, + ECON_SPECCST =2607,ECON_SPECRVN =2608,ECON_STRTECON=2609) + + if (missing(year) & missing(activity)) return (activities) + + if (missing(year)) stop ("year must be specified.") + if (missing(activity)) stop ("activity must be specified.") + if (class(activity) == "character") + { + item=grep (activity,names(activities),ignore.case=TRUE) + if (length(item) > 1) stop(activity," is matching: ", + paste(names(activities)[item],collapse=", ")) + iactk = if (length(item) > 0) as.integer(activities[item]) else NA + if (is.na(iactk)) stop(activity," could not be translated to a code.") + } + else + { + iactk = as.integer(activity) + } + if (is.null(parms)) + { + inprms = as.numeric(0) + nprms = as.integer(0) + } + else + { + if (any(is.na(parms))) stop ("parms can not contain NAs") + inprms = as.numeric(parms) + nprms = length(parms) + } + if (is.na(year)) stop ("year may not be an NA") + year = as.integer(year) + rtnCode = as.integer(0) + rtn = .Fortran("fvsAddActivity",year,iactk,inprms,nprms,rtnCode, + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + invisible(rtn[[5]]) +} + diff --git a/rFVS/R/fvsAddTrees.R b/rFVS/R/fvsAddTrees.R index da9e70d..8e13271 100755 --- a/rFVS/R/fvsAddTrees.R +++ b/rFVS/R/fvsAddTrees.R @@ -1,44 +1,44 @@ -#' Add new tree records to the simulation -#' -#' Pass a data frame of new trees. This function should be called -#' only at FVS stop point 6 or 7 (see \link{fvsRun}). -#' -#' @param newtrees a data.frame of new trees with the following required columns: -#' dbh (inches),species (FVS species index (integer), use \link{fvsGetSpeciesCodes} -#' to list permitted codes), ht (ft), cratio (percent), plot (index), -#' tpa (trees/acre). No missing values allowed. -#' @return invisable return code with the value 0 if the trees were added and -#' 1 if there was some error. -#' @export -fvsAddTrees <- -function(newtrees) -{ - if (missing(newtrees)) stop ("newtrees must be specified.") - cns <- colnames(newtrees) - if (is.null(cns)) stop ("newtrees must have colnames.") - req <- c("dbh","species","ht","cratio","plot","tpa") - locrec <- match(req,cns) - if (any(is.na(locrec))) stop (paste ("absent attributes=", - paste(req[is.na(locrec)],collapse=", "))) - if (any(is.na(newtrees))) stop ("no missing values allowed") - room <- fvsGetDims() - mxsp <- room["maxspecies"] - plts <- room["nplots"] - room <- room["maxtrees"] - room["ntrees"] - ntrees <- as.integer(nrow(newtrees)) - if (ntrees > room) stop (paste("room for",room,"and newtrees has",ntrees,"trees")) - in_dbh <- as.numeric(newtrees[,locrec[1]]) - in_species <- as.numeric(newtrees[,locrec[2]]) - if (any(in_species == 0)) stop("species codes must be > 0") - if (any(in_species > mxsp)) stop ("some (all) species codes must be within range for this FVS.") - in_ht <- as.numeric(newtrees[,locrec[3]]) - in_cratio <- as.numeric(newtrees[,locrec[4]]) - in_plot <- as.numeric(newtrees[,locrec[5]]) - if (any(in_plot == 0)) stop("plot codes must be > 0") - if (any(in_plot > plts)) stop ("plot codes must be within range for this run.") - in_tpa <- as.numeric(newtrees[,locrec[6]]) - rtn <- .Fortran("fvsAddTrees",in_dbh,in_species,in_ht,in_cratio, - in_plot,in_tpa,ntrees,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - invisible(rtn[[8]]) -} +#' Add new tree records to the simulation +#' +#' Pass a data frame of new trees. This function should be called +#' only at FVS stop point 6 or 7 (see \link{fvsRun}). +#' +#' @param newtrees a data.frame of new trees with the following required columns: +#' dbh (inches),species (FVS species index (integer), use \link{fvsGetSpeciesCodes} +#' to list permitted codes), ht (ft), cratio (percent), plot (index), +#' tpa (trees/acre). No missing values allowed. +#' @return invisable return code with the value 0 if the trees were added and +#' 1 if there was some error. +#' @export +fvsAddTrees <- +function(newtrees) +{ + if (missing(newtrees)) stop ("newtrees must be specified.") + cns <- colnames(newtrees) + if (is.null(cns)) stop ("newtrees must have colnames.") + req <- c("dbh","species","ht","cratio","plot","tpa") + locrec <- match(req,cns) + if (any(is.na(locrec))) stop (paste ("absent attributes=", + paste(req[is.na(locrec)],collapse=", "))) + if (any(is.na(newtrees))) stop ("no missing values allowed") + room <- fvsGetDims() + mxsp <- room["maxspecies"] + plts <- room["nplots"] + room <- room["maxtrees"] - room["ntrees"] + ntrees <- as.integer(nrow(newtrees)) + if (ntrees > room) stop (paste("room for",room,"and newtrees has",ntrees,"trees")) + in_dbh <- as.numeric(newtrees[,locrec[1]]) + in_species <- as.numeric(newtrees[,locrec[2]]) + if (any(in_species == 0)) stop("species codes must be > 0") + if (any(in_species > mxsp)) stop ("some (all) species codes must be within range for this FVS.") + in_ht <- as.numeric(newtrees[,locrec[3]]) + in_cratio <- as.numeric(newtrees[,locrec[4]]) + in_plot <- as.numeric(newtrees[,locrec[5]]) + if (any(in_plot == 0)) stop("plot codes must be > 0") + if (any(in_plot > plts)) stop ("plot codes must be within range for this run.") + in_tpa <- as.numeric(newtrees[,locrec[6]]) + rtn <- .Fortran("fvsAddTrees",in_dbh,in_species,in_ht,in_cratio, + in_plot,in_tpa,ntrees,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + invisible(rtn[[8]]) +} diff --git a/rFVS/R/fvsCompositeSum.R b/rFVS/R/fvsCompositeSum.R index 2678200..84f6993 100644 --- a/rFVS/R/fvsCompositeSum.R +++ b/rFVS/R/fvsCompositeSum.R @@ -1,106 +1,106 @@ -#' Build a composite summary statistics table -#' -#' A list of summary statistics tables are summarized into a composite (a -#' weighted average of values) for years that are common to all individual tables. -#' -#' @param allsum a list of summary tables -#' @return the composite table -#' @export -fvsCompositeSum <- -function(allsum) -{ - if (class(allsum) != "list") stop("allsum must be a list.") - if (length(allsum) == 0) return (NULL) - - yrs=allsum[[1]][,"Year"] - for (x in allsum) yrs = intersect(x[,"Year"],yrs) - - if (is.null(yrs) | length(yrs) < 1) stop("no common years.") - - mxyr=max(yrs) - warn=FALSE - comp = NULL; sumwt = 0 - fty = NULL - for (i in 1:length(allsum)) - { - one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs) - fty = if (is.null(fty)) one[,c(1,17:20)] else rbind(fty,one[,c(1,17:20)]) - - # check for removals outside of common years - if (! warn) - { - rmv = allsum[[i]][,c(1,7)] - noncom=setdiff(rmv[,1],yrs) - if (length(noncom) > 0) - { - rmv = subset(rmv,rmv[,1] %in% noncom) - rmv = subset(rmv, rmv[,"Year"] <= mxyr) - if (nrow(rmv) > 0) - { - if (sum(rmv[,2]) > 0) - { - warn=TRUE - warning (paste("Composite removals do not", - "include removals in cycle years that are not", - "common to all summary tables.")) - }}}} - - sum1 = apply(one[,1:16],2,function (x,one) x*one[,17], one) - if (is.null(comp)) - { - sumwt = one[,17] - comp = sum1 - } else - { - sumwt = sumwt + one[,17] - comp = comp + sum1 - } - } - ans = apply(comp,2,function (x,sumwt) x/sumwt, sumwt) - ans = cbind(ans,SampWt=sumwt) - - fts=as.character(unique(sort(fty[,3]))) - ForType = matrix(0,nrow=length(yrs),ncol=length(fts)) - colnames(ForType)=fts - rownames(ForType)=yrs - for (i in 1:length(allsum)) - { - one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,18)] - for (n in fts) - { - add = n == one[,2] - ForType[add,n] = ForType[add,n]+one[add,1] - } - } - - fts=as.character(unique(sort(fty[,4]))) - SizeCls = matrix(0,nrow=length(yrs),ncol=length(fts)) - colnames(SizeCls)=fts - rownames(SizeCls)=yrs - for (i in 1:length(allsum)) - { - one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,19)] - for (n in fts) - { - add = n == one[,2] - SizeCls[add,n] = SizeCls[add,n]+one[add,1] - } - } - - fts=as.character(unique(sort(fty[,5]))) - StkCls = matrix(0,nrow=length(yrs),ncol=length(fts)) - colnames(StkCls)=fts - rownames(StkCls)=yrs - for (i in 1:length(allsum)) - { - one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,20)] - for (n in fts) - { - add = n == one[,2] - StkCls[add,n] = StkCls[add,n]+one[add,1] - } - } - ans=list(sumTable=ans,ForType=ForType,SizeCls=SizeCls,StkCls=StkCls) - ans -} - +#' Build a composite summary statistics table +#' +#' A list of summary statistics tables are summarized into a composite (a +#' weighted average of values) for years that are common to all individual tables. +#' +#' @param allsum a list of summary tables +#' @return the composite table +#' @export +fvsCompositeSum <- +function(allsum) +{ + if (class(allsum) != "list") stop("allsum must be a list.") + if (length(allsum) == 0) return (NULL) + + yrs=allsum[[1]][,"Year"] + for (x in allsum) yrs = intersect(x[,"Year"],yrs) + + if (is.null(yrs) | length(yrs) < 1) stop("no common years.") + + mxyr=max(yrs) + warn=FALSE + comp = NULL; sumwt = 0 + fty = NULL + for (i in 1:length(allsum)) + { + one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs) + fty = if (is.null(fty)) one[,c(1,17:20)] else rbind(fty,one[,c(1,17:20)]) + + # check for removals outside of common years + if (! warn) + { + rmv = allsum[[i]][,c(1,7)] + noncom=setdiff(rmv[,1],yrs) + if (length(noncom) > 0) + { + rmv = subset(rmv,rmv[,1] %in% noncom) + rmv = subset(rmv, rmv[,"Year"] <= mxyr) + if (nrow(rmv) > 0) + { + if (sum(rmv[,2]) > 0) + { + warn=TRUE + warning (paste("Composite removals do not", + "include removals in cycle years that are not", + "common to all summary tables.")) + }}}} + + sum1 = apply(one[,1:16],2,function (x,one) x*one[,17], one) + if (is.null(comp)) + { + sumwt = one[,17] + comp = sum1 + } else + { + sumwt = sumwt + one[,17] + comp = comp + sum1 + } + } + ans = apply(comp,2,function (x,sumwt) x/sumwt, sumwt) + ans = cbind(ans,SampWt=sumwt) + + fts=as.character(unique(sort(fty[,3]))) + ForType = matrix(0,nrow=length(yrs),ncol=length(fts)) + colnames(ForType)=fts + rownames(ForType)=yrs + for (i in 1:length(allsum)) + { + one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,18)] + for (n in fts) + { + add = n == one[,2] + ForType[add,n] = ForType[add,n]+one[add,1] + } + } + + fts=as.character(unique(sort(fty[,4]))) + SizeCls = matrix(0,nrow=length(yrs),ncol=length(fts)) + colnames(SizeCls)=fts + rownames(SizeCls)=yrs + for (i in 1:length(allsum)) + { + one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,19)] + for (n in fts) + { + add = n == one[,2] + SizeCls[add,n] = SizeCls[add,n]+one[add,1] + } + } + + fts=as.character(unique(sort(fty[,5]))) + StkCls = matrix(0,nrow=length(yrs),ncol=length(fts)) + colnames(StkCls)=fts + rownames(StkCls)=yrs + for (i in 1:length(allsum)) + { + one = subset (allsum[[i]],allsum[[i]][,"Year"] %in% yrs)[,c(17,20)] + for (n in fts) + { + add = n == one[,2] + StkCls[add,n] = StkCls[add,n]+one[add,1] + } + } + ans=list(sumTable=ans,ForType=ForType,SizeCls=SizeCls,StkCls=StkCls) + ans +} + diff --git a/rFVS/R/fvsGetDims.R b/rFVS/R/fvsGetDims.R index b38b88f..76bc3d0 100755 --- a/rFVS/R/fvsGetDims.R +++ b/rFVS/R/fvsGetDims.R @@ -1,19 +1,19 @@ -#' Return the max dimensions of important FVS data storage. -#' -#' @return a named numeric vector. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetDims() -#' @export -fvsGetDims <- -function() -{ - fvsDims = unlist(.Fortran("fvsDimSizes",as.integer(0),as.integer(0), - as.integer(0),as.integer(0),as.integer(0),as.integer(0),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)) - names(fvsDims)=c("ntrees","ncycles","nplots","maxtrees","maxspecies", - "maxplots","maxcycles") - fvsDims -} - +#' Return the max dimensions of important FVS data storage. +#' +#' @return a named numeric vector. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetDims() +#' @export +fvsGetDims <- +function() +{ + fvsDims = unlist(.Fortran("fvsDimSizes",as.integer(0),as.integer(0), + as.integer(0),as.integer(0),as.integer(0),as.integer(0),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)) + names(fvsDims)=c("ntrees","ncycles","nplots","maxtrees","maxspecies", + "maxplots","maxcycles") + fvsDims +} + diff --git a/rFVS/R/fvsGetEventMonitorVariables.R b/rFVS/R/fvsGetEventMonitorVariables.R index 85faf50..9f51ca2 100644 --- a/rFVS/R/fvsGetEventMonitorVariables.R +++ b/rFVS/R/fvsGetEventMonitorVariables.R @@ -1,61 +1,61 @@ -#' Get Event Monitor Variables -#' -#' @param vars a character vector of Event Monitor names. Consult FVS documentation -#' for the possible variable names. -#' @return a named numeric vector of the variables, NA if the variable name does not exist -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetEventMonitorVariables(c("year","atpa","aba","mybba","myaba")) -#' fvsSetEventMonitorVariables(c("myaba"=100,"another"=40)) -#' fvsGetEventMonitorVariables(c("myaba","another")) -#' @export -fvsGetEventMonitorVariables <- -function(vars) -{ - if (missing(vars)) stop ("vars must be present") - if (class(vars) != "character") stop ("vars must be type character") - atr = vector("numeric",length(vars)) - all = NULL - for (name in vars) - { - nch = as.integer(nchar(name)) - ans = .C("CfvsEvmonAttr",tolower(name),nch,"get",as.double(0),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - all = c(all,if (ans[[5]] == 0) ans[[4]] else NA) - } - names(all) = vars - all -} - -#' Set Event Monitor Variables -#' -#' @param vars a named numeric vector of the variables and corresponding values. -#' @return a named numeric vector of the variables, NA if the variable name does not exit -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetEventMonitorVariables(c("year","atpa","aba","mybba","myaba")) -#' fvsSetEventMonitorVariables(c("myaba"=100,"another"=40)) -#' fvsGetEventMonitorVariables(c("myaba","another")) -#' @export -fvsSetEventMonitorVariables <- -function(vars) -{ - if (missing(vars)) stop ("vars must be present") - if (class(vars) != "numeric") stop ("vars must be type numeric") - if (is.null(names(vars))) stop ("vars must be named") - atr = vector("numeric",length(vars)) - all = NULL - for (name in names(vars)) - { - nch = as.integer(nchar(name)) - ans = .C("CfvsEvmonAttr",tolower(name),nch,"set", - as.double(vars[name]),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - all = c(all,if (ans[[5]] == 0) ans[[4]] else NA) - } - names(all) = names(vars) - all -} - +#' Get Event Monitor Variables +#' +#' @param vars a character vector of Event Monitor names. Consult FVS documentation +#' for the possible variable names. +#' @return a named numeric vector of the variables, NA if the variable name does not exist +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetEventMonitorVariables(c("year","atpa","aba","mybba","myaba")) +#' fvsSetEventMonitorVariables(c("myaba"=100,"another"=40)) +#' fvsGetEventMonitorVariables(c("myaba","another")) +#' @export +fvsGetEventMonitorVariables <- +function(vars) +{ + if (missing(vars)) stop ("vars must be present") + if (class(vars) != "character") stop ("vars must be type character") + atr = vector("numeric",length(vars)) + all = NULL + for (name in vars) + { + nch = as.integer(nchar(name)) + ans = .C("CfvsEvmonAttr",tolower(name),nch,"get",as.double(0),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + all = c(all,if (ans[[5]] == 0) ans[[4]] else NA) + } + names(all) = vars + all +} + +#' Set Event Monitor Variables +#' +#' @param vars a named numeric vector of the variables and corresponding values. +#' @return a named numeric vector of the variables, NA if the variable name does not exit +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetEventMonitorVariables(c("year","atpa","aba","mybba","myaba")) +#' fvsSetEventMonitorVariables(c("myaba"=100,"another"=40)) +#' fvsGetEventMonitorVariables(c("myaba","another")) +#' @export +fvsSetEventMonitorVariables <- +function(vars) +{ + if (missing(vars)) stop ("vars must be present") + if (class(vars) != "numeric") stop ("vars must be type numeric") + if (is.null(names(vars))) stop ("vars must be named") + atr = vector("numeric",length(vars)) + all = NULL + for (name in names(vars)) + { + nch = as.integer(nchar(name)) + ans = .C("CfvsEvmonAttr",tolower(name),nch,"set", + as.double(vars[name]),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + all = c(all,if (ans[[5]] == 0) ans[[4]] else NA) + } + names(all) = names(vars) + all +} + diff --git a/rFVS/R/fvsGetRestartcode.R b/rFVS/R/fvsGetRestartcode.R index ec1b4ba..af7ac3d 100644 --- a/rFVS/R/fvsGetRestartcode.R +++ b/rFVS/R/fvsGetRestartcode.R @@ -1,17 +1,17 @@ -#' Get the current FVS restart code. See \link{fvsRun} for a list of the -#' stop codes -#' -#' @return an integer -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetRestartcode() -#' @export -fvsGetRestartcode <- -function() -{ - .Fortran("fvsGetRestartCode",as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] -} - - +#' Get the current FVS restart code. See \link{fvsRun} for a list of the +#' stop codes +#' +#' @return an integer +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetRestartcode() +#' @export +fvsGetRestartcode <- +function() +{ + .Fortran("fvsGetRestartCode",as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] +} + + diff --git a/rFVS/R/fvsGetSVSDims.R b/rFVS/R/fvsGetSVSDims.R index 8148bbe..88c1ac2 100644 --- a/rFVS/R/fvsGetSVSDims.R +++ b/rFVS/R/fvsGetSVSDims.R @@ -1,19 +1,19 @@ -#' Return the max dimensions of important Stand Visualization System data storage. -#' -#' @return a named numeric vector. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetSVSDims() -#' @export -fvsGetSVSDims <- -function() -{ - fvsSVSDims = unlist(.Fortran("fvsSVSDimSizes",as.integer(0),as.integer(0), - as.integer(0),as.integer(0),as.integer(0),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)) - names(fvsSVSDims)=c("nsvsobjs","ndeadobjs","ncwdobjs","mxsvsobjs", - "mxdeadobjs","mxcwdobjs") - fvsSVSDims -} - +#' Return the max dimensions of important Stand Visualization System data storage. +#' +#' @return a named numeric vector. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetSVSDims() +#' @export +fvsGetSVSDims <- +function() +{ + fvsSVSDims = unlist(.Fortran("fvsSVSDimSizes",as.integer(0),as.integer(0), + as.integer(0),as.integer(0),as.integer(0),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)) + names(fvsSVSDims)=c("nsvsobjs","ndeadobjs","ncwdobjs","mxsvsobjs", + "mxdeadobjs","mxcwdobjs") + fvsSVSDims +} + diff --git a/rFVS/R/fvsGetSVSObjectSet.R b/rFVS/R/fvsGetSVSObjectSet.R index ceca440..1de6289 100644 --- a/rFVS/R/fvsGetSVSObjectSet.R +++ b/rFVS/R/fvsGetSVSObjectSet.R @@ -1,122 +1,122 @@ -#' Return the Stand Visualization System objects. -#' -#' @return a named list of trees, snags, and course woody debris (cwd). Each -#' item in the list is a data.frame of items. -#' @examples -#' fvsGetSVSObjectSet() # return list of empty data frames until a run is made using SVS. -#' @export -fvsGetSVSObjectSet <- -function() -{ - -### object types and locations - - svsdims = fvsGetSVSDims() - svsObjNames = c("objtype","objindex","xloc","yloc") - nsvsobjs = svsdims["nsvsobjs"] - svs = NULL - for (name in svsObjNames) - { - nch = nchar(name) - atr = vector("numeric",nsvsobjs) - ans = .C("CfvsSVSObjData",name,nch,"get",nsvsobjs,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[6]] == 0) - { - svs = append(svs,list(ans[[5]])) - names(svs)[length(svs)] = name - } - } - svs = as.data.frame(svs) - -# fetch the species codes for use below. - - sppCds = fvsGetSpeciesCodes() - -### live trees - - lives = NULL - liveptrs = svs$objindex[svs$objtype == 1] - liveptrs = liveptrs[liveptrs != 0] - if (length(liveptrs) > 0) - { - lives = fvsGetTreeAttrs(c("species","dbh","ht","crwdth","cratio", - "crownwt0","crownwt1","crownwt2","crownwt3"))[liveptrs,] - lives = cbind (subset(svs,objtype == 1)[,3:4],lives) - } - if (length(lives$species) > 0) lives$species = sppCds[lives$species,3] - - -### snags - - snagNames = c("snagspp","snagdbh","snaglen","snagfdir","snagstat","snagyear", - "snagwt0","snagwt1","snagwt2","snagwt3") - snags = NULL - snagptrs = svs$objindex[svs$objtype == 2] - snagptrs = snagptrs[snagptrs != 0] - ndeadobjs = svsdims["ndeadobjs"] - if (length(snagptrs) > 0) - { - for (name in snagNames) - { - nch =nchar(name) - atr = vector("numeric",ndeadobjs) - ans = .C("CfvsSVSObjData",name,nch,"get",ndeadobjs,atr,as.integer(0)) - if (ans[[6]] == 0) - { - snags = append(snags,list(ans[[5]])) - names(snags)[length(snags)] = name - } - } - - # age the snag weights - - maxsp = nrow(sppCds) - ageWts = c( "snagwt0", "snagwt1", "snagwt2", "snagwt3") - falyrs = c("fallyrs0","fallyrs1","fallyrs2","fallyrs3") - year = fvsGetEventMonitorVariables(vars="Year") - sage= year-snags$snagyear-1 - for (i in 1:length(falyrs)) - { - name=falyrs[i] - nch =nchar(name) - atr = vector("numeric",maxsp) - ans = .C("CfvsFFEAttrs",name,nch,"get",maxsp,atr,as.integer(0)) - if (ans[[6]] == 0) - { - fal = ans[[5]] - fal = sage/fal[snags$snagspp] - snags[[ageWts[i]]] = snags[[ageWts[i]]] * ifelse(fal < 1, 1-fal, 0) - } - } - - if (length(snags$snagspp) > 0) snags$snagspp = sppCds[snags$snagspp,3] - snags = cbind (subset(svs,objtype == 2)[,3:4],as.data.frame(snags)[snagptrs,]) - } - -### cwd: - - cwdNames = c("cwddia","cwdlen","cwdpil","cwddir","cwdwt") - cwd = NULL - cwdptrs = svs$objindex[svs$objtype == 4] - cwdptrs = cwdptrs[cwdptrs != 0] - ncwdobjs = svsdims["ncwdobjs"] - if (length(cwdptrs) > 0) - { - for (name in cwdNames) - { - nch =nchar(name) - atr = vector("numeric",ncwdobjs) - ans = .C("CfvsSVSObjData",name,nch,"get",ncwdobjs,atr,as.integer(0)) - if (ans[[6]] == 0) - { - cwd = append(cwd,list(ans[[5]])) - names(cwd)[length(cwd)] = name - } - } - cwd = cbind (subset(svs,objtype == 4)[,3:4],as.data.frame(cwd)) - } - - list(trees=lives, snags=snags, cwd=cwd) - -} +#' Return the Stand Visualization System objects. +#' +#' @return a named list of trees, snags, and course woody debris (cwd). Each +#' item in the list is a data.frame of items. +#' @examples +#' fvsGetSVSObjectSet() # return list of empty data frames until a run is made using SVS. +#' @export +fvsGetSVSObjectSet <- +function() +{ + +### object types and locations + + svsdims = fvsGetSVSDims() + svsObjNames = c("objtype","objindex","xloc","yloc") + nsvsobjs = svsdims["nsvsobjs"] + svs = NULL + for (name in svsObjNames) + { + nch = nchar(name) + atr = vector("numeric",nsvsobjs) + ans = .C("CfvsSVSObjData",name,nch,"get",nsvsobjs,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[6]] == 0) + { + svs = append(svs,list(ans[[5]])) + names(svs)[length(svs)] = name + } + } + svs = as.data.frame(svs) + +# fetch the species codes for use below. + + sppCds = fvsGetSpeciesCodes() + +### live trees + + lives = NULL + liveptrs = svs$objindex[svs$objtype == 1] + liveptrs = liveptrs[liveptrs != 0] + if (length(liveptrs) > 0) + { + lives = fvsGetTreeAttrs(c("species","dbh","ht","crwdth","cratio", + "crownwt0","crownwt1","crownwt2","crownwt3"))[liveptrs,] + lives = cbind (subset(svs,objtype == 1)[,3:4],lives) + } + if (length(lives$species) > 0) lives$species = sppCds[lives$species,3] + + +### snags + + snagNames = c("snagspp","snagdbh","snaglen","snagfdir","snagstat","snagyear", + "snagwt0","snagwt1","snagwt2","snagwt3") + snags = NULL + snagptrs = svs$objindex[svs$objtype == 2] + snagptrs = snagptrs[snagptrs != 0] + ndeadobjs = svsdims["ndeadobjs"] + if (length(snagptrs) > 0) + { + for (name in snagNames) + { + nch =nchar(name) + atr = vector("numeric",ndeadobjs) + ans = .C("CfvsSVSObjData",name,nch,"get",ndeadobjs,atr,as.integer(0)) + if (ans[[6]] == 0) + { + snags = append(snags,list(ans[[5]])) + names(snags)[length(snags)] = name + } + } + + # age the snag weights + + maxsp = nrow(sppCds) + ageWts = c( "snagwt0", "snagwt1", "snagwt2", "snagwt3") + falyrs = c("fallyrs0","fallyrs1","fallyrs2","fallyrs3") + year = fvsGetEventMonitorVariables(vars="Year") + sage= year-snags$snagyear-1 + for (i in 1:length(falyrs)) + { + name=falyrs[i] + nch =nchar(name) + atr = vector("numeric",maxsp) + ans = .C("CfvsFFEAttrs",name,nch,"get",maxsp,atr,as.integer(0)) + if (ans[[6]] == 0) + { + fal = ans[[5]] + fal = sage/fal[snags$snagspp] + snags[[ageWts[i]]] = snags[[ageWts[i]]] * ifelse(fal < 1, 1-fal, 0) + } + } + + if (length(snags$snagspp) > 0) snags$snagspp = sppCds[snags$snagspp,3] + snags = cbind (subset(svs,objtype == 2)[,3:4],as.data.frame(snags)[snagptrs,]) + } + +### cwd: + + cwdNames = c("cwddia","cwdlen","cwdpil","cwddir","cwdwt") + cwd = NULL + cwdptrs = svs$objindex[svs$objtype == 4] + cwdptrs = cwdptrs[cwdptrs != 0] + ncwdobjs = svsdims["ncwdobjs"] + if (length(cwdptrs) > 0) + { + for (name in cwdNames) + { + nch =nchar(name) + atr = vector("numeric",ncwdobjs) + ans = .C("CfvsSVSObjData",name,nch,"get",ncwdobjs,atr,as.integer(0)) + if (ans[[6]] == 0) + { + cwd = append(cwd,list(ans[[5]])) + names(cwd)[length(cwd)] = name + } + } + cwd = cbind (subset(svs,objtype == 4)[,3:4],as.data.frame(cwd)) + } + + list(trees=lives, snags=snags, cwd=cwd) + +} diff --git a/rFVS/R/fvsGetSpeciesCodes.R b/rFVS/R/fvsGetSpeciesCodes.R index 0f24229..f90f433 100755 --- a/rFVS/R/fvsGetSpeciesCodes.R +++ b/rFVS/R/fvsGetSpeciesCodes.R @@ -1,28 +1,28 @@ -#' Return a data.frame of species codes -#' -#' @return a data.frame with 1 row for each species and three character columns -#' \tabular{cl}{ -#' rowname \tab internal FVS numeric species index\cr -#' fvs \tab FVS species codes (2-character)\cr -#' fia \tab FIA numeric species codes\cr -#' plant \tab Plant codes\cr} -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetSpeciesCodes() -#' @export -fvsGetSpeciesCodes <- -function () -{ - maxsp = fvsGetDims()["maxspecies"] - all=NULL - for (i in 1:maxsp) { - ans = .C("CfvsSpeciesCode",fvs_code="",fia_code="",plant_code="", - indx=as.integer(i),PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - all = rbind(all,c(ans[[1]],ans[[2]],ans[[3]])) - } - rownames(all)=1:maxsp - colnames(all)=c("fvs","fia","plant") - all -} - +#' Return a data.frame of species codes +#' +#' @return a data.frame with 1 row for each species and three character columns +#' \tabular{cl}{ +#' rowname \tab internal FVS numeric species index\cr +#' fvs \tab FVS species codes (2-character)\cr +#' fia \tab FIA numeric species codes\cr +#' plant \tab Plant codes\cr} +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetSpeciesCodes() +#' @export +fvsGetSpeciesCodes <- +function () +{ + maxsp = fvsGetDims()["maxspecies"] + all=NULL + for (i in 1:maxsp) { + ans = .C("CfvsSpeciesCode",fvs_code="",fia_code="",plant_code="", + indx=as.integer(i),PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + all = rbind(all,c(ans[[1]],ans[[2]],ans[[3]])) + } + rownames(all)=1:maxsp + colnames(all)=c("fvs","fia","plant") + all +} + diff --git a/rFVS/R/fvsGetStandIDs.R b/rFVS/R/fvsGetStandIDs.R index ba2cbf0..dd93c9c 100644 --- a/rFVS/R/fvsGetStandIDs.R +++ b/rFVS/R/fvsGetStandIDs.R @@ -1,15 +1,15 @@ -#' Return stand identification codes -#' -#' @return a names character vector containing the "standid", "standcn", "mgmtid", and "caseID" -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetStandIDs() # will be blank until a run is started -#' @export -fvsGetStandIDs <- -function() -{ - .C("CfvsStandID",standid="",standcn="",mgmtid="" ,caseID="", - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) -} - +#' Return stand identification codes +#' +#' @return a names character vector containing the "standid", "standcn", "mgmtid", and "caseID" +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetStandIDs() # will be blank until a run is started +#' @export +fvsGetStandIDs <- +function() +{ + .C("CfvsStandID",standid="",standcn="",mgmtid="" ,caseID="", + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) +} + diff --git a/rFVS/R/fvsGetSummary.R b/rFVS/R/fvsGetSummary.R index d3448c5..077a7c2 100755 --- a/rFVS/R/fvsGetSummary.R +++ b/rFVS/R/fvsGetSummary.R @@ -1,30 +1,30 @@ -#' Return a data.frame of the summary statistics -#' -#' @return summary statistics with one row per period -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetSummary() # will be NULL until a run is made -#' @export -fvsGetSummary <- -function() -{ - nc = fvsGetDims()["ncycles"] - if (nc == 0) return(NULL) - - asum = vector("list",nc+1) - summary = vector("integer",20) - for (i in 1:(nc+1)) { - asum[[i]] = .Fortran("fvsSummary",as.integer(summary),as.integer(i),as.integer(0), - as.integer(0),as.integer(0),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] - } - ans = NULL - for (r in asum) ans = rbind(ans,r) - rownames(ans)=1:nrow(ans) - colnames(ans)=c("Year","Age","Tpa","TCuFt","MCuFt","BdFt","RTpa", - "RTCuFt","RMCuFt","RBdFt","ATBA","ATCCF","ATTopHt","PrdLen","Acc", - "Mort","SampWt","ForTyp","SizeCls","StkCls") - ans -} - +#' Return a data.frame of the summary statistics +#' +#' @return summary statistics with one row per period +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetSummary() # will be NULL until a run is made +#' @export +fvsGetSummary <- +function() +{ + nc = fvsGetDims()["ncycles"] + if (nc == 0) return(NULL) + + asum = vector("list",nc+1) + summary = vector("integer",20) + for (i in 1:(nc+1)) { + asum[[i]] = .Fortran("fvsSummary",as.integer(summary),as.integer(i),as.integer(0), + as.integer(0),as.integer(0),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] + } + ans = NULL + for (r in asum) ans = rbind(ans,r) + rownames(ans)=1:nrow(ans) + colnames(ans)=c("Year","Age","Tpa","TCuFt","MCuFt","BdFt","RTpa", + "RTCuFt","RMCuFt","RBdFt","ATBA","ATCCF","ATTopHt","PrdLen","Acc", + "Mort","SampWt","ForTyp","SizeCls","StkCls") + ans +} + diff --git a/rFVS/R/fvsGetTreeAttrs.R b/rFVS/R/fvsGetTreeAttrs.R index ac103f1..e952545 100755 --- a/rFVS/R/fvsGetTreeAttrs.R +++ b/rFVS/R/fvsGetTreeAttrs.R @@ -1,58 +1,58 @@ -#' Get Attributes of Trees. -#' -#' @param vars a character vector of any of these tree attribute names: -#' \tabular{cl}{ -#' id \tab Tree identification number (may not be unique) \cr -#' species \tab FVS numeric species code \cr -#' tpa \tab Trees per acre \cr -#' mort \tab Trees per acre predicted to die \cr -#' dbh \tab Diameter breast height (inches) \cr -#' dg \tab Diameter growth scaled to cycle length (inches) \cr -#' ht \tab Height (feet) \cr -#' htg \tab Height growth scaled to cycle length (feet) \cr -#' crwdth \tab Crown width (feet) \cr -#' cratio \tab Crown ratio (proportion of height in live crown \cr -#' age \tab Tree age \cr -#' plot \tab FVS numeric plot index \cr -#' tcuft \tab Total cubic volume \cr -#' mcuft \tab Merch cubic volume \cr -#' bdft \tab Board foot volume \cr -#' ptbal \tab Point basal area in larger trees (sq ft/acre) \cr -#' bapctile \tab Percentile in the distribution of tree basal area \cr -#' defect \tab Defect coded as 11223344 as described below \cr -#' mgmtcd \tab Tree value class or management code (1, 2, or 3) \cr -#' plotsize \tab Size of plot tree was sampled from \cr -#' crownwt0 \tab Weight of foliage (pounds) \cr -#' crownwt1 \tab Weight of 0-.25 inch crown material (pounds) \cr -#' crownwt2 \tab Weight of .25-1 inch crown material (pounds) \cr -#' crownwt3 \tab Weight of 1-3 inch crown material (pounds) \cr -#' crownwt4 \tab Weight of 3-6 inch crown material (pounds) \cr -#' crownwt5 \tab Weight of 06-12 inch crown material (pounds) \cr} -#' @return a data.frame with as many rows as there are tree records and a column -#' for each attribute. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsGetTreeAttrs(vars="dbh","ht","tpa")) # return an empty data frame until a run is made. -#' @export -fvsGetTreeAttrs <- -function(vars) -{ - ntrees = fvsGetDims()["ntrees"] - atr = vector("numeric",ntrees) - action="get" - all = NULL - for (name in vars) - { - nch =nchar(name) - ans = .C("CfvsTreeAttr",name,nch,action,ntrees,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[6]] == 0) - { - all = append(all,list(ans[[5]])) - names(all)[length(all)] = name - } - } - as.data.frame(all) -} - +#' Get Attributes of Trees. +#' +#' @param vars a character vector of any of these tree attribute names: +#' \tabular{cl}{ +#' id \tab Tree identification number (may not be unique) \cr +#' species \tab FVS numeric species code \cr +#' tpa \tab Trees per acre \cr +#' mort \tab Trees per acre predicted to die \cr +#' dbh \tab Diameter breast height (inches) \cr +#' dg \tab Diameter growth scaled to cycle length (inches) \cr +#' ht \tab Height (feet) \cr +#' htg \tab Height growth scaled to cycle length (feet) \cr +#' crwdth \tab Crown width (feet) \cr +#' cratio \tab Crown ratio (proportion of height in live crown \cr +#' age \tab Tree age \cr +#' plot \tab FVS numeric plot index \cr +#' tcuft \tab Total cubic volume \cr +#' mcuft \tab Merch cubic volume \cr +#' bdft \tab Board foot volume \cr +#' ptbal \tab Point basal area in larger trees (sq ft/acre) \cr +#' bapctile \tab Percentile in the distribution of tree basal area \cr +#' defect \tab Defect coded as 11223344 as described below \cr +#' mgmtcd \tab Tree value class or management code (1, 2, or 3) \cr +#' plotsize \tab Size of plot tree was sampled from \cr +#' crownwt0 \tab Weight of foliage (pounds) \cr +#' crownwt1 \tab Weight of 0-.25 inch crown material (pounds) \cr +#' crownwt2 \tab Weight of .25-1 inch crown material (pounds) \cr +#' crownwt3 \tab Weight of 1-3 inch crown material (pounds) \cr +#' crownwt4 \tab Weight of 3-6 inch crown material (pounds) \cr +#' crownwt5 \tab Weight of 06-12 inch crown material (pounds) \cr} +#' @return a data.frame with as many rows as there are tree records and a column +#' for each attribute. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsGetTreeAttrs(vars="dbh","ht","tpa")) # return an empty data frame until a run is made. +#' @export +fvsGetTreeAttrs <- +function(vars) +{ + ntrees = fvsGetDims()["ntrees"] + atr = vector("numeric",ntrees) + action="get" + all = NULL + for (name in vars) + { + nch =nchar(name) + ans = .C("CfvsTreeAttr",name,nch,action,ntrees,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[6]] == 0) + { + all = append(all,list(ans[[5]])) + names(all)[length(all)] = name + } + } + as.data.frame(all) +} + diff --git a/rFVS/R/fvsGetUnitConversion.R b/rFVS/R/fvsGetUnitConversion.R index 3323c20..977647b 100644 --- a/rFVS/R/fvsGetUnitConversion.R +++ b/rFVS/R/fvsGetUnitConversion.R @@ -1,51 +1,51 @@ -#' Get FVS Units Conversion Factor -#' -#' @param name a character string name of the desired conversion factor, where: -#' \tabular{cl}{ -#' CMtoIN \tab cm to inches \cr -#' CMtoFT \tab cm to feet \cr -#' MtoIN \tab m to inches \cr -#' MtoFT \tab m to feet \cr -#' KMtoMI \tab km to miles \cr -#' M2toFT2 \tab square m to square feet \cr -#' HAtoACR \tab hectares to acres \cr -#' M3toFT3 \tab cubic meters to cubic feet \cr -#' KGtoLB \tab kg to pounds (lbs) \cr -#' TMtoTI \tab Tonnes metric (1,000 kg) to Tons Imperial (2,000 lbs) \cr -#' CtoF1 \tab Slope in the Celsius to Fahrenheit conversion \cr -#' CtoF2 \tab Intercept in the Celsius to Fahrenheit conversion \cr -#' INtoCM \tab inches to cm \cr -#' FTtoCM \tab feet to cm \cr -#' INtoM \tab inches to m \cr -#' FTtoM \tab feet to m \cr -#' MItoKM \tab miles to km \cr -#' FT2toM2 \tab square feet to square m \cr -#' ACRtoHA \tab acres to hectares \cr -#' FT3toM3 \tab cubic feet to cubic m \cr -#' LBtoKG \tab pounds (lbs) to kg \cr -#' TItoTM \tab Tons Imperial (2,000 lbs) to Tonnes metric (1,000 kg) \cr -#' FtoC1 \tab Slope in the Fahrenheit to Celsius conversion \cr -#' FtoC2 \tab Intercept in the Fahrenheit to Celsius conversion \cr -#' BTUtoKJ \tab BTU to kilojoules \cr -#' M2pHAtoFT2pACR \tab square m per hectare to square feet per acre \cr -#' M3pHAtoFT3pACR \tab cubic m per hectare \cr -#' FT2pACRtoM2pHA \tab square feet per acre to square m per hectare \cr -#' FT3pACRtoM3pHA \tab cubic feet per acre to cubic m per hectare \cr} -#' @return the numeric value, or NA if FVS does not contain the desired factor. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsUnitConversion("BTUtoKJ") -#' fvsUnitConversion("M2pHAtoFT2pACR") -#' fvsUnitConversion("M2pHAtoFT2pACR")*fvsUnitConversion("FT2pACRtoM2pHA") -#' # [1] 0.9999998 -#' @export -fvsUnitConversion <- -function(name) -{ - nch =nchar(name) - ans = .C("CfvsUnitConversion",name,nch,as.numeric(0),as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[4]] == 0) return(ans[[3]]) else return(NA) -} - +#' Get FVS Units Conversion Factor +#' +#' @param name a character string name of the desired conversion factor, where: +#' \tabular{cl}{ +#' CMtoIN \tab cm to inches \cr +#' CMtoFT \tab cm to feet \cr +#' MtoIN \tab m to inches \cr +#' MtoFT \tab m to feet \cr +#' KMtoMI \tab km to miles \cr +#' M2toFT2 \tab square m to square feet \cr +#' HAtoACR \tab hectares to acres \cr +#' M3toFT3 \tab cubic meters to cubic feet \cr +#' KGtoLB \tab kg to pounds (lbs) \cr +#' TMtoTI \tab Tonnes metric (1,000 kg) to Tons Imperial (2,000 lbs) \cr +#' CtoF1 \tab Slope in the Celsius to Fahrenheit conversion \cr +#' CtoF2 \tab Intercept in the Celsius to Fahrenheit conversion \cr +#' INtoCM \tab inches to cm \cr +#' FTtoCM \tab feet to cm \cr +#' INtoM \tab inches to m \cr +#' FTtoM \tab feet to m \cr +#' MItoKM \tab miles to km \cr +#' FT2toM2 \tab square feet to square m \cr +#' ACRtoHA \tab acres to hectares \cr +#' FT3toM3 \tab cubic feet to cubic m \cr +#' LBtoKG \tab pounds (lbs) to kg \cr +#' TItoTM \tab Tons Imperial (2,000 lbs) to Tonnes metric (1,000 kg) \cr +#' FtoC1 \tab Slope in the Fahrenheit to Celsius conversion \cr +#' FtoC2 \tab Intercept in the Fahrenheit to Celsius conversion \cr +#' BTUtoKJ \tab BTU to kilojoules \cr +#' M2pHAtoFT2pACR \tab square m per hectare to square feet per acre \cr +#' M3pHAtoFT3pACR \tab cubic m per hectare \cr +#' FT2pACRtoM2pHA \tab square feet per acre to square m per hectare \cr +#' FT3pACRtoM3pHA \tab cubic feet per acre to cubic m per hectare \cr} +#' @return the numeric value, or NA if FVS does not contain the desired factor. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsUnitConversion("BTUtoKJ") +#' fvsUnitConversion("M2pHAtoFT2pACR") +#' fvsUnitConversion("M2pHAtoFT2pACR")*fvsUnitConversion("FT2pACRtoM2pHA") +#' # [1] 0.9999998 +#' @export +fvsUnitConversion <- +function(name) +{ + nch =nchar(name) + ans = .C("CfvsUnitConversion",name,nch,as.numeric(0),as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[4]] == 0) return(ans[[3]]) else return(NA) +} + diff --git a/rFVS/R/fvsInteractRun.R b/rFVS/R/fvsInteractRun.R index 0b1790d..afad55d 100644 --- a/rFVS/R/fvsInteractRun.R +++ b/rFVS/R/fvsInteractRun.R @@ -1,160 +1,160 @@ -#' Run FVS where FVS and R interact -#' -#' Pass one or more R-code blocks where each block is a named argument. FVS is run -#' up to the corresponding stop points and the code block is run. After the code block -#' is finished, FVS runs up to the next stop point. All of the code blocks are optional -#' in that any one or all can be used. -#' -#' @param trace is true or false, when true informative messages are generated. -#' @param BeforeEM1 R code to run at the stop point just before the first call to the Event Monitor -#' @param AfterEM1 R code to run at the stop point just after the first call to the Event Monitor -#' @param BeforeEM2 R code to run at the stop point just before the second call to the Event Monitor -#' @param AfterEM2 R code to run at the stop point just after the second call to the Event Monitor -#' @param BeforeAdd R code to run at the stop point after growth and mortality has been computed, but prior to applying them -#' @param BeforeEstab R code to run at the stop point just before the Regeneration Establishment Model is called -#' @param SimEnd R code to run at the end of one stand simulation. -#' @return a list of stands and years simulated with the call. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsSetCmdLine("--keywordfile=base.key") -#' testInteract <- function(msg) -#' { -#' cat("msg=",msg," ids=",unlist(fvsGetStandIDs()), -#' " year=",fvsGetEventMonitorVariables("year"),"\n") -#' fvsGetRestartcode() -#' } -#' fvsInteractRun(BeforeEM1 = 'testInteract("BeforeEM1 ")', -#' AfterEM1 = 'testInteract("AfterEM1 ")', -#' BeforeEM2 = 'testInteract("BeforeEM2 ")', -#' AfterEM2 = 'testInteract("AfterEM2 ")', -#' BeforeAdd = 'testInteract("BeforeAdd ")', -#' BeforeEstab= 'testInteract("BeforeEstab")', -#' SimEnd = 'testInteract("SimEnd ")') -#' @export -fvsInteractRun <- -function(...) -{ - args <- list(...) - - # set up trace - tm=match("trace",names(args)) - trace = as.logical( if (is.na(tm)) FALSE else - { - tr=args[tm] - args = args[-tm] - tr - } ) - - argnames <- names(args) - needed <- c("BeforeEM1","AfterEM1","BeforeEM2","AfterEM2", - "BeforeAdd","BeforeEstab","SimEnd") - toCall <- vector("list",length(needed)) - names(toCall) <- needed - toCall[needed] <- args[needed] - ignored <- setdiff(names(args),needed) - if (length(ignored) > 0) warning("argument(s) ignored: ", - paste(ignored,collapse=", ")) - if (trace) - { - for (name in needed) - { - cat ("arg=", name, "value=", - if (is.null(toCall[[name]])) "NULL" else if ( - class(toCall[[name]]) == "function") "function" else - toCall[[name]],"\n") - } - } - ntoc <- length(needed) - allCases <- list() - oneCase <- NULL - setNextStopPoint <- function (toCall,currStopPoint) - { - pts <- (currStopPoint+1):(ntoc-1) #set up a circlular sequence - if (length(pts) < ntoc) pts <- c(pts,1:(ntoc-length(pts)-1)) - for (i in pts) - { - if (i == 0) next - if (!is.null(toCall[[i]])) - { # args are: spptcd,spptyr - .Fortran("fvsSetStoppointCodes",as.integer(i),as.integer(-1), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - break - } - } - } - setNextStopPoint(toCall,0) - - repeat - { - # run fvs, capture the return code - if (trace) cat ("calling fvs\n") - rtn <- .Fortran("fvs",as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) [[1]] - if (trace) cat ("rtn=",rtn,"\n") - if (rtn != 0) break # this will signal completion. - - # if the current stop point is < zero, then the last call - # is a reload from a stoppoint file. - stopPoint <- .Fortran("fvsGetRestartCode",as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] - if (stopPoint < 0) - { - stopPoint = -stopPoint - setNextStopPoint(toCall,stopPoint) - } - if (trace) - { - yr <- fvsGetEventMonitorVariables("year") - ids <- fvsGetStandIDs() - cat ("called fvs, stopPoint=",stopPoint," yr=",yr," ids=",unlist(ids),"\n") - } - - if (stopPoint == 100) - { - if (! is.null(toCall[["SimEnd"]])) - { - ans <- if (is.function(toCall[["SimEnd"]])) toCall[["SimEnd"]]() else - eval(parse(text=toCall[["SimEnd"]])) - if (! is.null(ans)) - { - onePtr <- length(allCases)+1 - allCases[[onePtr]] <- ans - ids <- fvsGetStandIDs() - caseID <- paste(ids[1], ids[3], "SimEnd",sep=":") - names(allCases)[onePtr] <- caseID - } - } - setNextStopPoint(toCall,0) - } - else - { - if (! is.null(toCall[[stopPoint]])) - { - ans <- if (is.function(toCall[[stopPoint]])) toCall[[stopPoint]]() else - eval(parse(text=toCall[[stopPoint]])) - if (! is.null(ans)) - { - if (is.null(oneCase)) oneCase <- list() - onePtr <- length(oneCase)+1 - oneCase[[onePtr]] <- ans - names(oneCase)[onePtr] <- names(toCall)[stopPoint] - } - } - setNextStopPoint(toCall,if (stopPoint == ntoc-1) 0 else stopPoint) - } - if (! is.null(oneCase)) - { - yr <- fvsGetEventMonitorVariables("year") - ids <- fvsGetStandIDs() - caseID <- paste(ids[1], ids[3], as.character(yr),sep=":") - onePtr <- length(allCases)+1 - allCases[[onePtr]] <- oneCase - names(allCases)[onePtr] <- caseID - } - oneCase <- NULL - } - allCases -} - - +#' Run FVS where FVS and R interact +#' +#' Pass one or more R-code blocks where each block is a named argument. FVS is run +#' up to the corresponding stop points and the code block is run. After the code block +#' is finished, FVS runs up to the next stop point. All of the code blocks are optional +#' in that any one or all can be used. +#' +#' @param trace is true or false, when true informative messages are generated. +#' @param BeforeEM1 R code to run at the stop point just before the first call to the Event Monitor +#' @param AfterEM1 R code to run at the stop point just after the first call to the Event Monitor +#' @param BeforeEM2 R code to run at the stop point just before the second call to the Event Monitor +#' @param AfterEM2 R code to run at the stop point just after the second call to the Event Monitor +#' @param BeforeAdd R code to run at the stop point after growth and mortality has been computed, but prior to applying them +#' @param BeforeEstab R code to run at the stop point just before the Regeneration Establishment Model is called +#' @param SimEnd R code to run at the end of one stand simulation. +#' @return a list of stands and years simulated with the call. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsSetCmdLine("--keywordfile=base.key") +#' testInteract <- function(msg) +#' { +#' cat("msg=",msg," ids=",unlist(fvsGetStandIDs()), +#' " year=",fvsGetEventMonitorVariables("year"),"\n") +#' fvsGetRestartcode() +#' } +#' fvsInteractRun(BeforeEM1 = 'testInteract("BeforeEM1 ")', +#' AfterEM1 = 'testInteract("AfterEM1 ")', +#' BeforeEM2 = 'testInteract("BeforeEM2 ")', +#' AfterEM2 = 'testInteract("AfterEM2 ")', +#' BeforeAdd = 'testInteract("BeforeAdd ")', +#' BeforeEstab= 'testInteract("BeforeEstab")', +#' SimEnd = 'testInteract("SimEnd ")') +#' @export +fvsInteractRun <- +function(...) +{ + args <- list(...) + + # set up trace + tm=match("trace",names(args)) + trace = as.logical( if (is.na(tm)) FALSE else + { + tr=args[tm] + args = args[-tm] + tr + } ) + + argnames <- names(args) + needed <- c("BeforeEM1","AfterEM1","BeforeEM2","AfterEM2", + "BeforeAdd","BeforeEstab","SimEnd") + toCall <- vector("list",length(needed)) + names(toCall) <- needed + toCall[needed] <- args[needed] + ignored <- setdiff(names(args),needed) + if (length(ignored) > 0) warning("argument(s) ignored: ", + paste(ignored,collapse=", ")) + if (trace) + { + for (name in needed) + { + cat ("arg=", name, "value=", + if (is.null(toCall[[name]])) "NULL" else if ( + class(toCall[[name]]) == "function") "function" else + toCall[[name]],"\n") + } + } + ntoc <- length(needed) + allCases <- list() + oneCase <- NULL + setNextStopPoint <- function (toCall,currStopPoint) + { + pts <- (currStopPoint+1):(ntoc-1) #set up a circlular sequence + if (length(pts) < ntoc) pts <- c(pts,1:(ntoc-length(pts)-1)) + for (i in pts) + { + if (i == 0) next + if (!is.null(toCall[[i]])) + { # args are: spptcd,spptyr + .Fortran("fvsSetStoppointCodes",as.integer(i),as.integer(-1), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + break + } + } + } + setNextStopPoint(toCall,0) + + repeat + { + # run fvs, capture the return code + if (trace) cat ("calling fvs\n") + rtn <- .Fortran("fvs",as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) [[1]] + if (trace) cat ("rtn=",rtn,"\n") + if (rtn != 0) break # this will signal completion. + + # if the current stop point is < zero, then the last call + # is a reload from a stoppoint file. + stopPoint <- .Fortran("fvsGetRestartCode",as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] + if (stopPoint < 0) + { + stopPoint = -stopPoint + setNextStopPoint(toCall,stopPoint) + } + if (trace) + { + yr <- fvsGetEventMonitorVariables("year") + ids <- fvsGetStandIDs() + cat ("called fvs, stopPoint=",stopPoint," yr=",yr," ids=",unlist(ids),"\n") + } + + if (stopPoint == 100) + { + if (! is.null(toCall[["SimEnd"]])) + { + ans <- if (is.function(toCall[["SimEnd"]])) toCall[["SimEnd"]]() else + eval(parse(text=toCall[["SimEnd"]])) + if (! is.null(ans)) + { + onePtr <- length(allCases)+1 + allCases[[onePtr]] <- ans + ids <- fvsGetStandIDs() + caseID <- paste(ids[1], ids[3], "SimEnd",sep=":") + names(allCases)[onePtr] <- caseID + } + } + setNextStopPoint(toCall,0) + } + else + { + if (! is.null(toCall[[stopPoint]])) + { + ans <- if (is.function(toCall[[stopPoint]])) toCall[[stopPoint]]() else + eval(parse(text=toCall[[stopPoint]])) + if (! is.null(ans)) + { + if (is.null(oneCase)) oneCase <- list() + onePtr <- length(oneCase)+1 + oneCase[[onePtr]] <- ans + names(oneCase)[onePtr] <- names(toCall)[stopPoint] + } + } + setNextStopPoint(toCall,if (stopPoint == ntoc-1) 0 else stopPoint) + } + if (! is.null(oneCase)) + { + yr <- fvsGetEventMonitorVariables("year") + ids <- fvsGetStandIDs() + caseID <- paste(ids[1], ids[3], as.character(yr),sep=":") + onePtr <- length(allCases)+1 + allCases[[onePtr]] <- oneCase + names(allCases)[onePtr] <- caseID + } + oneCase <- NULL + } + allCases +} + + diff --git a/rFVS/R/fvsRun.R b/rFVS/R/fvsRun.R index 6c6bc22..d3f8311 100644 --- a/rFVS/R/fvsRun.R +++ b/rFVS/R/fvsRun.R @@ -1,51 +1,51 @@ -#' Run FVS up to a designated stop point, year, or both. See \link{fvsGetRestartcode} -#' for a way to find out the current stop point code. -#' -#' @param stopPointCode is the integer value of the FVS stop point. If NA, no stop point is defined. -#' The stop point codes are: -#' \tabular{cl}{ -#' 0 \tab Never stop. \cr -#' -1 \tab Stop at every stop location.\cr -#' 1 \tab Stop just before the first call to the Event Monitor.\cr -#' 2 \tab Stop just after the first call to the Event Monitor.\cr -#' 3 \tab Stop just before the second call to the Event Monitor.\cr -#' 4 \tab Stop just after the second call to the Event Monitor.\cr -#' 5 \tab Stop after growth and mortality has been computed, but prior to applying them.\cr -#' 6 \tab Stop just before the ESTAB routines are called.\cr -#' 7 \tab Stop just after input is read but before missing values are imputed -#' (tree heights and crown ratios, for example) and model calibration (argument -#' stopPointYear is ignored).\cr} -#' @param stopPointYear is the integer value of the year the stop should happen. -#' @return the FVS return code where -#' \tabular{cl}{ -#' -1 \tab indicates that FVS has not been started \cr -#' 0 \tab indicates that FVS is in good running state \cr -#' 1 \tab indicates that FVS has detected \cr -#' an error of some kind and should not be used until reset by specifying new input \cr -#' 2 \tab indicates that FVS has finished processing all the stands; new input can be specified \cr} -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsSetCmdLine("--keywordfile=base.key") -#' fvsRun() -#' @export -fvsRun <- -function(stopPointCode=NA,stopPointYear=NA) -{ - if (! is.na(stopPointCode) && ! is.na(stopPointYear)) - .Fortran("fvsSetStoppointCodes",as.integer(stopPointCode),as.integer(stopPointYear), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - - repeat - { - rtn = .Fortran("fvs",as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) [[1]] - if (rtn != 0) break - stopPoint <- .Fortran("fvsGetRestartCode",as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] - if (stopPoint != 0) break - } - invisible(rtn) -} - - +#' Run FVS up to a designated stop point, year, or both. See \link{fvsGetRestartcode} +#' for a way to find out the current stop point code. +#' +#' @param stopPointCode is the integer value of the FVS stop point. If NA, no stop point is defined. +#' The stop point codes are: +#' \tabular{cl}{ +#' 0 \tab Never stop. \cr +#' -1 \tab Stop at every stop location.\cr +#' 1 \tab Stop just before the first call to the Event Monitor.\cr +#' 2 \tab Stop just after the first call to the Event Monitor.\cr +#' 3 \tab Stop just before the second call to the Event Monitor.\cr +#' 4 \tab Stop just after the second call to the Event Monitor.\cr +#' 5 \tab Stop after growth and mortality has been computed, but prior to applying them.\cr +#' 6 \tab Stop just before the ESTAB routines are called.\cr +#' 7 \tab Stop just after input is read but before missing values are imputed +#' (tree heights and crown ratios, for example) and model calibration (argument +#' stopPointYear is ignored).\cr} +#' @param stopPointYear is the integer value of the year the stop should happen. +#' @return the FVS return code where +#' \tabular{cl}{ +#' -1 \tab indicates that FVS has not been started \cr +#' 0 \tab indicates that FVS is in good running state \cr +#' 1 \tab indicates that FVS has detected \cr +#' an error of some kind and should not be used until reset by specifying new input \cr +#' 2 \tab indicates that FVS has finished processing all the stands; new input can be specified \cr} +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsSetCmdLine("--keywordfile=base.key") +#' fvsRun() +#' @export +fvsRun <- +function(stopPointCode=NA,stopPointYear=NA) +{ + if (! is.na(stopPointCode) && ! is.na(stopPointYear)) + .Fortran("fvsSetStoppointCodes",as.integer(stopPointCode),as.integer(stopPointYear), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + + repeat + { + rtn = .Fortran("fvs",as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) [[1]] + if (rtn != 0) break + stopPoint <- .Fortran("fvsGetRestartCode",as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm)[[1]] + if (stopPoint != 0) break + } + invisible(rtn) +} + + diff --git a/rFVS/R/fvsSetCmdLine.R b/rFVS/R/fvsSetCmdLine.R index ae6c53d..e69b232 100755 --- a/rFVS/R/fvsSetCmdLine.R +++ b/rFVS/R/fvsSetCmdLine.R @@ -1,19 +1,19 @@ -#' Sets the command line -#' -#' @param cl character string of the FVS command line. If missing, the command line -#' arguments passed to R when it was started (also from RScript) are used) -#' @return the FVS return code or NULL if there is no command line specified. -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' fvsSetCmdLine("--keywordfile=base.key") -#' @export -fvsSetCmdLine <- -function(cl = NULL) -{ - if (is.null(cl)) cl=paste(commandArgs(trailingOnly = TRUE),collapse=" ") - nch = as.integer(nchar(cl)) - invisible(if (nch > 0) .C("CfvsSetCmdLine",cl,nch,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) else NULL) -} - +#' Sets the command line +#' +#' @param cl character string of the FVS command line. If missing, the command line +#' arguments passed to R when it was started (also from RScript) are used) +#' @return the FVS return code or NULL if there is no command line specified. +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' fvsSetCmdLine("--keywordfile=base.key") +#' @export +fvsSetCmdLine <- +function(cl = NULL) +{ + if (is.null(cl)) cl=paste(commandArgs(trailingOnly = TRUE),collapse=" ") + nch = as.integer(nchar(cl)) + invisible(if (nch > 0) .C("CfvsSetCmdLine",cl,nch,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) else NULL) +} + diff --git a/rFVS/R/fvsSetTreeAttr.R b/rFVS/R/fvsSetTreeAttr.R index 517d18f..ca503a3 100755 --- a/rFVS/R/fvsSetTreeAttr.R +++ b/rFVS/R/fvsSetTreeAttr.R @@ -1,46 +1,46 @@ -#' Set Attributes of Trees -#' -#' @param vars a named list of numeric vectors where the names are attributes -#' and the vector contains values for each tree (in order). See \link{fvsGetTreeAttrs} -#' for the list of possible attributes. -#' @return scalar integer 0 signals OK and 1 signals an error (invisible). -#' @examples -#' #edit fvsLoad to reflect where FVSbin is stored on your system. -#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") -#' vars = fvsGetTreeAttrs(vars=c("dbh","ht","tpa")) -#' fvsSetTreeAttrs(vars) -#' @export -fvsSetTreeAttrs <- -function(vars) -{ - ntrees = fvsGetDims()["ntrees"] - if (!is.list(vars)) stop("vars must be a list") - if (is.null(names(vars))) stop ("vars must have names") - action = "set" - rtn = 0 - for (name in names(vars)) - { - atr = as.numeric(vars[[name]]) - if (length(atr) != ntrees) - { - warning("Length of '",name,"' must be ",ntrees) - next - } - if (any(is.na(atr))) - { - warning ("NA(s) found for variable '",name,"'") - next - } - nch =nchar(name) - ans = .C("CfvsTreeAttr",name,nch,action,ntrees,atr,as.integer(0), - PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) - if (ans[[6]] != 0) - { - rtn = if (ans[[6]] > rtn) ans[[6]] else rtn - warning ("error assigning variable '",name,"'") - next - } - } - invisible(rtn) -} - +#' Set Attributes of Trees +#' +#' @param vars a named list of numeric vectors where the names are attributes +#' and the vector contains values for each tree (in order). See \link{fvsGetTreeAttrs} +#' for the list of possible attributes. +#' @return scalar integer 0 signals OK and 1 signals an error (invisible). +#' @examples +#' #edit fvsLoad to reflect where FVSbin is stored on your system. +#' fvsLoad(bin="FVSbin",fvsProgram="FVSie") +#' vars = fvsGetTreeAttrs(vars=c("dbh","ht","tpa")) +#' fvsSetTreeAttrs(vars) +#' @export +fvsSetTreeAttrs <- +function(vars) +{ + ntrees = fvsGetDims()["ntrees"] + if (!is.list(vars)) stop("vars must be a list") + if (is.null(names(vars))) stop ("vars must have names") + action = "set" + rtn = 0 + for (name in names(vars)) + { + atr = as.numeric(vars[[name]]) + if (length(atr) != ntrees) + { + warning("Length of '",name,"' must be ",ntrees) + next + } + if (any(is.na(atr))) + { + warning ("NA(s) found for variable '",name,"'") + next + } + nch =nchar(name) + ans = .C("CfvsTreeAttr",name,nch,action,ntrees,atr,as.integer(0), + PACKAGE=get(".FVSLOADEDLIBRARY",envir=.GlobalEnv)$pgm) + if (ans[[6]] != 0) + { + rtn = if (ans[[6]] > rtn) ans[[6]] else rtn + warning ("error assigning variable '",name,"'") + next + } + } + invisible(rtn) +} + diff --git a/rFVS/R/fvsSetupSummary.R b/rFVS/R/fvsSetupSummary.R index 15d5002..8142f57 100644 --- a/rFVS/R/fvsSetupSummary.R +++ b/rFVS/R/fvsSetupSummary.R @@ -1,43 +1,43 @@ -#' Modifies the "summary" statistics so that it is ready to plot -#' -#' The modification is done by adding a row for post thin statistics so that -#' variables like "TPA" show the trace over time with the removals being -#' shown as a vertical drop to the post thin level. -#' -#' @param asum as returned from [fvsGetSummary()] -#' @return A reorganized version of [`asum`]. -#' @examples -#' fvsSetupSummary(fvsGetSummary()) -#' @export - -fvsSetupSummary <- -function(asum) -{ - if (!is.null(names(asum)) && - names(asum)[1] == "sumTable") asum=asum[[1]] - std=c("Tpa","TCuFt","MCuFt","BdFt") - rstd=paste("R",std,sep="") - new=asum[,"RTpa"] > 0 - if (sum(new) > 0) - { - dups=unlist(lapply(1:length(new),function(x,new) if (new[x]) rep(x,2) else x, new)) - asum=asum[dups,] - for (row in 1:(nrow(asum)-1)) - { - nrow=row+1 - if (dups[row] == dups[nrow]) - { - asum[nrow,std] = asum[nrow,std] - asum[nrow,rstd] - asum[row,rstd] = 0 - asum[row,11:ncol(asum)] = NA - dups[nrow]=0 - } - } - } - tprd=apply(asum[,rstd],2,cumsum)+asum[,std] - colnames(tprd)=paste("TPrd",std,sep="") - asum=cbind(asum,tprd) - asum -} - - +#' Modifies the "summary" statistics so that it is ready to plot +#' +#' The modification is done by adding a row for post thin statistics so that +#' variables like "TPA" show the trace over time with the removals being +#' shown as a vertical drop to the post thin level. +#' +#' @param asum as returned from [fvsGetSummary()] +#' @return A reorganized version of [`asum`]. +#' @examples +#' fvsSetupSummary(fvsGetSummary()) +#' @export + +fvsSetupSummary <- +function(asum) +{ + if (!is.null(names(asum)) && + names(asum)[1] == "sumTable") asum=asum[[1]] + std=c("Tpa","TCuFt","MCuFt","BdFt") + rstd=paste("R",std,sep="") + new=asum[,"RTpa"] > 0 + if (sum(new) > 0) + { + dups=unlist(lapply(1:length(new),function(x,new) if (new[x]) rep(x,2) else x, new)) + asum=asum[dups,] + for (row in 1:(nrow(asum)-1)) + { + nrow=row+1 + if (dups[row] == dups[nrow]) + { + asum[nrow,std] = asum[nrow,std] - asum[nrow,rstd] + asum[row,rstd] = 0 + asum[row,11:ncol(asum)] = NA + dups[nrow]=0 + } + } + } + tprd=apply(asum[,rstd],2,cumsum)+asum[,std] + colnames(tprd)=paste("TPrd",std,sep="") + asum=cbind(asum,tprd) + asum +} + + diff --git a/rFVS/tests/iet01.key b/rFVS/tests/iet01.key index 1d4c311..a328403 100644 --- a/rFVS/tests/iet01.key +++ b/rFVS/tests/iet01.key @@ -1,65 +1,65 @@ -SCREEN -NOAUTOES -STATS -STDIDENT -S248112 UNTHINNED CONTROL. -MGMTID -NONE -DESIGN 11.0 1.0 -STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 -INVYEAR 1990.0 -NUMCYCLE 10.0 -TREEFMT -(T24,I4,T1,I4,T31,F2.0,I1,A3,F3.1,F2.1,T45,F3.0,T63,F3.0,T60,F3.1,T48,I1, -T52,I2,T66,5I1,T54,7I1,T75,F3.0) -TREEDATA -ECHOSUM -PROCESS - -REWIND 2.0 -NOAUTOES -STDIDENT -S248112 TEST EXPANDED THINDBH OPTION -MGMTID -THN1 -DESIGN 11.0 1.0 -STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 -INVYEAR 1990.0 -NUMCYCLE 16.0 -IF -(FRAC(CYCLE/3.0) EQ 0.0) -THEN -THINDBH 4.0 1.00 5.0 -THINDBH 2.0 0.01 300.0 -THINDBH 2.0 4.0 0.01 200.0 -THINDBH 4.0 8.0 0.01 125.0 -THINDBH 8.0 12.0 0.01 60.0 -THINDBH 12.0 16.0 0.01 35.0 -THINDBH 16.0 20.0 0.01 15.0 -THINDBH 20.0 1.00 -ENDIF -TREEDATA -ECHOSUM -PROCESS -REWIND 2.0 -NOAUTOES -STDIDENT -S248112 SHELTERWOOD PRESCRIPTION FROM THE USER'S MANUAL -MGMTID -THN2 -DESIGN 11.0 1.0 -STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 -INVYEAR 1990.0 -NUMCYCLE 10.0 -THINPRSC 1990.0 0.999 -SPECPREF 2020.0 2.0 999.0 -SPECPREF 2020.0 7.0 9999.0 -THINBTA 2020.0 157.0 -SPECPREF 2050.0 3.0 -999.0 -SPECPREF 2050.0 4.0 -99.0 -THINBTA 2050.0 35.0 -TREEDATA -ECHOSUM -TREELIST 2050 -PROCESS -STOP +SCREEN +NOAUTOES +STATS +STDIDENT +S248112 UNTHINNED CONTROL. +MGMTID +NONE +DESIGN 11.0 1.0 +STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 +INVYEAR 1990.0 +NUMCYCLE 10.0 +TREEFMT +(T24,I4,T1,I4,T31,F2.0,I1,A3,F3.1,F2.1,T45,F3.0,T63,F3.0,T60,F3.1,T48,I1, +T52,I2,T66,5I1,T54,7I1,T75,F3.0) +TREEDATA +ECHOSUM +PROCESS + +REWIND 2.0 +NOAUTOES +STDIDENT +S248112 TEST EXPANDED THINDBH OPTION +MGMTID +THN1 +DESIGN 11.0 1.0 +STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 +INVYEAR 1990.0 +NUMCYCLE 16.0 +IF +(FRAC(CYCLE/3.0) EQ 0.0) +THEN +THINDBH 4.0 1.00 5.0 +THINDBH 2.0 0.01 300.0 +THINDBH 2.0 4.0 0.01 200.0 +THINDBH 4.0 8.0 0.01 125.0 +THINDBH 8.0 12.0 0.01 60.0 +THINDBH 12.0 16.0 0.01 35.0 +THINDBH 16.0 20.0 0.01 15.0 +THINDBH 20.0 1.00 +ENDIF +TREEDATA +ECHOSUM +PROCESS +REWIND 2.0 +NOAUTOES +STDIDENT +S248112 SHELTERWOOD PRESCRIPTION FROM THE USER'S MANUAL +MGMTID +THN2 +DESIGN 11.0 1.0 +STDINFO 118.0 570.0 60.0 315.0 30.0 34.0 +INVYEAR 1990.0 +NUMCYCLE 10.0 +THINPRSC 1990.0 0.999 +SPECPREF 2020.0 2.0 999.0 +SPECPREF 2020.0 7.0 9999.0 +THINBTA 2020.0 157.0 +SPECPREF 2050.0 3.0 -999.0 +SPECPREF 2050.0 4.0 -99.0 +THINBTA 2050.0 35.0 +TREEDATA +ECHOSUM +TREELIST 2050 +PROCESS +STOP diff --git a/rFVS/tests/iet01.tre b/rFVS/tests/iet01.tre index 6394142..7894bc9 100644 --- a/rFVS/tests/iet01.tre +++ b/rFVS/tests/iet01.tre @@ -1,30 +1,30 @@ - 14 248112 0105 016LP 072 11322 0 0 - 2 248112 0101 031DF 001 0026 00222 0 0 - 1 248112 0101 011LP 11510 0734 00111 0 0 - 3 248112 0102 011WH 06523 0308 00111 0 0 - 4 248112 0102 011L 07906 0753 00111 0 0 - 5 248112 0102 018L 346 10322 0 0 - 6 248112 0103 011L 08007 0633 96222 0 56 - 7 248112 0103 011PP 06220 0385 34111 0 02 - 8 248112 0103 011L 084 54 00111 0 0 - 9 248112 0103 011LP 09511 0603 00111 0 0 - 10 248112 0104 011DF 040 0203 00111 50 0 - 11 248112 0104 011PP 08212 0655 50111 0 0 - 12 248112 0105 011DF 012 0116 00222 42 0 - 13 248112 0105 011DF 019 0135 00222 47 0 - 15 248112 0105 031PP 001 0037 34222 0 05 - 16 248112 0105 011GF 05309 0277 00111 0 0 - 17 248112 0106 011DF 10010 0654 00111 0 0 - 18 248112 0106 011GF 06112 0388 00111 0 0 - 19 248112 0106 011DF 12716 0674 00111 0 0 - 20 248112 0107 800 - 21 248112 0108 011LP 09605 0603 00222 0 0 - 22 248112 0108 011DF 10409 0555 97222 0 49 - 23 248112 0108 011LP 085 03 00111 0 0 - 24 248112 0109 011GF 10910 0657 00111 0 0 - 25 248112 0109 011DF 09418 0604 00111 0 0 - 26 248112 0110 011PP 03206 0175 00222 32 0 - 27 248112 0110 011S 001 0027 00222 0 0 - 28 248112 0110 011S 05810 0287 00111 0 0 - 29 248112 0110 011S 05010 0253 00111 37 0 - 30 248112 0111 011GF 06614 0307 00111 0 0 + 14 248112 0105 016LP 072 11322 0 0 + 2 248112 0101 031DF 001 0026 00222 0 0 + 1 248112 0101 011LP 11510 0734 00111 0 0 + 3 248112 0102 011WH 06523 0308 00111 0 0 + 4 248112 0102 011L 07906 0753 00111 0 0 + 5 248112 0102 018L 346 10322 0 0 + 6 248112 0103 011L 08007 0633 96222 0 56 + 7 248112 0103 011PP 06220 0385 34111 0 02 + 8 248112 0103 011L 084 54 00111 0 0 + 9 248112 0103 011LP 09511 0603 00111 0 0 + 10 248112 0104 011DF 040 0203 00111 50 0 + 11 248112 0104 011PP 08212 0655 50111 0 0 + 12 248112 0105 011DF 012 0116 00222 42 0 + 13 248112 0105 011DF 019 0135 00222 47 0 + 15 248112 0105 031PP 001 0037 34222 0 05 + 16 248112 0105 011GF 05309 0277 00111 0 0 + 17 248112 0106 011DF 10010 0654 00111 0 0 + 18 248112 0106 011GF 06112 0388 00111 0 0 + 19 248112 0106 011DF 12716 0674 00111 0 0 + 20 248112 0107 800 + 21 248112 0108 011LP 09605 0603 00222 0 0 + 22 248112 0108 011DF 10409 0555 97222 0 49 + 23 248112 0108 011LP 085 03 00111 0 0 + 24 248112 0109 011GF 10910 0657 00111 0 0 + 25 248112 0109 011DF 09418 0604 00111 0 0 + 26 248112 0110 011PP 03206 0175 00222 32 0 + 27 248112 0110 011S 001 0027 00222 0 0 + 28 248112 0110 011S 05810 0287 00111 0 0 + 29 248112 0110 011S 05010 0253 00111 37 0 + 30 248112 0111 011GF 06614 0307 00111 0 0