## ----rmd_setup, include = FALSE----------------------------------------------- knitr::opts_chunk$set( collapse = TRUE, comment = "#>" ) ## ----Pkg_Install, eval=FALSE-------------------------------------------------- # # Installing the BCGcalc library (with the vignette) from GitHub # library(devtools) # install_github("leppott/BCGcalc", force=TRUE, build_vignettes=TRUE) ## ----Pkg_Help, eval=FALSE----------------------------------------------------- # help(package="BCGcalc") ## ----View_TaxaMaster, eval=FALSE---------------------------------------------- # library(BCGcalc) # # View(TaxaMaster_Ben_BCG_PugLowWilVal) # # # Save to working directory # #write.csv(TaxaMaster_Ben_BCG_PugLowWilVal # # , "TaxaMaster_Ben_BCG_PugLowWilVal_20180927.csv") ## ----Head_TaxaMaster, echo=FALSE, eval=TRUE----------------------------------- library(BCGcalc) library(knitr) kable(head(TaxaMaster_Ben_BCG_PugLowWilVal), caption="PugLowWilVal BCG Master Taxa") ## ----CoreFun_TestData, eval=FALSE--------------------------------------------- # # Packages # library(BCGcalc) # library(readxl) # library(reshape2) # library(BioMonTools) # # # Import # df.samps.bugs <- read_excel( # system.file("./extdata/Data_BCG_PugLowWilVal.xlsx", # package="BCGcalc"), # guess_max = 10^6) # # # QC for TRUE/FALSE (both ok) # # Exclude to TRUE/FALSE # table(df.samps.bugs$Exclude) # # NonTarget to TRUE/FALSE # table(df.samps.bugs$NonTarget) # # # Add missing columns # col_add_char <- c("INFRAORDER", # "HABITAT", # "ELEVATION_ATTR", # "GRADIENT_ATTR", # "WSAREA_ATTR", # "HABSTRUCT") # col_add_num <- "UFC" # df.samps.bugs[, col_add_char] <- NA_character_ # df.samps.bugs[, col_add_num] <- NA_integer_ # # # 1.A. Calculate Metrics # # Extra columns to keep in results # keep.cols <- c("Area_mi2", # "SurfaceArea", # "Density_m2", # "Density_ft2") # # Run Function # df.metrics <- metric.values(df.samps.bugs, # "bugs", # fun.cols2keep = keep.cols) # # QC # dim(df.metrics) # # View(df.metrics) # # Save # # write.table(df.metrics, # # "Metric.Values.Test.tsv", # # col.names = TRUE, # # row.names = FALSE, # # sep = "\t") # # # 1.B. Metric Membership # # Import Rules # df.rules <- read_excel( # system.file("./extdata/Rules.xlsx", # package = "BCGcalc"), # sheet = "Rules") # # Run function # df.Metric.Membership <- BCG.Metric.Membership(df.metrics, # df.rules) # # Show Results # # View(df.Metric.Membership) # # Save Results # # write.table(df.Metric.Membership, # # "Metric.Membership.Test.tsv", # # row.names = FALSE, # # col.names = TRUE, # # sep = "\t") # # # 1.C. Level Assignment # # Run Function # df.Level.Membership <- BCG.Level.Membership(df.Metric.Membership, # df.rules) # # Show results # # View(df.Level.Membership) # # Save Results # # write.table(df.Level.Membership, # # "Level.Membership.Test.tsv", # # row.names = FALSE, # # col.names = TRUE, # # sep = "\t") # # # 1.D. Level Membership # # Run Function # df.Levels <- BCG.Level.Assignment(df.Level.Membership) # # # 1.E. Flags # # Import QC Checks # df.checks <- read_excel(system.file("./extdata/MetricFlags.xlsx", # package = "BCGcalc"), # sheet = "Flags") # # Run Function # df.flags <- qc.checks(df.metrics, df.checks) # # Change terminology; PASS/FAIL to NA/flag # df.flags[, "FLAG"][df.flags[, "FLAG"] == "FAIL"] <- "flag" # df.flags[, "FLAG"][df.flags[, "FLAG"] == "PASS"] <- NA # # long to wide format # df.flags.wide <- dcast(df.flags, # SAMPLEID ~ CHECKNAME, # value.var = "FLAG") # # Calc number of "flag"s by row. # df.flags.wide$NumFlags <- rowSums(df.flags.wide == "flag", na.rm = TRUE) # # Rearrange columns # NumCols <- ncol(df.flags.wide) # df.flags.wide <- df.flags.wide[, c(1, NumCols, 2:(NumCols-1))] # # Merge Levels and Flags # df.Levels.Flags <- merge(df.Levels, # df.flags.wide, # by.x = "SampleID", # by.y = "SAMPLEID", # all.x = TRUE) # # Show Results # # View(df.Levels.Flags) # # Summarize Results # table(df.flags[, "CHECKNAME"], df.flags[, "FLAG"], useNA = "ifany") # # Save Results # # write.csv(df.Levels.Flags, "Levels.Flags.Test.csv") ## ----CoreFun_NewData, eval=FALSE---------------------------------------------- # # Setup # library(readxl) # library(dplyr) # library(BCGcalc) # library(BioMonTools) # library(reshape2) # # # Read File # ## FileName # fn.data <- system.file("./extdata/ExampleMunge_UnformatedData.xlsx" # , package="BCGcalc") # # wd <- "F:\\myDocs" # # fn.data <- file.path(wd, "ExampleMunge_UnformatedData.xlsx") # # ## Worksheet # sh.data <- "SamplesWithBioticAttributesAndR" # ## Import # ### set "guess" to a large number to avoid type being wrong # df.data <- read_excel(fn.data, # sheet = sh.data, # guess_max = 12000) # dim(df.data) # # # Munge # ## Col Names # ### convert to upper case # names(df.data) <- toupper(names(df.data)) # ### Rename Columns (base R) [dplyr::rename not working] # names(df.data)[names(df.data) == "SAMPLE ID"] <- "SAMPLEID" # names(df.data)[names(df.data) == "TAXON"] <- "TAXAID" # names(df.data)[names(df.data) == "SAMPLE ID"] <- "SAMPLEID" # names(df.data)[names(df.data) == "QUANTITY SUBSAMPLING"] <- "N_TAXA" # #names(df.data)[names(df.data) == "HILSENHOFF BIOTIC TOLERANCE INDEX"] <- "TOLVAL" # # df.data <- df.data %>% rename("SAMPLEID"="SAMPLE ID" # # , "TAXAID"="TAXON" # # , "N_TAXA"="QUANTITY SUBSAMPLING" # # , "TOLVAL"="HILSENHOFF BIOTIC TOLERANCE INDEX" # # ) # ### Create columns # df.data$EXCLUDE <- !df.data$UNIQUE # df.data$NONTARGET <- df.data$`OUTSIDE PROTOCOL` # # df.data$FFG <- NA # # df.data$FFG[df.data$PREDATOR==TRUE] <- "PR" # # df.data$HABIT <- NA # # df.data$HABIT[df.data$CLINGER==TRUE] <- "CN" # # df.data$LIFE_CYCLE <- NA # df.data$SITE_TYPE <- NA # # df.data$BCG_ATTR <- NA # # df.data$THERMAL_INDICATOR <- NA # df.data$INDEX_NAME <- "BCG_PugLowWilVal_500ct" # df.data$SURFACEAREA <- df.data$`SURFACE AREA` # df.data$AREA_MI2 <- NA # df.data$DENSITY_M2 <- NA # df.data$DENSITY_FT2 <- NA # # # Add slope (and then gradient for SiteType) from NHD+ v2 # fn.slope <- system.file("./extdata/ExampleMunge_Slope.xlsx", # package="BCGcalc") # # fn.slope <- file.path(wd, "ExampleMunge_Slope.xlsx") # df.slope <- read_excel(fn.slope) # names(df.slope) <- toupper(names(df.slope)) # # merge files # df.comb.slope <- merge(df.data, # df.slope, # by.x = "SITE CODE", # by.y = "SITE_CODE", # all.x = TRUE) # # QC (rows) # dim(df.data) # dim(df.comb.slope) # nrow(df.data) == nrow(df.comb.slope) # df.comb.slope$SITE_TYPE <- df.comb.slope$`SLOPE CATEGORY` # # # Update Taxa Attributes from Master Taxa List in Package # df.taxamaster <- TaxaMaster_Ben_BCG_PugLowWilVal # names(df.taxamaster) <- toupper(names(df.taxamaster)) # ## Assume phylogenetic information is correct. # col.auteco <- c("TAXAID", # "BCG_ATTR", # "THERMAL_INDICATOR", # "LONG_LIVED", # "FFG", # "HABIT", # "LIFE_CYCLE", # "TOLVAL") # df.comb.slope.auteco <- merge(df.comb.slope, # df.taxamaster[, col.auteco], # by.x = "TAXAID", # by.y = "TAXAID", # all.x = TRUE) # nrow(df.comb.slope) == nrow(df.comb.slope.auteco) # # # SiteClass to Index_Class # df.comb.slope.auteco$INDEX_CLASS <- df.comb.slope.auteco$SITE_TYPE # # # Create Anlaysis File # col2keep <- c("SAMPLEID", # "INDEX_NAME", # "INDEX_CLASS", # "AREA_MI2", # "SURFACEAREA", # "DENSITY_M2", # "DENSITY_FT2", # "TAXAID", # "N_TAXA", # "EXCLUDE", # "NONTARGET", # "PHYLUM", # "SUBPHYLUM", # "CLASS", # "ORDER", # "FAMILY", # "SUBFAMILY", # "TRIBE", # "GENUS", # "FFG", # "HABIT", # "LIFE_CYCLE", # "TOLVAL", # "BCG_ATTR", # "THERMAL_INDICATOR") # df.samps.bugs <- as.data.frame(df.comb.slope.auteco[, col2keep ]) # # #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # # Repeat code from previous example # # (with minor edits) # #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # # # QC for TRUE/FALSE (both ok) # # Exclude to TRUE/FALSE # table(df.samps.bugs$EXCLUDE) # # NonTarget to TRUE/FALSE # table(df.samps.bugs$NONTARGET) # # # 1.A. Calculate Metrics # # Extra columns to keep in results # keep.cols <- toupper(c("Area_mi2", # "SurfaceArea", # "Density_m2", # "Density_ft2")) # # Run Function # df.metrics <- metric.values(df.samps.bugs, # "bugs", # fun.cols2keep = keep.cols, # boo.Shiny = TRUE) # # QC # dim(df.metrics) # # View(df.metrics) # # Save # # write.table(df.metrics # # , "Metric.Values.New.tsv" # # , col.names = TRUE # # , row.names = FALSE # # , sep = "\t") # # # 1.B. Metric Membership # # Import Rules # df.rules <- read_excel(system.file("./extdata/Rules.xlsx" # , package="BCGcalc") # , sheet="Rules") # names(df.rules)[names(df.rules) %in% "Index_Name"] <- "INDEX_NAME" # # Run function # df.Metric.Membership <- BCG.Metric.Membership(df.metrics, df.rules) # # Show Results # # View(df.Metric.Membership) # # Save Results # # write.table(df.Metric.Membership, # # "Metric.Membership.New.tsv", # # row.names = FALSE, # # col.names = TRUE, # # sep = "\t") # # # 1.C. Level Assignment # # Run Function # df.Level.Membership <- BCG.Level.Membership( # df.Metric.Membership, # df.rules) # # # Show results # # View(df.Level.Membership) # # Save Results # # write.table(df.Level.Membership, # # "Level.Membership.New.tsv", # # row.names = FALSE, # # col.names = TRUE, # # sep = "\t") # # # 1.D. Level Membership # # Run Function # df.Levels <- BCG.Level.Assignment(df.Level.Membership) # # # 1.E. Flags # # Import QC Checks # df.checks <- read_excel( # system.file("./extdata/MetricFlags.xlsx", # package = "BCGcalc"), # sheet = "Flags") # # Run Function # df.flags <- qc.checks(df.metrics, df.checks) # # Change terminology; PASS/FAIL to NA/flag # df.flags[, "FLAG"][df.flags[, "FLAG"] == "FAIL"] <- "flag" # df.flags[, "FLAG"][df.flags[, "FLAG"] == "PASS"] <- NA # # long to wide format # df.flags.wide <- dcast(df.flags, # SAMPLEID ~ CHECKNAME, # value.var="FLAG") # # Calc number of "flag"s by row. # df.flags.wide$NumFlags <- rowSums(df.flags.wide == "flag", na.rm = TRUE) # # Rearrange columns # NumCols <- ncol(df.flags.wide) # df.flags.wide <- df.flags.wide[, c(1, NumCols, 2:(NumCols - 1))] # # Merge Levels and Flags # df.Levels.Flags <- merge(df.Levels, # df.flags.wide, # by.x = "SampleID", # by.y = "SAMPLEID", # all.x = TRUE) # # Show Results # # View(df.Levels.Flags) # # Summarize Results # table(df.flags[, "CHECKNAME"], df.flags[, "FLAG"], useNA = "ifany") # # Save Results # # write.csv(df.Levels.Flags, "Levels.Flags.New.csv") ## ----Other_Rarify, eval=TRUE, echo=TRUE--------------------------------------- library(BCGcalc) library(knitr) library(BioMonTools) # Subsample to 600 organisms (from over 600 organisms) for 12 samples. ## FileName ### Package example df_data <- BioMonTools::data_bio2rarify ### Excel # wd <- "F:\\myDocs" # fn_data <- file.path(wd, "ExampleMunge_UnformatedData.xlsx") # readxl::read_excel(fn.data) ### CSV # fn_data <- # df_data <- read.csv(fn_data) # df_biodata <- df_data #dim(df_biodata) #View(df_biodata) # subsample mySize <- 600 Seed_OR <- 18590214 Seed_WA <- 18891111 Seed_US <- 17760704 bugs_mysize <- BioMonTools::rarify(inbug = df_biodata, sample.ID = "SampleID", abund = "N_Taxa", subsiz = mySize, mySeed = Seed_US) #dim(bugs.mysize) #View(bugs.mysize) # Compare pre- and post- subsample counts df_compare <- merge(df_biodata, bugs_mysize, by=c("SampleID", "TaxaID"), suffixes = c("_Orig","_600")) df_compare <- df_compare[, c("SampleID", "TaxaID", "N_Taxa_Orig", "N_Taxa_600")] #View(df.compare) # compare totals tbl_compare <- head(df_compare) tbl_compare_caption <- "First few rows of original and rarified data." kable(tbl_compare, caption=tbl_compare_caption) tbl_totals <- aggregate( cbind(N_Taxa_Orig, N_Taxa_600) ~ SampleID, df_compare, sum) tbl_totals_caption <- "Comparison of total individuals per sample." kable(tbl_totals, caption=tbl_totals_caption) # save the data #write.table(bugs.mysize,paste("bugs",mySize,"txt",sep="."),sep="\t") ## ----MetricValues_Keep1, eval = FALSE----------------------------------------- # # Packages # library(BCGcalc) # library(readxl) # library(knitr) # library(BioMonTools) # # # Load Data # df.data <- read_excel(system.file("./extdata/Data_BCG_PugLowWilVal.xlsx" # , package="BCGcalc") # , guess_max = 10^6) # # Columns to keep # myCols <- c("Area_mi2", # "SurfaceArea", # "Density_m2", # "Density_ft2") # # Metrics of Interest (BCG) # col.met2keep <- c("ni_total", # "nt_total", # "nt_BCG_att1i2", # "pt_BCG_att1i23", # "pi_BCG_att1i23", # "pt_BCG_att56", # "pi_BCG_att56", # "nt_EPT_BCG_att1i23", # "pi_NonInsJugaRiss_BCG_att456", # "pt_NonIns_BCG_att456", # "nt_EPT", # "pi_NonIns_BCG_att456") # # Run Function # df.metval <- metric.values(df.data, # "bugs", # fun.cols2keep = myCols, # fun.MetricNames = col.met2keep, # boo.Shiny = TRUE) # # # Select columns # col.ID <- c("SAMPLEID", # toupper(myCols), # "INDEX_NAME") # # Ouput # df.metval.bcg12 <- df.metval[, c(col.ID, col.met2keep)] # # RMD table # kable(head(df.metval.bcg12), caption = "Select Metrics, Example 1") ## ----MetricValues_Keep2------------------------------------------------------- # Packages library(BCGcalc) library(readxl) library(knitr) library(BioMonTools) # Load Data df.data <- read_excel(system.file("./extdata/Data_BCG_PugLowWilVal.xlsx" , package="BCGcalc") , guess_max = 10^6) # Add missing columns col_add_char <- c("INFRAORDER", "HABITAT", "ELEVATION_ATTR", "GRADIENT_ATTR", "WSAREA_ATTR", "HABSTRUCT") col_add_num <- c("UFC", "SAMP_AREA_M2") df.data[, col_add_char] <- NA_character_ df.data[, col_add_num] <- NA_integer_ # Columns to keep myCols <- c("Area_mi2", "SurfaceArea", # "Density_m2", "Density_ft2") # Run Function df.metval <- metric.values(df.data, "bugs", fun.cols2keep=myCols) # Metrics of Interest ## thermal indicator (_ti_) #names(df.metval)[grepl("_ti_", names(df.metval))] col.met2keep <- c("ni_total", "nt_total", paste0("nt_ti_", c("stenocold", "cold", "cool", "warm", "stenowarm")), paste0("pi_ti_", c("stenocold", "cold", "cool", "warm", "stenowarm")), paste0("pt_ti_", c("stenocold", "cold", "cool", "warm", "stenowarm")) ) col.ID <- c("SAMPLEID", toupper(myCols), "INDEX_NAME") # Ouput df.metval.ci <- df.metval[, c(col.ID, col.met2keep)] # RMD table kable(head(df.metval.ci), caption = "Select Metrics, Example 2") ## ----Flags, echo=FALSE, eval=TRUE--------------------------------------------- # Packages library(BCGcalc) library(readxl) library(reshape2) library(knitr) library(BioMonTools) #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Need to run some code to get results for display tables. # Repeat code from CoreFun_TestData #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Import df.samps.bugs <- read_excel(system.file("./extdata/Data_BCG_PugLowWilVal.xlsx" , package="BCGcalc") , guess_max = 10^6) # Add missing columns col_add_char <- c("INFRAORDER", "HABITAT", "ELEVATION_ATTR", "GRADIENT_ATTR" , "WSAREA_ATTR", "HABSTRUCT") col_add_num <- "UFC" df.samps.bugs[, col_add_char] <- NA_character_ df.samps.bugs[, col_add_num] <- NA_integer_ # 1.A. Calculate Metrics # Extra columns to keep in results keep.cols <- c("Area_mi2" , "SurfaceArea" , "Density_m2" , "Density_ft2") # Run Function df.metrics <- metric.values(df.samps.bugs, "bugs", fun.cols2keep = keep.cols) # # QC # dim(df.metrics) # View(df.metrics) # # Save # write.table(df.metrics, "Metric.Values.Test.tsv", col.names=TRUE #, row.names=FALSE, sep="\t") # 1.B. Metric Membership # Import Rules df.rules <- read_excel(system.file("./extdata/Rules.xlsx" , package="BCGcalc") , sheet="Rules") # Run function df.Metric.Membership <- BCG.Metric.Membership(df.metrics, df.rules) # # Show Results # View(df.Metric.Membership) # # Save Results # write.table(df.Metric.Membership, "Metric.Membership.Test.tsv" # , row.names=FALSE, col.names=TRUE, sep="\t") # 1.C. Level Assignment # Run Function df.Level.Membership <- BCG.Level.Membership(df.Metric.Membership, df.rules) # # Show results # View(df.Level.Membership) # # Save Results # write.table(df.Level.Membership, "Level.Membership.Test.tsv" # , row.names=FALSE, col.names=TRUE, sep="\t") # 1.D. Level Membership # Run Function df.Levels <- BCG.Level.Assignment(df.Level.Membership) # 1.E. Flags # Import QC Checks df.checks <- read_excel(system.file("./extdata/MetricFlags.xlsx" , package="BCGcalc") , sheet="Flags") # Run Function df.flags <- qc.checks(df.metrics, df.checks) # Change terminology; PASS/FAIL to NA/flag df.flags[,"FLAG"][df.flags[,"FLAG"]=="FAIL"] <- "flag" df.flags[, "FLAG"][df.flags[,"FLAG"]=="PASS"] <- NA # long to wide format df.flags.wide <- dcast(df.flags, SAMPLEID ~ CHECKNAME, value.var="FLAG") # Calc number of "flag"s by row. df.flags.wide$NumFlags <- rowSums(df.flags.wide=="flag", na.rm=TRUE) # Rearrange columns NumCols <- ncol(df.flags.wide) df.flags.wide <- df.flags.wide[, c(1, NumCols, 2:(NumCols-1))] # Merge Levels and Flags df.Levels.Flags <- merge(df.Levels, df.flags.wide , by.x = "SampleID", by.y = "SAMPLEID" , all.x=TRUE) # # Show Results # View(df.Levels.Flags) # # Summarize Results # table(df.flags[,"CHECKNAME"], df.flags[,"FLAG"], useNA="ifany") # # Save Results # write.csv(df.Levels.Flags, "Levels.Flags.Test.csv") #~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~ # Flags # Filter for "hi" tbl.checks.hi <- df.checks[df.checks[,"SITE_TYPE"]=="Hi", ] # Display tbl.checks.caption <- "Flags, Hi Gradient" kable(tbl.checks.hi, caption = tbl.checks.caption) # Levels and Flags tbl.Levels.Flags.caption <- "Levels and Flags." kable(head(df.Levels.Flags), caption = tbl.Levels.Flags.caption) # Flags tbl.flags.caption <- "Flag Summary." kable(table(df.flags[,"CHECKNAME"], df.flags[,"FLAG"], useNA="ifany") , caption = tbl.flags.caption)