1. Worum geht es?

Naja, ums Schreiben von Funktionen in der Programmiersprache R.

1.1. Was sind Funktionen?

  • Funktionen sind Programmkonstrukte, mit denen Du Teile des von Dir geschriebenen Codes wiederverwenden kannst (siehe Wikipedia).

  • Funktionen sind in den Standardbibliotheken jeder Programmiersprache vorhanden, viele R-Funktionen kennst Du wahrscheinlich schon: sum(), mean() oder summary().

1.2. Warum Funktionen?

  • Damit Du Teile des von Dir geschriebenen Codes wiederverwenden kannst.

  • Damit Du, wenn Du Fehler im Code entdeckst, diese auch nur an einer Stelle korrigieren musst.

1.3. Wann Funktionen?

Immer wenn Du merkst, dass Du (alten) Code mehrfach kopierst und an anderer Stelle einfügst ohne ihn stark zu verändern, solltest Du darüber nachdenken, eine (oder mehrere) Funktion(en) aus ihm zu machen.

2. Eine Funktion schreiben

2.1. Eine neue Summenfunktion

Warum wir diese Funktion nicht schreiben sollten

Eine Summenfunktion gibt es wahrscheinlich in jeder Programmiersprache, in R heißt sie sum(). Diese Funktion ist besser, stabiler und schneller, als alles, das wir selbst programmieren können.

Warum wir es trotzdem tun

Nunja, irgendwelchen Code müssen wir ja nehmen. Ich habe die Summenberechnung ausführlich als Beispiel zur Schleifenprogrammierung in Programmieren in R benutzt, und eine Wiederholung schadet sicher nicht.

2.1.1. Vom Code …

a  <- c(2, 3, 4, 10) # <1>
value <- 0 # <2>
for (a_i in a) { # <3>
    value <- value + a_i  # <4>
}
print(value) # <5>
## [1] 19

Dabei siehst Du:

  1. Definition des zu summierenden Vektors

  2. Definition des zur Addition neutralen Elementes

  3. Schleife über die Elemente des Vektors

  4. Addition des aktuellen Vektorelementes zum Ergebnis

  5. Ausgabe des Ergebnisses

2.1.2. … zur Funktion

Für meine Summenfunktion will ich die Definition des zu summierenden Vektors der Anwenderin überlassen (alles andere wäre auch sehr seltsam, wer braucht eine Funktion, die immer die Zahl 19 ausgibt?), daher wird der Vektor zu einem Argument der Funktion. Ich wähle als Namen für das Argument jetzt x (das könnte aber auch a bleiben, das ist eine Frage der Konvention, und unter x verstehen wir meist eine Unbekannte). Und als Ausgabe verwende ich keine Druck- sondern eine Rückgabefunktion (return() statt print()). Das Ergebnis sieht dann so aus:

my_sum <- function(x) {
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}

Dabei habe ich mehrere Dinge getan, beispielsweise einen ziemlich miesen Namen für meine Funktion gewählt. Im Wesentlichen aber habe ich:

2.2. Scoping

Programmiersprachen kennen für Objekte unterschiedliche Gültigkeitsbereiche (englisch "scope"), wir sehen uns das am Beispiel an:

2.2.1. Schreibzugriffe

Ausgangszustand

Im Augenblick hat das Objekte value den Wert 19:

print(value)
## [1] 19
Funktionsausführung

Jetzt wenden wir unsere Summenfunktion an und berechnen die Summe eines anderen Vektors:

print(my_sum(1:3))
## [1] 6

Das Objekt value behält seinen Wert:

print(value)
## [1] 19

Und das, obwohl wir innerhalb der Funktion dem Objekt value in der ersten Zeile den Wert 0 zuweisen und diesen dann in der Schleife mit den Werten 1, 3 und 6 überschreiben: R verwaltet automatisch die Gültigkeitsbereiche aller Objekte. Es gibt daher ein Objekt names value außerhalb der Funktion, das den Wert 19 enthält und unverändert bleibt. Innerhalb der Funktion legt R ein neues lokales Objekt, ebenfalls mit dem Namen value, an. Du kannst auch aus einer Funktion in einen anderen Gültigkeitsbereich schreiben, wenn Du das wirklich willst.

2.2.2. Lesezugriffe

Lesen ist unsicher

Mit dem Namen eines Objektes wird dieses gelesen. Innerhalb einer Funktion sucht R zunächst nach einem lokalen Objekt des gesuchten Namens, dann in den der Funktion übergeordneten Gültigkeitsbereichen, also außerhalb der Funktion.

Das kann zu unerwünschten Nebeneffekten führen. Stell Dir vor, Du kommentierst beim Schreiben der Summenfunktion die Definition des zur Addition neutralen Elementes aus Versehen aus:

