feat: results are now returned as tbl_svy when derived from egor obje…

…ct with ego_design #3

R/composition.R

@@ -39,7 +39,9 @@ composition <- function(object, alt.attr, absolute = FALSE) {
       select(.egoID, tmp, prop) %>%
       tidyr::spread(tmp, prop)
   }
-  ungroup(comp(group_by(object$alter, .egoID)))
+  res <- ungroup(comp(group_by(object$alter, .egoID)))
+
+  return_results(object, res)
 }
 
 
@@ -94,7 +96,9 @@ comp_ply <-
     res <- tibble(.egoID = ego_id,
                   result.name = res)
     names(res) <- c(".egoID", result.name)
-    res
+
+    egor:::return_results(x = object, results = res)
+
   }
 
 #' Calculate diversity measures on an `egor` object.

R/count_dyads.R

@@ -1,9 +1,5 @@
 if (getRversion() >= "2.15.1")
-  utils::globalVariables(
-    c(
-      "dyads"
-    )
-  )
+  utils::globalVariables(c("dyads"))
 
 #' Count attribute combinations of dyads in ego-centered networks
 #'
@@ -22,7 +18,7 @@ if (getRversion() >= "2.15.1")
 #' count_dyads(object = egor32,
 #'             alter_var_name = "country")
 #'
-#' # Return result as long tibble. 
+#' # Return result as long tibble.
 #' count_dyads(object = egor32,
 #'             alter_var_name = "country",
 #'             return_as = "long")
@@ -46,22 +42,25 @@ count_dyads <-
 
     aaties_df$dyads <-
       purrr::map2_chr(aaties_df[[paste0(alter_var_name, "_src")]],
-               aaties_df[[paste0(alter_var_name, "_tgt")]],
-               ~ paste(sort(c(.x, .y)), collapse = "_"))
+                      aaties_df[[paste0(alter_var_name, "_tgt")]],
+                      ~ paste(sort(c(.x, .y)), collapse = "_"))
 
     res <- count(aaties_df, .egoID, dyads)
 
     if (return_as[1] == "wide") {
       if (is.null(prefix))
-        prefix <- paste0("dy_", substring(alter_var_name, 1, 3), "_")
-      tidyr::pivot_wider(
+        prefix <-
+          paste0("dy_", substring(alter_var_name, 1, 3), "_")
+      res <- tidyr::pivot_wider(
         res,
         .egoID,
         names_from = "dyads",
         values_from = n,
         names_prefix = prefix,
         values_fill = list(n = 0)
       )
+
+      return_results(object, res)
     }
     else
       res

R/density.R

@@ -2,21 +2,21 @@
 
 #' Calculate the relationship density in ego-centered networks
 #'
-#' This function uses an \code{egor} object and calculates the density of all 
-#' the ego-centered networks listed in the 'egor' object. Instead of an 
+#' This function uses an \code{egor} object and calculates the density of all
+#' the ego-centered networks listed in the 'egor' object. Instead of an
 #' \code{egor} object, alter and alter-alter data can be provided as \code{lists}
-#' or \code{data.frames}. 
+#' or \code{data.frames}.
 #' @template object
 #' @param max.netsize Optional parameter. Constant value used if the
 #' number of alters whose relations were collected is limited.
-#' @param directed logical indicating if the alter-alter relation data/ edges 
+#' @param directed logical indicating if the alter-alter relation data/ edges
 #' are directed or undirected.
 #' @param weight \code{Character} naming a variable containing the weight values
 #' of relations. Weights should range from 0 to 1.
 #' @template meth_dots
 #' @return returns a \code{vector} of network density values.
 #' @keywords ego-centered network analysis
-#' @examples 
+#' @examples
 #' data("egor32")
 #' ego_density(egor32)
 #' @export
@@ -26,32 +26,39 @@ ego_density <- function(object, ...) {
 
 #' @rdname ego_density
 #' @export
-ego_density.egor <- function(object, weight = NULL, max.netsize = NULL, directed = FALSE, ...) {
-  aatie_l <- aaties_by_ego(object)
-  if (!is.null(weight)) {
+ego_density.egor <-
+  function(object,
+           weight = NULL,
+           max.netsize = NULL,
+           directed = FALSE,
+           ...) {
+    aatie_l <- aaties_by_ego(object)
+    if (!is.null(weight)) {
+      dyaden_real <- map_dbl(aatie_l, function(x)
+        sum(x[[weight]]))
+
+    } else {
+      dyaden_real <- purrr::map_dbl(aatie_l, nrow)
+    }
 
-    dyaden_real <- map_dbl(aatie_l, function(x) sum(x[[weight]]))
 
-  } else {
-    dyaden_real <- map_dbl(aatie_l, nrow)
-  }
-
-
-  alter_l <- alters_by_ego(object)
-  netsize <- map_dbl(alter_l, nrow)
-
-  if (!is.null(max.netsize)) {
-    netsize[netsize > max.netsize] <- max.netsize
-  }
-
-  dyad_poss <- (netsize^2 - netsize)
-
-  if (!directed) {
-    dyad_poss <- dyad_poss / 2
+    alter_l <- alters_by_ego(object)
+    netsize <- purrr::map_dbl(alter_l, nrow)
+
+    if (!is.null(max.netsize)) {
+      netsize[netsize > max.netsize] <- max.netsize
+    }
+
+    dyad_poss <- (netsize ^ 2 - netsize)
+
+    if (!directed) {
+      dyad_poss <- dyad_poss / 2
+    }
+
+    density <- as.vector(dyaden_real / dyad_poss)
+    names(density) <- names(alter_l)
+    density[is.infinite(density)] <- NA
+    res <- tibble::enframe(density, name = ".egoID", value = "density")
+    res$.egoID <- as(res$.egoID, Class = class(object$alter$.egoID))
+    return_results(object, res)
   }
-
-  density <- as.vector(dyaden_real / dyad_poss)
-  names(density) <- names(alter_l)
-  density[is.infinite(density)] <- NA
-  tibble::enframe(density, name = ".egoID", value = "density")
-}

R/ego_constraint.R

@@ -37,5 +37,7 @@ ego_constraint <-
                 get.edge.attribute(., weights),
               nodes = V(.)[V(.)$name == "ego"]
             ))
-    enframe(res, ".egoID", "constraint")
+    res <- enframe(res, ".egoID", "constraint")
+    res$.egoID <- as(res$.egoID, Class = class(object$alter$.egoID))
+    return_results(object, res)
   }

