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