prep for seqSOM 1

maraab23 · Nov 22, 2024 · 21eb2c4 · 21eb2c4
1 parent d9247b2
commit 21eb2c4
Show file tree

Hide file tree

Showing 3 changed files with 35 additions and 16 deletions.
diff --git a/R/ggseqdplot.R b/R/ggseqdplot.R
@@ -151,8 +151,11 @@ ggseqdplot <- function(seqdata,
     cli::cli_warn(c("i" = "group vector {.arg {group_name}} is of class {.cls haven_labelled} and has been converted into a factor"))
   }
 
+  # seSOM prep by G. Ritschard: take care of empty groups
+  drop <- TRUE
+  if ("drop" %in% names(list(...))) drop <- list(...)[["drop"]]
   if (is.factor(group)) {
-    group <- forcats::fct_drop(group)
+    if (isTRUE(drop)) group <- forcats::fct_drop(group)
     grinorder <- levels(group)
   } else {
     grinorder <- factor(sort(unique(group)))
@@ -209,7 +212,7 @@ ggseqdplot <- function(seqdata,
                        labels = attributes(seqdata)$labels
         ),
         state = forcats::fct_na_value_to_level(.data$state,
-                                                level = "Missing"
+                                               level = "Missing"
         ),
         state = forcats::fct_drop(.data$state, "Missing"), # shouldn't be necessary
         state = forcats::fct_rev(.data$state)
@@ -372,3 +375,4 @@ ggseqdplot <- function(seqdata,
 
   return(ggdplot)
 }
+
diff --git a/R/ggseqiplot.R b/R/ggseqiplot.R
@@ -148,8 +148,10 @@ ggseqiplot <- function(seqdata,
     cli::cli_warn(c("i" = "group vector {.arg {group_name}} is of class {.cls haven_labelled} and has been converted into a factor"))
   }
 
+  drop <- TRUE
+  if ("drop" %in% names(list(...))) drop <- list(...)[["drop"]]
   if (is.factor(group)) {
-    group <- forcats::fct_drop(group)
+    if (isTRUE(drop)) group <- forcats::fct_drop(group)
     grinorder <- levels(group)
   } else {
     grinorder <- factor(sort(unique(group)))
@@ -205,7 +207,7 @@ ggseqiplot <- function(seqdata,
                         labels = attributes(seqdata)$labels
         ),
         states = forcats::fct_na_value_to_level(.data$states,
-                                          level = "Missing"
+                                                level = "Missing"
         ),
         states = forcats::fct_drop(.data$states, "Missing") # shouldn't be necessary
       ) |>
@@ -264,20 +266,19 @@ ggseqiplot <- function(seqdata,
       )
     )
 
-
   ylabspec <- purrr::map(
     grinorder,
     ~ dt2 |>
       dplyr::filter(.data$group == .x) |>
       dplyr::summarise(
         group = dplyr::first(.data$group),
-        maxwgt = max(.data$end),
+        maxwgt = max(.data$end, 0, na.rm=TRUE), ##gr to avoid a warning
+        #maxwgt = max(.data$end),
         nseq = dplyr::n_distinct(.data$idnew)
       )
   ) |>
     dplyr::bind_rows()
 
-
   scalebreaks <- purrr::map(
     grinorder,
     ~ ybrks |>
@@ -293,7 +294,10 @@ ggseqiplot <- function(seqdata,
       dplyr::pull()
   )
 
-  grsize <- purrr::map(scalelabels, max)
+  #grsize <- purrr::map(scalelabels, max) ## warning when x has only NAs
+  max0 <- function(x){max(0,x,na.rm=TRUE)} ## max0 to avoid warning
+  grsize <- purrr::map(scalelabels, max0)
+  grsize <- lapply(grsize, function(x){ifelse(x==0, NA, x)}) ## gr turning 0 back to NA
 
   scalelabels <- purrr::map(
     scalelabels,
@@ -318,6 +322,7 @@ ggseqiplot <- function(seqdata,
     ~ .x[.y]
   )
 
+
   if (facet_scale == "fixed") {
     maxyidx <- purrr::map(scalebreaks, max) |>
       unlist() |>
@@ -338,6 +343,7 @@ ggseqiplot <- function(seqdata,
     )
   )
 
+  ylabspec$group <- levels(group) ##gr because empty groups were labelled NA
 
   if (nrow(ylabspec) == 1 & weighted == TRUE) {
     ylabspec <- glue::glue("{ylabspec$nseq} sequences",
@@ -351,6 +357,8 @@ ggseqiplot <- function(seqdata,
     ylabspec <- glue::glue("{ylabspec$group} (n={ylabspec$nseq})")
   }
 
+  grinorder <- factor(grinorder, levels = levels(group)) ##gr
+
   grouplabspec <- dplyr::tibble(
     group = forcats::fct_inorder(grinorder),
     grouplab = forcats::fct_inorder(ylabspec)
@@ -404,7 +412,8 @@ ggseqiplot <- function(seqdata,
     dplyr::mutate(
       aux = .data$right - .data$left,
       aux2 = .data$aux,
-      aux = ifelse(.data$aux == 0, 1, .data$aux)
+      aux = ifelse(.data$aux == 0, 1, .data$aux),
+      aux = ifelse(is.na(.data$aux), 0, .data$aux) ## gr
     ) |>
     tidyr::uncount(.data$aux) |>
     dplyr::select(-"aux") |> #.data$aux
@@ -418,10 +427,10 @@ ggseqiplot <- function(seqdata,
 
 
   dt2 <- dt2 |>
-      dplyr::mutate(x = rep(factor(1:length(attributes(seqdata)$names)),
-                            length.out = nrow(dt2)),
-                    left = .data$left +.5,
-                    right = .data$right +.5)
+    dplyr::mutate(x = rep(factor(1:length(attributes(seqdata)$names)),
+                          length.out = nrow(dt2)),
+                  left = .data$left +.5,
+                  right = .data$right +.5)
 
 
   if (border == FALSE) {
@@ -518,6 +527,5 @@ ggseqiplot <- function(seqdata,
       )
   )
 
-
   return(ggiplot)
 }
diff --git a/R/zzz.R b/R/zzz.R
@@ -1,6 +1,13 @@
+# both don't work
 .onLoad  <- function(libname, pkgname) {
 
-  requireNamespace("TraMineR", quietly = TRUE)
-
+  suppressPackageStartupMessages(requireNamespace("TraMineR", quietly = TRUE))
+  suppressPackageStartupMessages(library(TraMineR, quietly = TRUE))
 }
 
+
+.onAttach <- function(libname, pkgname) {
+
+  suppressPackageStartupMessages(requireNamespace("TraMineR", quietly = TRUE))
+  suppressPackageStartupMessages(library(TraMineR, quietly = TRUE))
+}