R/ei.R

@@ -53,6 +53,8 @@ if(getRversion() >= "2.15.1")
 #' @importFrom tidyr complete
 #' @importFrom tibble as_tibble
 EI <- function(object, alt.attr) {
+  object_original <- object
+
   ei <- function(e, i)
     (e - i) / (e + i)
 
@@ -98,14 +100,14 @@ EI <- function(object, alt.attr) {
       filter(fact.x == fact | fact.y == fact) %>%
       count(homogen) %>%
       complete(homogen) %>%
-      replace_na(list(n = 0)) %>%
-      spread(homogen, n)
+      tidyr::replace_na(list(n = 0)) %>%
+      tidyr::spread(homogen, n)
   }
 
   alt.attr_enquo <- enquo(alt.attr)
 
   object <- 
-    map(object, ungroup)
+    purrr::map(object, ungroup)
 
   class(object) <- c("egor", class(object))
 
@@ -137,7 +139,7 @@ EI <- function(object, alt.attr) {
         return(res)
       }
 
-      map(y$fact, function(z) {
+      purrr::map(y$fact, function(z) {
         calc_grp_ei_tab(x, z)
       }) %>%
         bind_rows() %>%
@@ -159,9 +161,14 @@ EI <- function(object, alt.attr) {
     x %>%
       mutate(ei_sc = ei(E / poss_ext, I / poss_int)) %>%
       select(fact, ei_sc) %>%
-      spread(fact, ei_sc)
+      tidyr::spread(fact, ei_sc)
   })
 
-  #cat(paste0("EI-Index: " , substitute(alt.attr), "\n"))
-  bind_cols(.egoID = object$ego$.egoID, ei = a, b)
+  if(has_ego_design(object_original)) {
+    res <- bind_cols(.egoID = object$ego$variables$.egoID, ei = a, b)
+  } else {
+    res <- bind_cols(.egoID = object$ego$.egoID, ei = a, b)
+  }
+
+  return_results(object_original, res)
 }

R/helper.R

@@ -1,4 +1,5 @@
-if (getRversion() >= "2.15.1") utils::globalVariables(c(".egoID"))
+if (getRversion() >= "2.15.1")
+  utils::globalVariables(c(".egoID"))
 
 #' General helper functions
 #'
@@ -12,7 +13,7 @@ if (getRversion() >= "2.15.1") utils::globalVariables(c(".egoID"))
 #' @name helper
 NULL
 
-#' @describeIn helper Converts an egor object to a "legacy" egor object with 
+#' @describeIn helper Converts an egor object to a "legacy" egor object with
 #' nested .alts and .aaties columns.
 #' @export
 as_nested_egor <- function(x) {
@@ -25,13 +26,13 @@ as_nested_egor <- function(x) {
   if (has_ego_design(x)) {
     res$variables$.aaties <- aaties_l
     res$variables$.alts <- alters_l
-    }
+  }
   else {
     res <- x$ego
     res$.aaties <- aaties_l
     res$.alts <- alters_l
   }
-
+  
   class(res) <- c("nested_egor", class(res))
   res
 }
@@ -53,40 +54,46 @@ print.nested_egor <- function(x, ...) {
 #'   (possibly 0-row) of alters associated with each ego, in the same
 #'   order as the ego table.
 #' @export
-alters_by_ego <- function(x) UseMethod("alters_by_ego")
+alters_by_ego <- function(x)
+  UseMethod("alters_by_ego")
 #' @rdname helper
 #' @export
-alters_by_ego.egor <- function(x) split(x$alter, factor(x$alter$.egoID, levels = as_tibble(x$ego)$.egoID))
+alters_by_ego.egor <- function(x)
+  split(x$alter, factor(x$alter$.egoID, levels = as_tibble(x$ego)$.egoID))
 #' @rdname helper
 #' @export
-alters_by_ego.nested_egor <- function(x) as_tibble(x)$.alts
+alters_by_ego.nested_egor <- function(x)
+  as_tibble(x)$.alts
 
 #' @describeIn helper Splits the alter--alter ties table into a list of
 #'   tables (possibly 0-row) of alter--alter associated with each ego, in
 #'   the same order as the ego table.
 #' @export
-aaties_by_ego <- function(x) UseMethod("aaties_by_ego")
+aaties_by_ego <- function(x)
+  UseMethod("aaties_by_ego")
 #' @rdname helper
 #' @export
-aaties_by_ego.egor <- function(x) split(x$aatie, factor(x$aatie$.egoID, levels = as_tibble(x$ego)$.egoID))
+aaties_by_ego.egor <- function(x)
+  split(x$aatie, factor(x$aatie$.egoID, levels = as_tibble(x$ego)$.egoID))
 #' @rdname helper
 #' @export
-aaties_by_ego.nested_egor <- function(x) as_tibble(x)$.aaties
+aaties_by_ego.nested_egor <- function(x)
+  as_tibble(x)$.aaties
 
 #' @describeIn helper Returns the count of possible edges in an
 #' undirected or directed, ego-centered network, based on the number of alters.
 #' @export
 dyad.poss <- function(max.alters, directed = FALSE) {
-  dp <- (max.alters^2 - max.alters)
+  dp <- (max.alters ^ 2 - max.alters)
   if (!directed) {
-    dp <- dp/2 
+    dp <- dp / 2
   }
   dp
 }
 
-#' @describeIn helper Generates a \code{data.frame} marking possible dyads in 
-#' a wide alter-alter relation \code{data.frame}. Row names corresponds to the 
-#' network size. This is useful for sanitizing alter-alter relations in the wide 
+#' @describeIn helper Generates a \code{data.frame} marking possible dyads in
+#' a wide alter-alter relation \code{data.frame}. Row names corresponds to the
+#' network size. This is useful for sanitizing alter-alter relations in the wide
 #' format.
 #' @export
 sanitize.wide.edges <- function(max.alters) {
@@ -108,7 +115,7 @@ sanitize.wide.edges <- function(max.alters) {
   df
 }
 
-#' @describeIn helper Creates a \code{vector} of names for variables 
+#' @describeIn helper Creates a \code{vector} of names for variables
 #' containing data on alter-alter relations/ dyads in ego-centered networks.
 #' @export
 create_edge_names_wide <- function(x) {
@@ -127,24 +134,52 @@ create_edge_names_wide <- function(x) {
   names_
 }
 
-#' @describeIn helper Calculates the possible edges between members of 
+#' @describeIn helper Calculates the possible edges between members of
 #' different groups in an ego-centered network.
 #' @export
 dyads_possible_between_groups <- function(x, y, geometric = TRUE) {
-  if (geometric) sqrt(x*y)
-    else x*y
-  }
+  if (geometric)
+    sqrt(x * y)
+  else
+    x * y
+}
 
-#' @describeIn helper Calculates the optimal distribution of a number of 
-#' equally sized objects on a DIN-Norm DIN 476 (i.e. DIN A4) page in landscape 
+#' @describeIn helper Calculates the optimal distribution of a number of
+#' equally sized objects on a DIN-Norm DIN 476 (i.e. DIN A4) page in landscape
 #' view.
 #' @export
 din_page_dist <- function(x) {
   for (yps in 2:x) {
     ix <- x / yps
-    if (ix/yps <= sqrt(2)) {
-      break()  
+    if (ix / yps <= sqrt(2)) {
+      break()
     }
   }
-  c(x = ceiling(ix),y = ceiling(yps))
+  c(x = ceiling(ix), y = ceiling(yps))
 }
+
+#' Returns results inheriting `srvyr` design if the input egor object has a an
+#' `ego_design` and global option "egor.return.results.with.design" is `TRUE` or
+#' 'NULL'.
+return_results <-
+  function(x, results) {
+
+    join_results_with_design <-
+      function(x, results) {
+        if ("tbl_svy" %in% class(x$ego)) {
+          a <- ego_design(x)
+          a$variables <- dplyr::select(a$variables, .egoID)
+          a$variables <- dplyr::left_join(a$variables, results, by = ".egoID")
+          a
+        } else
+          results
+      }
+
+    errwd <- getOption("egor.return.results.with.design")
+
+    if (is.null(errwd) | isTRUE(errwd)) {
+      join_results_with_design(x, results)
+    } else {
+      results
+    }
+  }