replace plyr ddply/join with base #161

ncss-tech · Nov 5, 2021 · cd3e98c · cd3e98c
1 parent 34e679f
commit cd3e98c
Show file tree

Hide file tree

Showing 6 changed files with 14 additions and 11 deletions.
diff --git a/R/fetchNASIS_report.R b/R/fetchNASIS_report.R
@@ -66,7 +66,7 @@
 
 
   # upgrade to SoilProfilecollection
-  h <- join(.$phorizon, .$phcolor, by = "phiid", type = "left")
+  h <- merge(.$phorizon, .$phcolor, by = "phiid", all.x = TRUE, sort = FALSE)
   depths(h) <- peiid ~ hzdept + hzdepb
 
 

diff --git a/R/fetchPedonPC.R b/R/fetchPedonPC.R
@@ -33,7 +33,7 @@ fetchPedonPC <- function(dsn) {
 
 	# join pieces
 	# horizon + hz color: all horizons
-	h <- join(hz_data, color_data, by='phiid', type='left')
+	h <- merge(hz_data, color_data, by='phiid', all.x = TRUE, sort = FALSE)
 
 	# convert colors... in the presence of missing color data
 	if(nrow(h) > 0) {
@@ -42,7 +42,7 @@ fetchPedonPC <- function(dsn) {
   	h$soil_color[idx] <- with(h[idx, ], rgb(m_r, m_g, m_b)) # moist colors
   }
 	# replace horizons with hz + fragment summary
-	h <- join(h, extended_data$frag_summary, by='phiid', type='left')
+	h <- merge(h, extended_data$frag_summary, by='phiid', all.x = TRUE, sort = FALSE)
 
 	# fix some common problems
 	# replace missing lower boundaries

diff --git a/R/getHzErrorsPedonPC.R b/R/getHzErrorsPedonPC.R
@@ -6,7 +6,7 @@ getHzErrorsPedonPC <- function(dsn, strict=TRUE) {
 	hz_data <- get_hz_data_from_pedon_db(dsn)
 
 	# combine pieces
-	f <- join(hz_data, site_data, by='peiid', type='inner')
+  f <- merge(hz_data, site_data, by='peiid', all.x = TRUE, sort = FALSE)
 
 	f.test <- aqp::checkHzDepthLogic(f, hzdepths = c('hzdept', 'hzdepb'),
 	                                 idname = 'pedon_id', fast = TRUE)

diff --git a/R/get_colors_from_pedon_db.R b/R/get_colors_from_pedon_db.R
@@ -1,7 +1,5 @@
 # 2013-01-08: now much faster since we only mix/clean data with > 1 color / horizon
 
-
-
 #' Get Soil Color Data from a PedonPC Database
 #' 
 #' Get, format, mix, and return color data from a PedonPC database.
@@ -60,7 +58,9 @@ FROM (
 	if(length(dry.to.mix) > 0) {
 		# filter out and mix only colors with >1 color / horizon
 		dry.mix.idx <- which(dry.colors$phiid %in% dry.to.mix)
-		mixed.dry <- ddply(dry.colors[dry.mix.idx, ], 'phiid', mix_and_clean_colors)
+		dc <- split(dry.colors[dry.mix.idx, ], f = dry.colors[['phiid']][dry.mix.idx])
+		dc.l <- lapply(dc, mix_and_clean_colors)
+		mixed.dry <- do.call('rbind', dc.l)
 		# combine original[-horizons to be mixed] + mixed horizons
 		dry.colors.final <- rbind(dry.colors[-dry.mix.idx, c("phiid", "r", "g", "b", "colorvalue")], mixed.dry)
 	}
@@ -71,7 +71,10 @@ FROM (
 	if(length(moist.to.mix) > 0) {
 		# filter out and mix only colors with >1 color / horizon
 		moist.mix.idx <- which(moist.colors$phiid %in% moist.to.mix)
-		mixed.moist <- ddply(moist.colors[moist.mix.idx, ], 'phiid', mix_and_clean_colors)
+		mc <- split(moist.colors[moist.mix.idx, ], f = moist.colors[['phiid']][moist.mix.idx])
+		mc.l <- lapply(mc, mix_and_clean_colors)
+		mixed.moist <- do.call('rbind', mc.l)
+
 		# combine original[-horizons to be mixed] + mixed horizons
 		moist.colors.final <- rbind(moist.colors[-moist.mix.idx, c("phiid", "r", "g", "b", "colorvalue")], mixed.moist)
 	}
@@ -83,7 +86,7 @@ FROM (
 	names(moist.colors.final) <- c('phiid', 'm_r', 'm_g', 'm_b', 'm_value')
 
 	# merge into single df
-	d.final <- join(dry.colors.final, moist.colors.final, by='phiid', type='full')
+	d.final <- merge(dry.colors.final, moist.colors.final, by='phiid', all.x = TRUE, all.y = TRUE, sort = FALSE)
 
 	# clean-up
 	rm(d, d.rgb, dry.colors, moist.colors, dry.colors.final, moist.colors.final)

diff --git a/R/get_component_data_from_NASIS_db.R b/R/get_component_data_from_NASIS_db.R
@@ -780,7 +780,7 @@ get_comonth_from_NASIS_db <- function(SS = TRUE,
 
     # join full version to comonth records
     # nd contains the full set of component records IDs
-    d <- join(nd, d, by=c('coiid', 'month'), type = 'left')
+    d <- merge(nd, d, by=c('coiid', 'month'), all.x = TRUE, sort = FALSE)
 
     ## this isn't likely needed, will re-visit after some testing
 

diff --git a/R/get_hz_data_from_pedon_db.R b/R/get_hz_data_from_pedon_db.R
@@ -78,7 +78,7 @@ LEFT OUTER JOIN (SELECT * FROM metadata_domain_detail WHERE metadata_domain_deta
   }
 
   # join
-  d <- join(d, d.texture, by='phiid', type='left')
+  d <- merge(d, d.texture, by='phiid', all.x = TRUE, sort = FALSE)
 
 	# close connection
 	DBI::dbDisconnect(channel)