1# Remove s4 classes created by this package.
2# This is only necessary if the package was loaded with devtools. If the
3# package was NOT loaded by devtools, it's not necessary to remove the
4# classes this way, and attempting to do so will result in errors.
5remove_s4_classes <- function(package) {
6  nsenv <- ns_env(package)
7  if (is.null(nsenv)) {
8    return()
9  }
10
11  classes <- methods::getClasses(nsenv, FALSE)
12  classes <- sort_s4classes(classes, package)
13  lapply(classes, remove_s4_class, package)
14}
15
16# Sort S4 classes for hierarchical removal
17# Derived classes must be removed **after** their parents.
18# This reduces to a topological sorting on the S4 dependency class
19# https://en.wikipedia.org/wiki/Topological_sorting
20sort_s4classes <- function(classes, package) {
21  nsenv <- ns_env(package)
22
23  sorted_classes <- vector(mode = 'character', length = 0)
24
25  ## Return the parent class, if any within domestic classes
26  extends_first <- function(x, classes) {
27    ext <- methods::extends(methods::getClass(x, where = nsenv))
28    parent <- ext[2]
29    classes %in% parent
30  }
31
32  ## Matrix of classes in columns, extending classes in rows
33  extended_classes <- vapply(
34    classes,
35    extends_first,
36    rep(TRUE, length(classes)),
37    classes
38  )
39
40  if (!is.matrix(extended_classes))
41    extended_classes <- as.matrix(extended_classes)
42
43  ## Dynamic set of orphan classes (safe to remove)
44  start_idx <- which(apply(extended_classes, 2, sum) == 0)
45
46  while (length(start_idx) > 0) {
47    ## add node to sorted list (and remove from pending list)
48    i <- start_idx[1]
49    start_idx <- utils::tail(start_idx, -1)
50    sorted_classes <- c(sorted_classes, classes[i])
51
52    ## check its derived classes if any
53    for (j in which(extended_classes[i, ])) {
54      extended_classes[i, j] <- FALSE
55      if (sum(extended_classes[, j]) == 0) {
56        start_idx <- c(start_idx, j)
57      }
58    }
59  }
60  if (any(extended_classes)) {
61    ## Graph has a cycle. This should not happen
62    ## Stop or try to continue?
63    idx <- !classes %in% sorted_classes
64    sorted_classes <- c(sorted_classes, classes[idx])
65  }
66
67  sorted_classes
68}
69
70# Remove an s4 class from a package loaded by devtools
71#
72# For classes loaded with devtools, this is necessary so that R doesn't try to
73# modify superclasses that don't have references to this class. For example,
74# suppose you have package pkgA with class A, and pkgB with class B, which
75# contains A. If pkgB is loaded with load_all(), then class B will have a
76# reference to class A, and unloading pkgB the normal way, with
77# unloadNamespace("pkgB"), will result in some errors. They happen because R
78# will look at B, see that it is a superclass of A, then it will try to modify
79# A by removing subclass references to B.
80#
81# This function sidesteps the problem by modifying B. It finds all the classes
82# in B@contains which also have references back to B, then modifes B to keep
83# references to those classes, but remove references to all other classes.
84# Finally, it removes B. Calling removeClass("B") tells the classes referred to
85# in B@contains to remove their references back to B.
86#
87# It is entirely possible that this code is necessary only because of bugs in
88# R's S4 implementation.
89#
90# @param classname The name of the class.
91# @param package The package object which contains the class.
92remove_s4_class <- function(classname, package) {
93  nsenv <- ns_env(package)
94
95  # Make a copy of the class
96  class <- methods::getClassDef(classname, package = package, inherits = FALSE)
97
98  # If the class is not defined in this package do not try to remove it
99  if (!identical(class@package, package)) {
100    return()
101  }
102
103  # Find all the references to classes that (this one contains/extends AND
104  # have backreferences to this class) so that R doesn't try to modify them.
105  keep_idx <- contains_backrefs(classname, package, class@contains)
106  class@contains <- class@contains[keep_idx]
107
108  # Assign the modified class back into the package
109  methods::assignClassDef(classname, class, where = nsenv, force = TRUE)
110
111  # Remove the class, ignoring failures due to potentially locked environments.
112  tryCatch(methods::removeClass(classname, where = nsenv), error = function(e) NULL)
113}
114
115
116# Given a list of SClassExtension objects, this returns a logical vector of the
117# same length. Each element is TRUE if the corresponding object has a reference
118# to this class, FALSE otherwise.
119contains_backrefs <- function(classname, pkgname, contains) {
120
121  # If class_a in pkg_a has class_b in pkg_b as a subclass, return TRUE,
122  # otherwise FALSE.
123  has_subclass_ref <- function(class_a, pkg_a, class_b, pkg_b) {
124    x <- methods::getClassDef(class_a, package = pkg_a)
125    if (is.null(x)) return(FALSE)
126
127    subclass_ref <- x@subclasses[[class_b]]
128
129    if (!is.null(subclass_ref) && subclass_ref@package == pkg_b) {
130      return(TRUE)
131    }
132
133    FALSE
134  }
135
136  if (length(contains) == 0) {
137    return()
138  }
139
140  # Get a named vector of 'contains', where each item's name is the class,
141  # and the value is the package.
142  contain_pkgs <- sapply(contains, "slot", "package")
143
144  mapply(has_subclass_ref, names(contain_pkgs), contain_pkgs, classname, pkgname)
145}
146