my_sum_broken <- function(x) {
    # FIXME: this is accidentally commented out:
    # value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}

Du führst die Funktion aus und erhältst:

print(my_sum_broken(1:3))
## [1] 25

Was ist passiert? Im ersten Durchlauf der Schleife gibt es beim Lesen von value noch kein lokales Objekt dieses Namens. Daher sucht R außerhalb der Funktion und findet ein Objekt mit dem Wert 19. Zu diesem Objekt addieren wir x_i, das im ersten Schleifendurchlauf den Wert 1 enthält und erschaffen damit in der Funktion ein lokales Objekt names value, das dann im zweiten Durchlauf der Schleife auch gelesen werden kann.

Wenn Du diese Funktion verwendest, ohne vorher das Objekt value zu definieren, oder das Objekt value entfernst und dann die Funktion ausführst

rm(value)
print(my_sum_broken(1:3))
## Error in my_sum_broken(1:3): object 'value' not found

erhälst Du einen Fehler, weil R auch außerhalb der Funktion kein Objekt names value finden kann. Und diesen Fehler erwarten wir ja eigentlich, wenn wir nur die Funktion betrachten: sie ist fehlerhaft.

Sicherer Lesen

Wie wir eine Funktion dazu bringen können, außerhalb ihres Gültigkeitsbereiches zu schreiben (nein, das wie habe ich Dir noch nicht gezeigt), so können wir eine Funktion auch zwingen, beim Lesen nur nach lokalen Objekten zu suchen:

my_sum_safer <- function(x) {
    for (x_i in x) {
        value <- get("value", inherits = FALSE) + x_i
    }
    return(value)
}

Selbst wenn wir ein Objekt namens value anlegen, gibt die Funktion nun einen Fehler aus:

value <- 42
my_sum_safer(1:10)
## Error in get("value", inherits = FALSE): object 'value' not found

Ich finde es aber praktikabler, beim Schreiben einer Funktion darauf zu achten, welche Objekte ich lese.
Und wenn Du Funktionen testest, findest Du Fehler, die auf Scoping beruhen, sehr schnell.

2.2.3. Arbeiten mit Gültigkeitsbereichen

Ein Befehl, mit dem Du alle Objekte Deines aktuellen Arbeitsbereiches löschen kannst (entsprechend dem RStudio-Knopf mit dem Besensymbol [1]), lautet:

rm(list = ls(all.names = TRUE))

Nun bin ich vergesslich, weshalb ich mir die Syntax schlecht merken kann und lieber eine Funktion (aber keinen Knopf) hätte. Da "der aktuelle Arbeitsbereich" ein Gültigkeitsbereich (in R heißen die Gültigkeitsbereiche "environments", in S hießen sie "frames") ist und die Funktionen ls und rm nur in einem Gültigkeitsbereich arbeiten, funktioniert das naheliegende

wipe_clean <- function() {
    rm(list = ls(all.names = TRUE))
}

nicht:

wipe_clean(); ls()
## [1] "a"             "a_i"           "my_sum"        "my_sum_broken"
## [5] "my_sum_safer"  "value"         "wipe_clean"

Wenn ich den Gültigkeitsbereich explizit

wipe_clean <- function() {
    rm(list = ls(name = parent.frame(), all.names = TRUE), envir = parent.frame())
}

angebe, tut die Funktion, was ich wollte:

wipe_clean(); ls()
## character(0)

2.3. Argumente

Funktionen kennen Argumente, am besten nicht zu viele (siehe zum Beispiel [cc]). Unsere Summenfunktion kennt beispielsweise eines, nämlich den Vektor, den sie summieren soll. Der ist also ein obligatorisches Element, er sollte keine Voreinstellung haben (und hat auch keine).

Eine Funktion, die, wie wipe_clean, kein Argument kennt, ist Folgende:

memory_hogs <- function() {
    z <- sapply(ls(envir = parent.frame()),
                function(x) object.size(get(x, envir = parent.frame())))
    return(z)
}

Diese Funktion gibt mir für jedes Objekt des Gültigkeitsbereiches, in dem ich sie aufrufe, den Speicherverbrauch aus.

va <- rep(mtcars, 1)
vb <- rep(mtcars, 1000)
vc <- rep(mtcars, 2000)
vd <- rep(mtcars, 100)
memory_hogs()
## memory_hogs          va          vb          vc          vd
##        7896        4424     3520824     7040824      352824

Bei so wenigen Objekten erkenne ich leicht, dass vc der größte Speicherfresser ist und ich, falls mir der Speicher platzt und ich vc nicht mehr unbedingt brauche, vc löschen sollte.

Aber wenn ich viele Objekte habe, wäre es doch schön, ein optionales Funktionsargument zu haben, das in seiner Voreinstellung die Ausgabe nach Größe des Speicherbedarfs sortiert:

Ein Steuerargument
memory_hogs <- function(order = TRUE) {
    z <- sapply(ls(envir = parent.frame()),
                function(x) object.size(get(x, envir = parent.frame())))
    if (isTRUE(order)) z <- z[order(z)]
    return(z)
}
memory_hogs()
##          va memory_hogs          vd          vb          vc
##        4424       10120      352824     3520824     7040824

Das ist ein klassisches (optionales) Steuerargument, das das Verhalten einer Funktion steuert. Steuerargumente sollten eine sinnvolle Voreinstellung haben.

Da die memory_hogs intern nun die Funktion order aufruft, könnten wir ja auf die Idee kommen, dieser Funktion Argumente weiterreichen zu wollen. Das können wir entweder explizit tun, oder wir benutzen ein spezielles, Ellipsis genanntes Argument, das durch drei Punkte (...) aufgerufen wird:

Ellipsis I
memory_hogs <- function(...) {
    z <- sapply(ls(envir = parent.frame()),
                function(x) object.size(get(x, envir = parent.frame())))
    if (! missing(...)) {
      z <- z[order(z, ...)]
    }
    return(z)
}
memory_hogs()
## memory_hogs          va          vb          vc          vd
##       13624        4424     3520824     7040824      352824
memory_hogs(decreasing = TRUE)
##          vc          vb          vd memory_hogs          va
##     7040824     3520824      352824       50624        4424

Jetzt können wir die Rückgabe unserer Funktion nutzen, um die beiden größten Speicherfresser zu löschen:

rm(list = names(memory_hogs(decreasing = TRUE)[1:2]))
memory_hogs()
## memory_hogs          va          vd
##       50624        4424      352824

Wir können also, wenn wir wollen, drei Arten von Argumenten unterscheiden:

  • Obligatorische. Sie kennen keine Voreinstellungen und übergeben üblicherweise Objekte, die von der Funktion verarbeitet werden sollen. Der zu summierende Vektor x in my_sum ist ein klassisches Beispiel: ein Voreinstellung für die zu summiernden Zahlen (etwa x = c(40, 2)) ist unsinnig.

  • Optionale. Sie haben Voreinstellungen und dienen üblicherweise der Steuerung der Funktion. Das Argument order in memory_hogs ist ein klassisches Beispiel: in der Voreinstellung wird die Ausgabe nach Speicherverbrauch sortiert.

  • Die Ellipsis, um Argumente an andere Funktionen weiterzureichen.

2.4. Return Value und Side Effects

Jede Funktion in R gibt einen Wert zurück, falls sie nicht mit einem Fehler abbricht. Wenn wir keinen Rückgabewert (return value) explizit angeben, ist er automatisch der Wert des letzten in der Funktion ausgewerteten Ausdrucks (siehe ?expression), oder, falls die Funktion keinen Ausdruck hat, NULL (siehe ?return), compris? Es ist daher sicher nicht schlecht, wenn Du versucht, den Rückgabewert jeder Funktion explizit anzugeben. Wenn Du die auf die explizite Rückgabe verzichtest ist Deine Funktion zwar (um eine Zeile) kürzer und inhaltsgleich, aber weniger sprechend. Und damit weniger gut lesbar. Und damit mehr schlechter als eine Zeile kürzer mehr besser ist, capisce?

Komplexere Funktionen haben oft Nebenwirkungen (side effects). Bei vielen dieser Funktionen sind die Nebenwirkungen der eigentliche Zweck der Funktion, manchmal ist der Rückgabewert sogar belanglos. Die Funktion rm gibt beispielsweise unsichtbar NULL zurück (und das selbst dann, wenn es gar nichts zu löschen gibt). Das erkennen wir, wenn wir ihren Rückgabewert explizit drucken:

a <- "This is a string"
print(rm(a))
## NULL
print(rm())
## NULL

Das heißt also, dass unsere Funktion wipe_clean den Wert invisible(NULL), zurückgibt, denn das war der Wert des letzten in ihr ausgewerteten Ausdrucks (der Aufruf der Funktion rm).

Das können wir ändern, indem wir einen expliziten Rückgabewert einbauen (bei der Gelegenheit wandeln wir gleich noch den Gültigkeitsbereich, indem die Funktion löscht, in ein Steuerargument mit Voreinstellung um):

wipe_clean <- function(environment = parent.frame()) {
    objects <- ls(name = environment, all.names = TRUE)
    rm(list = objects, envir = environment)
    return(invisible(objects))
}
print(wipe_clean())
## [1] "memory_hogs" "va"          "vd"          "wipe_clean"
ls()
## character(0)

Jetzt gibt die Funktion die Namen der von ihr gelöschten Objekte zurück. Wir wissen also, wie hieß, was wir gelöscht haben. Damit können wir zwar nichts mehr anfangen, aber die Funktion hat nun genau einen expliziten Endpunkt. Das ist immerhin schön übersichtlich.

Exkurs: Komplexe Rückgabewerte
Rückgabewerte können auch komplex sein. Stell Dir vor, Du wolltest für einen Vektor verschiedene statistische Kennwerte berechen. Eine Funktion könnte so aussehen:
stats <- function(x) {
    m <- mean(x)
    v <- var(x)
    r <- range(x)
    value <- list(date = Sys.time(), data = x, mean = m, variance = v, range = r)
    return(value)
}
stats(rnorm(100))
## $date
## [1] "2021-11-30 12:33:24 CET"
##
## $data
##   [1]  1.608717119 -0.348743814 -0.635374246 -0.595049069  0.624690650
##   [6] -0.094654327 -0.331659501 -1.548394124 -0.749738425  0.965900514
##  [11] -0.238325926  1.325856317  0.318390694 -0.828176291 -0.160789034
##  [16] -0.186310247 -0.899753876  1.032156233  0.194925645  1.342144159
##  [21] -1.272001761 -0.659447446  0.072235139 -0.171629632 -1.133711628
##  [26] -0.839506146  0.618306442  0.327982217  0.753849244  0.817425363
##  [31]  0.776762225  1.152896246 -0.591680342  0.312085146 -0.820945884
##  [36]  1.057346467  0.810585612 -0.307261831 -0.003211322  0.379046796
##  [41]  1.289463581 -0.794753610  1.021488598 -0.979595961 -0.555138862
##  [46]  1.196570713 -1.057261195  0.646887550 -1.309789510 -1.431403842
##  [51]  0.645884196  1.500021485 -0.527206848  0.066339809  0.342632450
##  [56] -0.903944499  0.764868629  1.304190732  0.307178790  0.085966255
##  [61] -0.186824390 -0.415523871  0.568882532 -0.596513094 -1.267735819
##  [66] -1.140913212 -0.676122066  1.090393000  1.598231679 -0.576062980
##  [71]  0.505100039  0.193585761 -0.568702277 -0.131212042  0.013822816
##  [76]  0.215477177 -0.570426537  0.291797224 -0.182730284  1.975718009
##  [81]  2.504349772 -0.492917124 -0.882037637  0.141725865  0.952791562
##  [86]  0.422837636 -0.403140152 -1.076726671  0.947389067 -0.785610469
##  [91] -0.186292839  0.421394471 -1.749994778  1.522665722  0.596301891
##  [96]  0.442100825  0.196670760 -0.447817096  0.596920448 -0.078782167
##
## $mean
## [1] 0.06469407
##
## $variance
## [1] 0.7438964
##
## $range
## [1] -1.749995  2.504350

Die Rückgabe einer Liste ist unter statistischen Funktionen (stats::lm, stats::glm, mgcv::gam, …) verbreitet.

2.5. Funktionen verwalten

2.5.1. Im jeweiligen Skript

Ich schreibe viele Funktionen während Datenauswertungen, sie landen dann erstmal im jeweiligen Auswertungsskript. Manchmal sammele ich sie an dessen Beginn, meist lege ich sie aber gleich lokal ab.

2.5.2. Lokal

Viele meiner wissenschaftlichen Projekte haben im R-Skript-Verzeichnis ein Unterverzeichnis mit dem Namen ./functions. Darin lege ich die Funktionen, die ich in den Skripten des Projektes schreibe, ab. Wichtige Funktionen kommen in eigene Dateien, die nach ihnen benannt sind, andere sammele ich, beispielsweise in ./functions/utils.R oder ./functions/misc.R.

Jedes Auswertungsskript hat dann am Beginn die Zeilen

for (f in dir("./functions/", full.names = TRUE, pattern = ".*\\.[rR]$")) {
    source(f)
}

2.5.3. Global

Funktionen, die Du nicht nur in einem Projekt nutzen willst, kannst Du zentral verwalten, in dem Du Dateien wie im Abschnitt lokal beschrieben ablegst, nur mit dem Unterschied, dass Du ein zentrales Verzeichnis benutzt. Dann fügst Du in eine Deiner R-Startup-Dateien die Anweisung

for (f in dir("/full/path/to/functions_directory/",
              full.names = TRUE, pattern = ".*\\.[rR]$")) {
    source(f)
}

ein und den passt "/full/path/to/functions_directory/" an. Geeignte R-Startup-Dateien verrät Dir die R-Hilfe ?Startup oder der Code:

candidates <- c( Sys.getenv("R_PROFILE"),
                 Sys.getenv("R_PROFILE_USER"),
                 file.path(Sys.getenv("R_HOME"), "etc", "Rprofile.site"),
                 file.path(Sys.getenv("HOME"), ".Rprofile"),
                 file.path(getwd(), ".Rprofile") )

Filter(file.exists, candidates)

2.5.4. Als Paket

Wenn Du Dir die Mühe machst, Deine Funktionen zu dokumentieren, kannst Du sie eigentlich auch gleich in einem oder mehreren Paketen verwalten. Das ist am elegantesten.

3. Schöner Programmieren

3.1. Argumententests

Wir haben verschiedene Möglichkeiten, die Objekte, die wir den Argumenten einer Funktion übergeben, zu testen.

3.1.1. Typentests

Wir können Objekte darauf testen, ob sie einem bestimmten Typ (einer Klasse) angehören; bei Objekten, die einer Funktion als Argument übergeben werden ist dies besonders ratsam. Das geht in reinen base R, ist aber eher umständlich, die Vignette zu checkmate bietet ein anschauliches Bespiel.

Ich kenne zwei Pakete, die Typentest vereinfachen: assertthat und checkmate

  • checkmate ist hauptsächlich in C geschrieben, sehr schnell, sehr flexibel mit unterschiedlichen Testarten ("checks", "asserts" und "tests"), hat aber viele Abhängigkeiten und ist etwas sperrig: sein Manual ist über 100 Seiten lang.

  • assertthat ist reines R ohne irgendwelche Abhängigkeiten und recht übersichtlich.

assertthat ist sehr einfach:

x <- 6
assertthat::assert_that(is.numeric(x))
## [1] TRUE
x <- "This is a string."
assertthat::assert_that(is.numeric(x))
## Error: x is not a numeric or integer vector
Was haben wir davon?

Wenn wir unserer Summenfunktion

my_sum <- function(x) {
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}

ein nicht-numerisches Argument übergeben, erhalten wir eine recht kryptische Fehlermeldung:

my_sum(c("a", "b"))
## Error in value + x_i: non-numeric argument to binary operator

Durch den Einbau eines Typentests

my_sum <- function(x) {
    assertthat::assert_that(is.numeric(x))
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}

wird die Meldung deutlich verständlicher:

my_sum(c("a", "b"))
## Error: x is not a numeric or integer vector

Mit checkmate können wir sogar erzwingen, dass x nicht nur numerisch sein muss, sondern auch mindestens zwei Elemente haben soll. Eine Summe einer Zahl ist ja etwas albern:

my_sum <- function(x) {
    checkmate::qassert(x, "n>=2")
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}
my_sum(42)
## Error in my_sum(42): Assertion on 'x' failed. Must be of length >= 2, but has length 1.

Ich nutze Typentests oft in Funktionen. Da checkmate deutlich mehr Funktionalität bietet, nutzte ich assertthat eher selten.

3.1.2. Auswahllisten

Mit Auswahllisten können wir Objekte darauf testen, ob sie eine von mehreren Möglichkeiten enthalten. Das ist vor allem für Steuerargumente hilfreich. base R kennt match.arg, das mit alphanumerischen Vektoren arbeitet und einfach das Objekt zurückgibt, wenn es in der Auswahlliste enthalten ist:

noten <-  c("sehr gut", "gut", "nicht soo gut", "das kann auf jeden Fall noch besser werden")
note  <- "gut"
match.arg(arg = note, choices = noten)
## [1] "gut"

Dabei bedient es sich dem "partial matching", das heißt, dass ein eindeutig einer Auswahlmöglichkeit zuzuordnender Anfang einer Zeichenkette ausreicht:

note  <- "das"
match.arg(arg = note, choices = noten)
## [1] "das kann auf jeden Fall noch besser werden"

Wird kein Treffer in der Auswahlliste gefunden, erhalten wir einen Fehler:

note  <- "ausreichend"
match.arg(arg = note, choices = noten)
## Error in match.arg(arg = note, choices = noten): 'arg' should be one of "sehr gut", "gut", "nicht soo gut", "das kann auf jeden Fall noch besser werden"

match.arg ist genau, was hinter Steuerargumenten vieler Funktionen (z.b. mgcv::gam(optimizer = …)) steckt, hier ein Beispiel aus der Hilfe zu match.arg:

center <- function(x, type = c("mean", "median", "trimmed")) {
    type <- match.arg(type)
    switch(type,
           mean = mean(x),
           median = median(x),
           trimmed = mean(x, trim = .1))
}
center(rnorm(100), "med")
## [1] 0.08940291
center(rnorm(100), "m")
## Error in match.arg(type): 'arg' should be one of "mean", "median", "trimmed"

checkmate kennt auch Auswahllisten, macht aber kein partial matching (was ich ganz gut finde):

note  <- "das"
checkmate::assertChoice(x = note, choices = noten)
## Error in eval(expr, envir, enclos): Assertion on 'note' failed: Must be element of set {'sehr gut','gut','nicht soo gut','das kann auf jeden Fall noch besser werden'}, but is 'das'.

Außerdem gibt checkmate die gefundene Rückgabe unsichtbar zurück, weshalb ich hier ein explizites print benötige:

note  <- "gut"
checkmate::assertChoice(x = note, choices = noten)
print(checkmate::assertChoice(x = note, choices = noten))
## [1] "gut"

checkmate kann nicht nur mit alphanumerischen Vektoren umgehen:

x <- 3
choices <- 1:7
print(checkmate::assertChoice(x = x, choices = choices))
## [1] 3

Ich nutze Auswahllisten eher selten, da ich selten Steuerargumente mit mehreren Auswahlmöglichenkeiten in meinen Funktionen habe.

3.2. Funktionen testen

3.2.1. Unit Testing

Beim Unit Testing wollen wir nicht die einer Funktion übergebenen Argumente, sondern die Funktion selbst testen. Also im Zweifel ihren Rückgabewert.

Ich kenne zwei Pakete, die Unit Testing in R formalisieren (im Prinzip geht es auch ohne spezielle Pakete, aber seit ich die beiden Pakete kenne, habe ich nie mehr wie früher "von Hand" getestet):

  • RUnit gibt es schon seit 2004, es ist sehr formal und hat wenige Abhängigkeiten (daher bevorzuge ich es beim Testen von Paketen).

  • testthat finde ich interaktiv einfacher anzuwenden.

Erwartungen

Die kleinste Testeinheit ist immer ein Vergleich.

Wenn wir die Funktionen

my_sum <- function(x) {
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}
und
not_my_sum <- function(x) {
    value <- 0
    for (x_i in x) {
        value <- value - x_i
    }
    return(value)
}

haben, können wir zum Beispiel mit base R prüfen, ob sie tun, was wir erwarten:

my_sum(c(2, 7)) == 9
## [1] TRUE
# better use identical(), see ?Comparison
identical(not_my_sum(c(2, 7)), 9)
## [1] FALSE

Beide Pakete formalisieren dies zu Erwartungsfunktionen die hauptsächlich dazu dienen, Fehler zu beschreiben:

RUnit::checkIdentical(not_my_sum(c(2, 7)), 9)
## Error in RUnit::checkIdentical(not_my_sum(c(2, 7)), 9): FALSE
##
testthat::expect_identical(not_my_sum(c(2, 7)), 9)
## Error in cat(unlist(cond)): argument 1 (type 'list') cannot be handled by 'cat'
Tests

Um Erwartungen bei der Paketentwicklung oder in Bezug auf ihre Coverage auszuwerten, werden in beiden Paketen Erwartungen zu Tests zusammenfasst (eigentlich sollten Tests immer nur Erwartungen zu einer Funktion enthalten, aber wir wollen ja auch Fehler sehen):

Du kannst einen Test entweder einzeln laufen lassen

testthat::context("My first test.")
testthat::test_that("Simple test on summation.", {
                        testthat::expect_identical(not_my_sum(c(2, 7)), 9,
                                                   info = "Not my sum.")
                        testthat::expect_identical(my_sum(c(2, 7)), 9,
                                                   info = "My sum.")
})
## ── Failure (<text>:3:25): Simple test on summation. ────────────────────────────
## not_my_sum(c(2, 7)) not identical to 9.
## 1/1 mismatches
## [1] -9 - 9 == -18
## Not my sum.
## Error: Test failed

oder den Test in einer Testdatei

testthat::context("My first test.")
testthat::test_that("Simple test on summation.", {
                        testthat::expect_identical(not_my_sum(c(2, 7)), 9,
                                                   info = "Not my sum.")
                        testthat::expect_identical(my_sum(c(2, 7)), 9,
                                                   info = "My sum.")
})

mit einer Funktion auswerten, bei testthat ändert sich relativ wenig:

testthat::test_file(file.path("src", "test_my_sum.R"))
##
## ══ Testing test_my_sum.R ══════════════════════════════════════════════════════════════════════════════════════════════════════════
##
[ FAIL 0 | WARN 0 | SKIP 0 | PASS 0 ]
[ FAIL 0 | WARN 0 | SKIP 0 | PASS 0 ]
[ FAIL 1 | WARN 0 | SKIP 0 | PASS 0 ]
[ FAIL 1 | WARN 0 | SKIP 0 | PASS 1 ]
##
## ── Failure (test_my_sum.R:3:25): Simple test on summation. ─────────────────────
## not_my_sum(c(2, 7)) not identical to 9.
## 1/1 mismatches
## [1] -9 - 9 == -18
## Not my sum.
##
##
[ FAIL 1 | WARN 0 | SKIP 0 | PASS 1 ]

Du erhälst aber die Information, dass der Fehler im ersten Test in Zeile 3 auftrat.

Größer sind die Unterschiede bei RUnit, das primär für das Testen von Paketen entwickelt wurde: Es ist beim einfachen

test_sum <- function() {
    RUnit::checkIdentical(not_my_sum(c(2, 7)), 9)
    RUnit::checkIdentical(my_sum(c(2, 7)), 9)
}
test_sum()
## Error in RUnit::checkIdentical(not_my_sum(c(2, 7)), 9): FALSE
##

recht spröde, mit einer Testdatei

src/runit_my_sum.R
test_sum <- function() {
    RUnit::checkIdentical(not_my_sum(c(2, 7)), 9)
    RUnit::checkIdentical(my_sum(c(2, 7)), 9)
}

allerdings gesprächiger:

test_file <- normalizePath(file.path("src", "runit_my_sum.R"))
runit <- RUnit::runTestFile(test_file)
## Warning in RNGkind(kind = testSuite$rngKind, normal.kind =
## testSuite$rngNormalKind): RNGkind: Marsaglia-Multicarry has poor statistical
## properties
## Warning in RNGkind(kind = testSuite$rngKind, normal.kind =
## testSuite$rngNormalKind): RNGkind: severe deviations from normality for
## Kinderman-Ramage + Marsaglia-Multicarry
##
##
## Executing test function test_sum  ...
## Timing stopped at: 0 0 0.001
## Error in RUnit::checkIdentical(not_my_sum(c(2, 7)), 9) : FALSE
##
##  done successfully.
RUnit::printTextProtocol(runit)
## RUNIT TEST PROTOCOL -- Tue Nov 30 12:33:25 2021
## ***********************************************
## Number of test functions: 1
## Number of errors: 0
## Number of failures: 1
##
##
## 1 Test Suite :
## runit_my_sum - 1 test function, 0 errors, 1 failure
## FAILURE in test_sum: Error in RUnit::checkIdentical(not_my_sum(c(2, 7)), 9) : FALSE
##
##
##
##
## Details
## ***************************
## Test Suite: runit_my_sum
## Test function regexp: ^test.+
## Test file regexp: ^runit_my_sum.R$
## Involved directory:
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src
## ---------------------------
## Test file: /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/runit_my_sum.R
## test_sum: FAILURE !! (check number 1)
## Error in RUnit::checkIdentical(not_my_sum(c(2, 7)), 9) : FALSE
##

3.2.2. Code Coverage

Um zu sehen, ob Deine Unit Tests die Funktion gut testen, kannst Du ihre Überdeckung berechnen. covr ist eines der Pakete, die Code Coverage implentieren und das einzige, das ich nutze. Ich weiß es nicht, glaube aber, dass covr die branch coverage berechnet.

Du kannst auch mit einer hohen Überdeckung unzureichend testen, wie wir später sehen werden. Versuche daher nicht, sie unbedingt zu maximieren und lasse Dich von einer hohen Überdeckung einlullen. Aber prinzipiell ist eine hohe Überdeckung gut.

Wenn Du eine Datei mit einer Funktionsdefinition

src/my_sum_assertion.R
my_sum <- function(x) {
    assertthat::assert_that(is.numeric(x))
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}

und eine mit dem Test

src/test_my_sum_assertion.R
testthat::context("Tests for summation with argument assertion.")
testthat::test_that("Testing summation", {
                    testthat::expect_identical(my_sum(c(2, 7)), 9)
                    testthat::expect_error(my_sum(c("2" + "7")))
})

hast, kannst Du die Überdeckung berechnen.

cov <- covr::file_coverage(file.path("src", "my_sum_assertion.R"),
                           file.path("src", "test_my_sum_assertion.R"))
## Test passed 🌈
print(cov)
## Coverage: 100.00%
## src/my_sum_assertion.R: 100.00%

Wenn Du eine Funktion schreibst, in der eine Zeile eingebaut ist, die der Test nicht erreicht, weist Dich covr darauf hin:

src/my_sum_coverage.R
my_sum <- function(x) {
    assertthat::assert_that(is.numeric(x))
    if (! is.numeric(x)) message("You'll never get here!")
    value <- 0
    for (x_i in x) {
        value <- value + x_i
    }
    return(value)
}
cov <- covr::file_coverage(file.path("src", "my_sum_coverage.R"),
                           file.path("src", "test_my_sum_assertion.R"))
## Test passed 😸
print(cov)
## Coverage: 83.33%
## src/my_sum_coverage.R: 83.33%

covr sagt Dir sogar, dass es die dritte Zeile ist:

covr::zero_coverage(cov)
##                filename functions line value
## 2 src/my_sum_coverage.R    my_sum    3     0

3.2.3. Nebenwirkungen testen

Funktionen sind relativ einfach zu testen, wenn ihr Rückgabewert ihr Zweck ist. Wenn sie aber Nebenwirkungen bezwecken, finde ich Tests schwieriger zu schreiben.

Stell Dir vor, Du hättest die fehlerhafte Löschfunktion aus Arbeiten mit Gültigkeitsbereichen in eine Datei geschrieben:

src/wipe_clean_broken.R
wipe_clean <- function(environment = parent.frame()) {
    objects <- ls(name = environment, all.names = TRUE)
    # FIXME: rm() by default removes objects from
    # the current frame, which is this function, not the parent frame!
    rm(list = objects)
    return(invisible(objects))
}

Nun schreibst Du eine Testdatei:

src/test_wipe_clean_broken.R
testthat::test_that("Test return value.", {
                    a <- 3
                    testthat::expect_identical(wipe_clean(),
                                               c("a"))}
                    )

Und erhälst vollständige Überdeckung:

cov <- covr::file_coverage(file.path("src", "wipe_clean_broken.R"),
                           file.path("src", "test_wipe_clean_broken.R"))
## ── Warning (test_wipe_clean_broken.R:3:21): Test return value. ─────────────────
## object 'a' not found
## Backtrace:
##  1. testthat::expect_identical(wipe_clean(), c("a")) src/test_wipe_clean_broken.R:3:20
##  4. wipe_clean()
##  5. base::rm(list = objects)
print(cov)
## Coverage: 100.00%
## src/wipe_clean_broken.R: 100.00%

Alles gut? Nein, die Funktion ist kaputt und die Testdatei, die dies zeigt müsste auf die Nebenwirkung testen:

src/test_wipe_clean.R
testthat::test_that("Test return value and side effects.", {
                    a <- 3
                    testthat::expect_identical(wipe_clean(), c("a"))
                    testthat::expect_identical(ls(), character(0))}
                    )
covr::file_coverage(file.path("src", "wipe_clean_broken.R"),
                    file.path("src", "test_wipe_clean.R"))
## ── Warning (test_wipe_clean.R:3:21): Test return value and side effects. ───────
## object 'a' not found
## Backtrace:
##  1. testthat::expect_identical(wipe_clean(), c("a")) src/test_wipe_clean.R:3:20
##  4. wipe_clean()
##  5. base::rm(list = objects)
##
## ── Failure (test_wipe_clean.R:4:21): Test return value and side effects. ───────
## ls() not identical to character(0).
## Lengths differ: 1 is not 0
## Error: Test failed

3.2.4. Was soll die ganze Testerei?

Stell Dir vor, Du erstelltest öfter Abbildungen. Jetzt bist Du ein Mensch mit einem Gefühl für Harmonien, daher willst Du gerne, wenn möglich, den Goldenen Schnitt bei der Wahl der Zuschnitte berücksichtigen.

Da Du Dir den Goldenen Schnitt nicht gut merken kannst, schreibst Du folgende Funktion:

src/golden_ratio.R
golden_ratio  <- function() {
    phi <- (1 + sqrt(5)) / 2
    return(phi)
}

Das ginge auch als Einzeiler:

golden_ratio  <- function() return((1 + sqrt(5)) / 2)

aber den findest Du auch nicht viel eleganter, dafür aber schlechter lesbar.

Du schreibst auch einen Test, obwohl der ziemlich trivial ist:

src/test_golden_ratio.R
testthat::test_that("Test on Golden Ratio", {
                        expectation <- (1 + sqrt(5)) / 2
                        result <- golden_ratio()
                        testthat::expect_identical(result, expectation)
})
covr::file_coverage(file.path("src", "golden_ratio.R"),
                    file.path("src", "test_golden_ratio.R"))
## Test passed 🥇
## Coverage: 100.00%
## src/golden_ratio.R: 100.00%

Wenn Du Graphiken nach dem Goldenen Schnitt proportionieren willst, musst Du bei gegebener Länge der kurzen Seite diese mit dem Goldenen Schnitt multipizieren um die Länge der langen Seite zu erhalten.

Das ist eigentlich nicht allzu kompliziert, dennoch kommst Du manchmal durcheinander, also schreibst Du die folgende Funktion:

src/golden_rectangle.R
golden_rectangle  <- function(b) {
    a <- b * golden_ratio()
    return(c("a" = a, "b" = b))
}

Auch für diese Funktion schreibst Du einen Test:

src/test_golden_rectangle.R
testthat::test_that("Test on golden rectangle", {
                        b <- 2
                        expectation <- c(a = b * golden_ratio(), b = b)
                        result <- golden_rectangle(b)
                        testthat::expect_identical(result, expectation)
})
covr::file_coverage(file.path("src", c("golden_ratio.R", "golden_rectangle.R")),
                    file.path("src", "test_golden_rectangle.R"))
## Test passed 🎊
## Coverage: 100.00%
## src/golden_ratio.R: 100.00%
## src/golden_rectangle.R: 100.00%

Du benutzt die Funtktion …

source(file.path("src", "golden_ratio.R"))
width <- 2
png("p1.png", units = "cm", res = 400,
    width = width,
    height = golden_rectangle(width)[["a"]])
par(mar=c(1,1,1,1))
plot(cars)
dev.off()
## pdf
##   2

und bist begeistert:

p1.png
Figure 1. Oh, wie schön!

Du benutzt die Funktion eine Weile weiter, merkst dann aber, dass Du ja auch querformatige Abbildungen erstellen willst und daher bei gegebener Länge der langen Seite diese durch den Goldenen Schnitt dividieren musst, um die Länge der kurzen Seite zu erhalten.

Jetzt kannst Du entweder eine neue Funktion schreiben oder die alte erweitern. Da die Funktionalitäten zum selben Thema passen und golden_rectangle bislang recht simpel ist, schreibst Du Deine Funktion also um:

src/golden_rectangle.R
golden_rectangle  <- function(value, landscape = TRUE) {
    phi <- golden_ratio()
    if (isTRUE(landscape)) {
        a  <- value
        b <- a / phi
    } else {
        b <- value
        a <- b * phi
    }
    return(c("a" = a, "b" = b))
}
width <- 4
png("p2.png", units = "cm", res = 400,
    width = width,
    height = golden_rectangle(width)[["b"]])
par(mar=c(1,1,1,1))
plot(cars)
dev.off()
## pdf
##   2
p2.png
Figure 2. Auch sehr schön!

Herzlichen Glückwunsch, Du hast gerade die Schnittstelle Deiner Funktion zerschossen, indem Du ihr voreingestelltes Verhalten geändert hast. Glücklicherweise hast Du einen Test, der Dir jetzt um die Ohren fliegt:

covr::file_coverage(file.path("src", "golden_rectangle.R"),
                    file.path("src", "test_golden_rectangle.R"))
## ── Failure (test_golden_rectangle.R:5:25): Test on golden rectangle ────────────
## `result` not identical to `expectation`.
## 2/2 mismatches (average diff: 1)
## [1] 2.00 - 3.24 == -1.236
## [2] 1.24 - 2.00 == -0.764
## Error: Test failed

Was bedeutet das? Du musst entweder

  • alle Aufrufe der Funktion, die Du vor der Veränderung ihrer Schnittstelle progammiert hast, anpassen (indem Du , landscape = FALSE einfügst) oder

  • die Funktion so ändern, dass die Schnittstelle stabil bleibt (und der Test weiterhin funktioniert).

Du entscheidest Dich, die Funktion zu ändern:

src/golden_rectangle.R
golden_rectangle  <- function(value, landscape = FALSE) {
    phi <- golden_ratio()
    if (isTRUE(landscape)) {
        a  <- value
        b <- a / phi
    } else {
        b <- value
        a <- b * phi
    }
    return(c("a" = a, "b" = b))
}

Um Querformatige Proportionen zu erhalten musst Du nun aktiv Querformat einstellen: golden_rectangle(width, landscape = TRUE)

Der Test funktioniert wieder, da Du aber die Funktion geändert hast, überdeckt er sie nicht mehr vollständig:

cov <- covr::file_coverage(file.path("src", "golden_rectangle.R"),
                    file.path("src", "test_golden_rectangle.R"))
## Test passed 🥇
print(cov)
## Coverage: 71.43%
## src/golden_rectangle.R: 71.43%
print(covr::zero_coverage(cov))
##                 filename        functions line value
## 3 src/golden_rectangle.R golden_rectangle    4     0
## 4 src/golden_rectangle.R golden_rectangle    5     0

Du erweiterst also Deine Testdatei an:

src/test_golden_rectangle.R
testthat::test_that("Test on golden rectangle", {
                        value <- 2
                        expectation <- c(a = value * golden_ratio(), b = value)
                        result <- golden_rectangle(value)
                        testthat::expect_identical(result, expectation)
                        result <- golden_rectangle(value * golden_ratio(), landscape = TRUE)
                        testthat::expect_identical(result, expectation)
})
covr::file_coverage(file.path("src", "golden_rectangle.R"),
                    file.path("src", "test_golden_rectangle.R"))
## Test passed 🥳
## Coverage: 100.00%
## src/golden_rectangle.R: 100.00%

golden_rectangle habe ich mir nur ausgedacht, um Dir mein Vorgehen zu verdeutlichen. Aber:

Ich teste fast alle meine Funktion nach genau dem Ablauf in diesem Abschnitt spätestens, wenn ich sie in ein Paket verpacke.

Du testest Deinen Code so oder so (zur Not auf die harte Tour, also bei der produktiven Anwendung), das Unit Testing ist nur eine hilfreiche Formalisierung, nutze sie! Und mit der Code Coverage hast Du sogar eine Möglichkeit, die Güte Deines Testens abzuschätzen.

3.3. Weniger schlecht programmieren

Ich möchte Dir gerne noch vier Funktionen aus vier verschiedenen Paketen vorstellen, die ich alle vier standardmäßig bei der Entwicklung von Paketen nutze.

Die erste findet echte Fehler in Deinem Code, die anderen drei können Dir helfen, besser lesbare, übersichtlichere und weniger komplizierte Funktionen zu schreiben.

Stell Dir vor, Du hättest in der Datei "src/code.R" folgende unschöne und kaputte Funktion geschrieben:

foo <- function(this, func, has, way, too, many,args, hell = TRUE) {
    if (isTRUE(this)) { if (isTRUE(func)) {
        if (isTRUE(has)) {
            if (!isTRUE(way)) {
                if (isTRUE(too)) print(sum(many, args))  else stop("What the hell?")
            } else stop("Haha, gotcha!")
        } else stop("Foobar!")
} else stop("Foo!")
    } else stop("Bar!")
    return(invisible(you_will_never_get_here))
}

3.3.1. Fehler finden mit codetools

codetools gehört zur Gruppe der "recommended Packages" von R und kann Programmfehler finden:

source(file.path("src", "code.R"))
codetools::checkUsage(foo, all = TRUE)
## <anonymous>: no visible binding for global variable 'you_will_never_get_here'
## <anonymous>: parameter 'hell' may not be used

in Deiner Funktion findet codetools nicht benutzte Funktionsargumente und das nicht definierte Objekte this_is_not_defined (und findet damit auch unsere Scopingfehler beim Lesen).

3.3.2. Entflusen mit lintr

Das Paket lintr prüft Code auf Fussel, das sind Abweichungen des Codes von Richtlinien zur übersichtlichen Formatierung. Die Richtlinien (gegen die lintr prüft, und die sind gut, halte Dich an sie; mehr über Progammierrichtlinien findest Du im Programmierleitfaden an der Forstlichen Versuchs- und Forschungsanstalt Baden-Württemberg) sehen unter anderem vor, dass auf Kommas immer ein Leerzeichen und auf öffnende geschweifte Klammern immer ein Zeilenumbruch folgen sollte:

lintr::lint(file.path("src", "code.R"))
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/code.R:1:49: style: Commas should always have a space after.
## foo <- function(this, func, has, way, too, many,args, hell = TRUE) {
##                                                 ^
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/code.R:2:23: style: Opening curly braces should never go on their own line and should always be followed by a new line.
##     if (isTRUE(this)) { if (isTRUE(func)) {
##                       ^
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/code.R:5:1: style: Lines should not be more than 80 characters.
##                 if (isTRUE(too)) print(sum(many, args))  else stop("What the hell?")
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/code.R:10:22: warning: no visible binding for global variable 'you_will_never_get_here'
##     return(invisible(you_will_never_get_here))
##                      ^~~~~~~~~~~~~~~~~~~~~~~

lintr gibt Dir klare Anweisungen, wie Du Deinen Code umschreiben solltest.

Das Paket kennt viele Optionen, lies Dir die Hilfe durch!

Hartes Entflusen

Es gibt zwei Pakete, die Quelldateien umschreiben: formatR und, seit Ende 2017, styler.

formatR macht in etwa, was lintr empfiehlt, styler geht etwas weiter (indem es beispielsweise {}-Blöcke sinnvoll ergäntzt) und bringt damit in meinen Augen deutlich bessere Ergebnisse.

Ich nutze styler sehr selten und nur, wenn ich richtig schlechten Code lesen muss.

Da beide Pakete Quelldateien umschreiben, solltest Du Deine Quelldateien vorsichtshalber kopieren und dann erst entflusen:

tempfile <- paste0(tempfile(), ".R")
file.copy(file.path("src", "code.R"), tempfile, overwrite = TRUE)
## [1] TRUE
formatR::tidy_file(tempfile)
## tidying /tmp/RtmpjoEzmQ/file69ad252829c2.R

formatR bereinigt schon mal das schlimmste:

cat(readLines(file.path(tempfile)), sep = "\n")
foo <- function(this, func, has, way, too, many, args, hell = TRUE) {
    if (isTRUE(this)) {
        if (isTRUE(func)) {
            if (isTRUE(has)) {
                if (!isTRUE(way)) {
                  if (isTRUE(too))
                    print(sum(many, args)) else stop("What the hell?")
                } else stop("Haha, gotcha!")
            } else stop("Foobar!")
        } else stop("Foo!")
    } else stop("Bar!")
    return(invisible(you_will_never_get_here))
}
styler::style_file(file.path("src", "code.R"))
## Styling  1  files:
##  src/code.R ℹ
## ────────────────────────────────────────
## Status       Count   Legend
## ✔    0       File unchanged.
## ℹ    1       File changed.
## ✖    0       Styling threw an error.
## ────────────────────────────────────────
## Please review the changes carefully!

Ich finde aber das Ergebnis von styler überzeugender:

cat(readLines(file.path("src", "code.R")), sep = "\n")
foo <- function(this, func, has, way, too, many, args, hell = TRUE) {
  if (isTRUE(this)) {
    if (isTRUE(func)) {
      if (isTRUE(has)) {
        if (!isTRUE(way)) {
          if (isTRUE(too)) print(sum(many, args)) else stop("What the hell?")
        } else {
          stop("Haha, gotcha!")
        }
      } else {
        stop("Foobar!")
      }
    } else {
      stop("Foo!")
    }
  } else {
    stop("Bar!")
  }
  return(invisible(you_will_never_get_here))
}

Nun ja, jetzt hast Du leider doch Deine Quelldatei überschrieben. Falls Du den Empfehlungen des Programmierleitfadens an der Forstlichen Versuchs- und Forschungsanstalt Baden-Württemberg folgst, benutzt Du sicher Versionskontrollsystem. Falls das git ist, kannst Du die Quelldatei wiederherstellen:

repo <- git2r::repository(".")
## Error in dyn.load(file, DLLpath = DLLpath, ...): unable to load shared object '/home/qwer/svn/R/r-devel/build/library/git2r/libs/git2r.so':
##   libgit2.so.27: cannot open shared object file: No such file or directory
git2r::checkout(object = repo, path = file.path("src", "code.R"))
## Error in dyn.load(file, DLLpath = DLLpath, ...): unable to load shared object '/home/qwer/svn/R/r-devel/build/library/git2r/libs/git2r.so':
##   libgit2.so.27: cannot open shared object file: No such file or directory
cat(readLines(file.path("src", "code.R")), sep = "\n")
foo <- function(this, func, has, way, too, many, args, hell = TRUE) {
  if (isTRUE(this)) {
    if (isTRUE(func)) {
      if (isTRUE(has)) {
        if (!isTRUE(way)) {
          if (isTRUE(too)) print(sum(many, args)) else stop("What the hell?")
        } else {
          stop("Haha, gotcha!")
        }
      } else {
        stop("Foobar!")
      }
    } else {
      stop("Foo!")
    }
  } else {
    stop("Bar!")
  }
  return(invisible(you_will_never_get_here))
}

3.3.3. Code säubern mit cleanr

Das Paket cleanr greift einige Richtlinien aus [cc] auf und prüft die Länge und (Zeilen-) Breite von Funktionen und Codedateien und die Verschachtelungstiefe von Funktionen, ihre Argumentenanzahl und ob sie einen expliziten Rückgabewert haben.

print(suppressWarnings(cleanr::check_file(file.path("src", "code.R"))))
## Error in cleanr::check_file(file.path("src", "code.R")):  src/code.R  foo  found 8 arguments, max_num_arguments was 5
## foo  found nesting depth 4, max_nesting_depth was 3

Auch dieses Paket kennt viele Optionen, lies Dir die Hilfe durch!

3.3.4. Cyclomatic Complexity prüfen mit cyclocomp

McCabes "cyclomatic complexity" ([cyc]) mißt die Komplexität von Programmcode. Mit ihr kannst Du prüfen, ob Deine Funktionen einfach genug sind.

Insbesondere gibt Dir die "cyclomatic complexity" eine Idee davon, wie viele Testfälle Du für eine Funktion schreiben solltest (genau genommen ist sie eine obere Grenze für die Anzahl der für vollständige branch coverage benötigten Testfälle). Für Deine hässliche Funktion bräuchtest Du also 6 Testfälle:

cyclocomp::cyclocomp(parse(text = readLines(file.path("src", "code.R"))))
## [1] 6

Allgemein gilt: je höher die "cyclomatic complexity", desto unverständlicher der Code. McCabe empfiehlt eine "cyclomatic complexity" von nicht mehr als 10 für eine Funktion. Und der war professioneller Programmierer des Departement of Defense der National Security Agency. Bei einer "cyclomatic complexity" von 20 dürfte es selbst für professionelle Programmiererinnen langsam schwierig werden, die Absicht hinter Deinem Code zu verstehen. Wenn Du eine "cyclomatic complexity" von mehr als 40 schaffst, hast Du vielleicht eine Funktion geschrieben, die tut, was sie soll, aber ziemlich sicher eine, die kaum ein Mensch mehr versteht.

Und was machst Du dann? Dann solltest du versuchen, Teilfunktionen aus der Funktion auszugliedern. Das ist schwierig, aber wahrscheinlich weniger schwierig als Deine Funktion in Zukunft nochmal zu lesen oder gar zu ändern.

Natürlich gibt es immer Ausnahmen von der 10er-Regel. Die Funktion devtools::release beispielsweise hat eine ganze Reihe von interaktiven Abfragen des Typs

if (yesno("Were devtool's checks successful?"))
  return(invisible())

Diese treiben die "cyclomatic complexity" in die Höhe (weil die return-Anweisungen viele verschiedene mögliche Endpunkte der Funktion definieren. Eine wohlstrukturierte Funktion hat genau einen "exit node"):

source(file.path("src", "release.R"))
cyclocomp::cyclocomp(release)
## [1] 35

Dabei ist die Funktion lediglich schwer verdaulich und nicht völlig unlesbar. Dennoch sollte Hadley Wickham die Funktion dringend entrümpeln:

linters <- lintr::default_linters[names(lintr::default_linters )!= "object_usage_linter"]
lintr::lint(file.path("src", "release.R"), linters = linters)
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/release.R:41:1: style: functions should have cyclomatic complexity of less than 15, this has 35.
## release <- function(pkg = ".", check = FALSE, args = NULL) {
## ^
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/release.R:132:1: style: Lines should not be more than 80 characters.
##     if (file.exists("codemeta.json")) "Have you updated codemeta.json with codemetar::write_codemeta()?",
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/release.R:193:1: style: Lines should not be more than 80 characters.
##   yeses <- c("Yes", "Definitely", "For sure", "Yup", "Yeah", "I agree", "Absolutely")
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/release.R:371:1: style: Variable and function name style should be snake_case.
## as.object_size <- function(x) structure(x, class = "object_size")
## ^~~~~~~~~~~~~~
## /home/qwer/git/cyclops/fvafrcu/funktionen_in_r/src/release.R:387:1: style: Lines should not be more than 80 characters.
##     "Once it is accepted, delete this file and tag the release (commit ", sha, ")."
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
suppressWarnings(cleanr::check_file(file.path("src", "release.R")))
## Error in cleanr::check_file(file.path("src", "release.R")):  src/release.R: line 132 counts 105 characters.
## src/release.R: line 193 counts 85 characters.
## src/release.R: line 387 counts 83 characters.
## src/release.R: 401 lines in file.
##  src/release.R  as.object_size  found no return() statement at all.
## src/release.R  build_cran  found no return() statement at all.
## src/release.R  cran_comments  found no return() statement at all.
## src/release.R  cran_mirror  found no return() statement at all.
## src/release.R  email  found no return() statement at all.
## src/release.R  email_browser  found no return() statement at all.
## src/release.R  find_release_questions  found no return() statement at all.
## src/release.R  flag_release  line 14: found width 83 max_line_width was 80
## flag_release  found no return() statement at all.
## src/release.R  has_cran_results  found no return() statement at all.
## src/release.R  maintainer  found no return() statement at all.
## src/release.R  release  line 91: found width 105 max_line_width was 80
## release  found 107 lines, max_lines was 65
## release  found 106 lines of code, max_lines_of_code was 50
## release  found no return() statement at all.
## src/release.R  release_email  found no return() statement at all.
## src/release.R  submit_cran  found no return() statement at all.
## src/release.R  upload_cran  found no return() statement at all.
## src/release.R  yesno  line 1: found width 85 max_line_width was 80
## yesno  found no return() statement at all.

3.4. Funktionen dokumentieren

Wenn Du Hilfe zu einer Funktion in R suchst, kannst Du unter anderem die R-Hilfe mit help(topic) oder der Kurzform ?topic aufrufen, bei Paketen findest Du die selbe Information auch immer als pdf beigelegt.

Solche Hilfeformate kannst Du für Deine Funktionen auch schreiben.

3.4.1. Warum solltest Du Deine Funktionen dokumentieren?

Wenn Du Funktionen dokumentierst, erklärst Du einer anderen Person, was die Funktion tun sollte. Wenn Du das schaffst, kannst Du Dir einigermaßen sicher sein, dass Du weißt, was die Funktion tut und dass es richtig war, sie (und nicht eine etwas andere) zu schreiben.

Außerdem ist es von dokumentierten Funktionen zu Paketen nicht mehr weit, was ihre Verwaltung deutlich erleichtert.

Du merkst, dass Du die Funktion golden_ratio eigentlich nur innerhalb von golden_rectangle benutzt und letzteres kein glücklicher Name ist, weil Du die Funktion zwar zum Errechnen von Seitenlängen von Graphiken nutzt, sie ja aber ganz allgemein den Goldenen Schnitt ausrechnet. Du entschließt Dich daher, die interne Funktion in .golden_ratio (der führende Punkt ist eine Konvention, die aus der UNIX-Welt stammt, dort werden (vorwiegend Konfigurations-) Dateien mit einem führenden Punkt aus dem directory listing ausgeschlossen (unter Windows heißen diese Dateien "versteckt")  — in R kennzeichnet die Konvention interne Funktionen, die gewöhnlich nicht direkt aufgerufen werden (sollten)) und golden_rectangle in golden_ratio umzubenennen. Dazu musst Du

  • die Funktionsdateien und die zugehörigen Testdateien umbenennen,

  • die Namen in den Funktionsdefinitionen ändern und

  • die Namen in den Funktionsaufrufen ändern.

Das kannst Du von Hand machen, oder Du schreibst folgende Funktionen:

substitute_function <- function(from, to, file_name) {
        patterns <- c(definition_pattern = paste0(from, "( *<-)"),
                      call_pattern = paste0(from, "(\\()"))
        x <- readLines(file_name)
        for (pattern in patterns)
            x <- sub(pattern, paste0(to, "\\1"), x)

        writeLines(x, con = file_name)

}

rename_function <- function(from, to, directory = ".") {
    file_names <- list.files(directory, full.names = TRUE,
                             pattern = paste0("^(test_|)", from, "\\.[rR]$")
                             )
    new_file_names <- NULL

    for (file_name in file_names) {

        substitute_function(from = from, to = to, file_name = file_name)
        new_file_name <- file.path(dirname(file_name),
                                   sub(from, to, basename(file_name)))
        file.rename(file_name, new_file_name)
        new_file_names <- c(new_file_names, new_file_name)
    }
    return(new_file_names)
}

Diese Funktionen leben ja von Nebenwirkungen, sie sind schwer zu testen und wir hoffen also, dass Du keine Fehler gemachst hast.

Funktionieren tut das so:

rename_function(from = "golden_ratio", to = ".golden_ratio",
                 directory = "src")
## [1] "src/.golden_ratio.R"      "src/test_.golden_ratio.R"
# replace calls to golden_ratio()!
substitute_function(from = "golden_ratio", to = ".golden_ratio",
                 file_name = file.path("src", "test_golden_rectangle.R"))
substitute_function(from = "golden_ratio", to = ".golden_ratio",
                 file_name = file.path("src", "golden_rectangle.R"))
rename_function(from = "golden_rectangle", to = "golden_ratio",
                 directory = "src")
## [1] "src/golden_ratio.R"      "src/test_golden_ratio.R"

Du testest natürlich Deine neuen Dateien:

covr::file_coverage(file.path("src", ".golden_ratio.R"),
                    file.path("src", "test_.golden_ratio.R"))
## Test passed 🥇
covr::file_coverage(file.path("src", c("golden_ratio.R", ".golden_ratio.R")),
                    file.path("src", "test_golden_ratio.R"))
## Test passed 😸
## Coverage: 100.00%
## src/golden_ratio.R: 100.00%

Scheint geklappt zu haben.

Du siehst also, dass Du Deine Funktionen verändert hast, weil Du sie dokumentieren willst.

3.4.2. Wie kannst Du Funktionen dokumentieren?

Das R-Hilfeformat wird hier beschrieben, ich rate Dir aber, roxygen2 zu benutzen (hier gibt Hadley Wickham eine druckreife Einführung).

Du veränderst also Deine Funktionsdatei, in dem Du Dokumentationskommentare einfügst:

src/golden_ratio.R
#' Compute the Other Quantity in Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' Specify \code{value = 1} to obtain the Golden Ratio itself in element "a" of
#' the return value.
#' @param value A Quantity.
#' @param landscape Is the quantity given by \code{value} the larger one ("a")?
#' @return A vector giving the quantities "a" and "b".
#' @export
#' @examples
#' print(golden_ratio(value = 1)[["a"]])
golden_ratio  <- function(value, landscape = FALSE) {
    phi <- .golden_ratio()
    if (isTRUE(landscape)) {
        a  <- value
        b <- a / phi
    } else {
        b <- value
        a <- b * phi
    }
    return(c("a" = a, "b" = b))
}

und weil dokumentieren Dir so viel Spaß bereit, dokumentierst Du gleich auch die interne Funktion (interne Funktionen zu dokumentieren ist ein wenig umstritten, ich finde es gut).

src/.golden_ratio.R
#' Compute the Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' @return The Golden Ratio
#' @keywords internal
.golden_ratio  <- function() {
    phi <- (1 + sqrt(5)) / 2
    return(phi)
}

Was hast Du davon, außer Arbeit?

Wenn Du Deine beiden Funktionen in eine Datei schreibst

src/golden_ratios.R
#' Compute the Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' @return The Golden Ratio
#' @keywords internal
.golden_ratio  <- function() {
    phi <- (1 + sqrt(5)) / 2
    return(phi)
}

#' Compute the Other Quantity in Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' Specify \code{value = 1} to obtain the Golden Ratio itself in element "a" of
#' the return value.
#' @param value A Quantity.
#' @param landscape Is the quantity given by \code{value} the larger one ("a")?
#' @return A vector giving the quantities "a" and "b".
#' @export
#' @examples
#' print(golden_ratio(value = 1)[["a"]])
golden_ratio  <- function(value, landscape = FALSE) {
    phi <- .golden_ratio()
    if (isTRUE(landscape)) {
        a  <- value
        b <- a / phi
    } else {
        b <- value
        a <- b * phi
    }
    return(c("a" = a, "b" = b))
}

kannst Du mit dem Paket document Hilfe-Dateien erstellen, wie Du sie aus R kennst:

document::document(file.path("src", "golden_ratios.R"), output_directory = ".")
list.files(pattern = "^golden.*", full.names = TRUE)
## [1] "./golden_ratios.html" "./golden_ratios.pdf"  "./golden_ratios.txt"

Außerdem kannst Du mit document nach der Erstellung der Hilfe-Dateien in einer laufenden R-Sitzung die Hilfe zu Deiner Funktion ansehen:

document::man("golden_ratio")
Compute the Other Quantity in Golden Ratio

Description:

     See <URL: https://en.wikipedia.org/wiki/Golden_ratio> for an
     introduction to the Golden Ratio.

Usage:

     golden_ratio(value, landscape = FALSE)

Arguments:

   value: A Quantity.

landscape: Is the quantity given by ‘value’ the larger one ("a")?

Details:

     Specify ‘value = 1’ to obtain the Golden Ratio itself in element
     "a" of the return value.

Value:

     A vector giving the quantities "a" and "b".

Examples:

     print(golden_ratio(value = 1)[["a"]])

Und zum Dritten und Wichtigsten: Du hast Deine Funktionen dokumentiert und ihre Schnittstellen beschrieben. Sie sind jetzt paketierungsreif.

3.5. Paketieren

Zum Paketieren nimmst Du wieder die getrennten Funktionsdateien, src/golden_ratio.R und src/.golden_ratio.R und ihre zugehörigen Testdateien.

Damit sie den Paketanforderungen genügen, musst Du noch zwei kleine Änderungen vornehmen: golden_ratio.R braucht noch einen Verweis darauf, dass interne Funktionen in golden_ratio_internals.R stehen

code <- c("#' @include golden_ratio_internals.R", "NULL", "",
          readLines(file.path("src", "golden_ratio.R")))
writeLines(code, file.path("src", "golden_ratio.R"))
src/golden_ratio.R
#' @include golden_ratio_internals.R
NULL

#' Compute the Other Quantity in Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' Specify \code{value = 1} to obtain the Golden Ratio itself in element "a" of
#' the return value.
#' @param value A Quantity.
#' @param landscape Is the quantity given by \code{value} the larger one ("a")?
#' @return A vector giving the quantities "a" and "b".
#' @export
#' @examples
#' print(golden_ratio(value = 1)[["a"]])
golden_ratio  <- function(value, landscape = FALSE) {
    phi <- .golden_ratio()
    if (isTRUE(landscape)) {
        a  <- value
        b <- a / phi
    } else {
        b <- value
        a <- b * phi
    }
    return(c("a" = a, "b" = b))
}

und die Dokumentation für .golden_ratio sollte in eine Datei geschrieben werden, deren Name nicht mit einem Punkt beginnt (der Name der Hilfedatei wird, wenn Du ihn nicht explizit angibst, aus dem der dokumentierten Funktion abgeleitet)

code <- readLines(file.path("src", ".golden_ratio.R"))
return_line <- grep("@return", code)
code_upper <- code[1:return_line]
code_lower <- code[(return_line + 1):length(code)]
code <- c(code_upper, "#' @rdname internals", code_lower)
writeLines(code, file.path("src", ".golden_ratio.R"))
src/.golden_ratio.R
#' Compute the Golden Ratio
#'
#' See \url{https://en.wikipedia.org/wiki/Golden_ratio} for an introduction to
#' the Golden Ratio.
#'
#' @return The Golden Ratio
#' @rdname internals
#' @keywords internal
.golden_ratio  <- function() {
    phi <- (1 + sqrt(5)) / 2
    return(phi)
}

Du erstellst eine Paketvorlage und kopierst die Dateien hinein:

# Create package skeleton
package_name <- "mytools"
package_dir <- file.path(dirname(tempdir()), package_name)
unlink(package_dir, recursive = TRUE) # make sure it's not there
usethis::create_package(package_dir, open = FALSE)
# add source files
file.copy(from = file.path("src", c("golden_ratio.R", ".golden_ratio.R")),
          to = file.path(package_dir, "R"))
# rename the hidden file, package will not build otherwise:
file.rename(file.path(package_dir, "R", ".golden_ratio.R"),
            file.path(package_dir, "R", "golden_ratio_internals.R"))
# create package's testing skeleton
withr::with_dir(package_dir, usethis::use_testthat())
# add test files
file.copy(from = file.path("src", c("test_golden_ratio.R",
                                    "test_.golden_ratio.R")),
                           file.path(package_dir, "tests", "testthat"))
# build the docs
roxygen2::roxygenize(package_dir)
## Warning:
## ── Conflicts ───────────────────────────────────────────────────────────────────────────────────────────────── mytools conflicts ──
## ✖ golden_ratio() masks mytools::golden_ratio()
##
## Did you accidentally source a file rather than using `load_all()`?
## Run `rm(list = c("golden_ratio"))` to remove the conflicts.
# Set package Metadata
desc::desc_set_authors(person(given = "Your", family = "Name",
                              role = c("aut", "cre"),
                              email = "your.name@somewhe.re"),
                       file = package_dir, normalize = TRUE)
desc::desc_bump_version("minor", package_dir)
## Fix some more metadata
d <- desc::desc(package_dir)
### Use title case
d$set(Title = tools::toTitleCase(d$get("Title")))
### Set package License
d$set(License = "GPL")
d$write()

Nun kannst Du das Paket prüfen:

check <- rcmdcheck::rcmdcheck(package_dir, args = "--as-cran")
print(check)
## ── R CMD check results ───────────────────────────────────────────────────────────────────────────────────────── mytools 0.1.0 ────
## Duration: 27.7s
##
## ❯ checking CRAN incoming feasibility ... NOTE
##   Maintainer: ‘Your Name <your.name@somewhe.re>’
##
##   New submission
##
##   DESCRIPTION fields with placeholder content:
##     Title: what the package does (one line, title case)
##     Description: what the package does (one paragraph).
##
## 0 errors ✔ | 0 warnings ✔ | 1 note ✖

Nun ja, Du hast die Metadaten noch nicht angepasst. Solltest Du noch tun.

Du kannst Dein Paket auch testen:

covr::package_coverage(package_dir)
## mytools Coverage: 100.00%
## R/golden_ratio_internals.R: 100.00%
## R/golden_ratio.R: 100.00%

Und Du solltest immer auch die Deine drei Freunde lintr, cleanr und cyclocomp fragen (wobei lintr hier die vorhandene Funktion .golden_ratio() nicht erkennt [2] und cyclocomp ebenfalls nicht [3] und daher keine cyclomatic complexity für sie berechnet):

print(lintr::lint_package(package_dir))
## R/golden_ratio.R:9:80: style: Trailing whitespace is superfluous.
## #' Specify \code{value = 1} to obtain the Golden Ratio itself in element "a" of
##                                                                                ^
## tests/testthat/test_golden_ratio.R:6:1: style: Lines should not be more than 80 characters.
##                         result <- golden_ratio(value * .golden_ratio(), landscape = TRUE)
## ^~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
print(suppressWarnings(cleanr::check_directory(package_dir)))
## [1] TRUE
print(cyclocomp::cyclocomp_package_dir(package_dir))
##
   checking for file ‘/tmp/RtmpjoEzmQ/remotes69ad195f15b1/mytools/DESCRIPTION’ ...

✔  checking for file ‘/tmp/RtmpjoEzmQ/remotes69ad195f15b1/mytools/DESCRIPTION’
## ─  preparing ‘mytools’:
## ✔  checking DESCRIPTION meta-information
##

─  checking for LF line-endings in source and make files and shell scripts
## ─  checking for empty or unneeded directories
## ─  building ‘mytools_0.1.0.tar.gz’
##


##
          name cyclocomp
## 1 golden_ratio         2

Gut! Das wird jetzt verpackt:

withr::with_dir(dirname(package_dir),
                callr::rcmd_safe("build", basename(package_dir)))
## $status
## [1] 0
##
## $stdout
## [1] "* checking for file ‘mytools/DESCRIPTION’ ... OK\n* preparing ‘mytools’:\n* checking DESCRIPTION meta-information ... OK\n* checking for LF line-endings in source and make files and shell scripts\n* checking for empty or unneeded directories\n* building ‘mytools_0.1.0.tar.gz’\n"
##
## $stderr
## [1] "\n"
##
## $timeout
## [1] FALSE
##
## $command
## [1] "/home/qwer/svn/R/r-devel/build/bin/R"
## [2] "CMD"
## [3] "build"
## [4] "mytools"
package_path <- paste0(package_dir, "_0.1.0.tar.gz")
if (file.exists(package_path)) print(package_path)
## [1] "/tmp/mytools_0.1.0.tar.gz"

Paket fertig. Die Metadaten sind natürlich gelogen (Du solltest die Datei DESCRIPTION anpassen, Du solltest eine Datei NEWS.md pflegen, Du solltest ein version control system benutzten), aber funktional ist es korrekt.

4. Bibliographie

  • [cc] R.C. Martin. 2008. Clean Code: A Handbook of Agile Software Craftsmanship. Pearson Education.

  • [cyc] T. J. McCabe, 1976. A Complexity Measure IEEE Transactions on Software Engineering archive. Volume 2, Issue 4, Pages 308-320


1. Im Code von RStudio v1.1.426 findet sich die Funktion hinter dem Knopf in der Datei src/cpp/session/modules/SessionEnvironment.R, sie besteht im wesentlichen aus der Zeile
rm(list=ls(envir=env, all.names=includeHidden), envir=env)
Sie wird in src/cpp/session/modules/environment/SessionEnvironment.cpp in der C++-Funktion removeAllObjects aufgerufen.
2. Das ist ein altes Problem, siehe https://github.com/jimhester/lintr/issues/27. Wenn Du mit devtools::install(package_dir) das Paket installierst, verschwindet die falsch positive Warnung.
3. In Version 1.1.0 des Pakets ruft cyclocomp::cyclocomp_package_dir die Funktion cyclocomp::cyclocomp_package und diese ls(asNamespace(package)), wobei package das aktuelle Paket, hier also "mytools", ist und ls mit der Voreinstellung all.names = FALSE Objekte mit einem führenden Punkt nicht auflistet.