site normalization fixes

R/SoilProfileCollection-setters.R

@@ -335,22 +335,26 @@ setReplaceMethod("site", signature(object = "SoilProfileCollection"),
   names_attr <- names(mf)
   idx <- match(names_attr, horizonNames(object))
 
-  # remove the index to the ID columnm, as we do not want to remove this from
+  # remove the index to the ID column, as we do not want to remove this from
   # the horizon data !
   idx <- idx[-match(idname(object), names_attr)]
 
   # this will break when multiple horizons in the same pedon have different site data!
   # this seems to work fine in all cases, as we keep the ID column
   # and it ensures that the result is in the same order as the IDs
-  new_site_data <- ddply(mf, idname(object),
-      .fun=function(x) {
-	      unique(x[, names_attr, drop = FALSE])
-      }
-  )
-
+  .SD <- NULL
+
+  dth <- as.data.table(horizons(object))
+
+  new_site_data <- .as.data.frame.aqp(unique(dth[, .SD, .SDcols = names_attr]), aqp_df_class(object))
+
+  if (nrow(new_site_data) != length(object)) {
+    warning("One or more horizon columns cannot be normalized to site. Leaving site data unchanged.", call. = FALSE)
+    return(object)
+  }
+
   # if site data is already present, we don't overwrite/erase it
-  site_data <- merge(object@site, new_site_data, by = idname(object),
-                     all.x = TRUE, sort = FALSE)
+  site_data <- merge(object@site, new_site_data, by = idname(object), all.x = TRUE, sort = FALSE)
 
   # remove the named site data from horizon_data
   h <- object@horizons

tests/testthat/test-denormalize.R

@@ -9,15 +9,59 @@ depths(sp1) <- id ~ top + bottom
 sp1$sitevar <- round(runif(length(sp1)))
 
 test_that("denormalize result is 1:1 with horizons", {
-# use denormalize() to create a mirror of sitevar in the horizon table
-# name the attribute something different (e.g. `hz.sitevar`) to prevent collision with the site attribute
-# the attributes can have the same name but you will then need site() or horizons() to access explicitly
+  # use denormalize() to create a mirror of sitevar in the horizon table
+  # name the attribute something different (e.g. `hz.sitevar`) to prevent collision with the site attribute
+  # the attributes can have the same name but you will then need site() or horizons() to access explicitly
   sp1.hz.sitevar <- denormalize(sp1, 'sitevar')
 
   expect_error(sp1.hz.sitevar <- denormalize(sp1, 'foo'))
 
-# compare number of horizons to number of values in denormalize result
+  # compare number of horizons to number of values in denormalize result
   expect_equal(nrow(sp1), length(sp1.hz.sitevar)) # check that the output is 1:1 with horizon
 
   sp1$hz.sitevar <- sp1.hz.sitevar
 })
+
+test_that("round trip normalize/denormalize", {
+  library(aqp)
+
+  data(sp3)
+  depths(sp3) <- id ~ top + bottom
+
+  # create site var -- unique at site level
+  site(sp3)$foo <- profile_id(sp3)
+
+  # denormalize site var to horizon var (leaves foo in site)
+  expect_error({sp3$foo <- denormalize(sp3, "foo")})
+
+  # need to create a new variable for hz-denorm var
+  sp3$foo2 <- denormalize(sp3, "foo")
+
+  # inspect
+  plot(sp3, color="foo2")
+
+  # normalize to site (removes foo2 in horizon)
+  site(sp3) <- ~ foo2
+
+  # expected TRUE
+  expect_true(all(sp3$foo == sp3$foo2))
+  expect_true(all(sp3$foo2 == profile_id(sp3)))
+
+  # commence the breakin'
+
+  # make another `foo3`
+  sp3$foo3 <- denormalize(sp3, "foo")
+
+  # not appropriate for normalization (1:1 with horizon, not site)
+  sp3$foo4 <- 1:nrow(sp3)
+
+  # do that SPC dirty...
+  expect_warning(site(sp3) <- ~ foo3 + foo4)
+
+  # still valid
+  expect_true(spc_in_sync(sp3)$valid)
+
+  # didn't do anything
+  expect_equal(length(sp3$foo3), nrow(sp3))
+  expect_equal(length(sp3$foo4), nrow(sp3))
+})