rlib/misclang.R at master · RudolfCardinal/rlib · GitHub

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
# misclang.R

#==============================================================================
# Namespace-like method: http://stackoverflow.com/questions/1266279/#1319786
#==============================================================================

misclang <- new.env()


#==============================================================================
# Libraries
#==============================================================================

misclang$library_or_install <- function(required_packages)
{
    # https://stackoverflow.com/questions/4090169/elegant-way-to-check-for-missing-packages-and-install-them
    missing_packages <- required_packages[
        !(required_packages %in% installed.packages()[,"Package"])]
    if (length(missing_packages)) {
        install.packages(missing_packages)
    }
    for (pkg in required_packages) {
       library(pkg, character.only = TRUE)
    }
}


#==============================================================================
# String manipulation
#==============================================================================

misclang$n_char_occurrences <- function(string, char)
{
    s2 <- gsub(char, "", string)
    return(nchar(string) - nchar(s2))
}


#==============================================================================
# Vector manipulation
#==============================================================================

misclang$vector_element_by_index_of_last_element <- function(x)
{
    x[ x[ length(x) ] ]
}


#==============================================================================
# Vector uniqueness, inclusion/exclusion
#==============================================================================

misclang$elements_unique <- function(x) {
    # Are all the elements of x unique?
    length(x) == length(unique(x))
}


misclang$elements_include <- function(x, values) {
    # Is any element of "values" present in "x"?
    any(values %in% x)
}


misclang$elements_unique_and_exclude <- function(x, values) {
    # Are all the elements of x unique, without any "values" present?
    !misclang$elements_include(x, values) && misclang$elements_unique(x)
}


#==============================================================================
# Caching
#==============================================================================

misclang$load_rds_or_run_function <- function(
        filename, fn, ...,
        forcerun = FALSE)
{
    # Simplified version of load_or_run_function() that only uses RDS files,
    # so doesn't need varname.

    if (!forcerun && file.exists(filename)) {
        cat("Loading from file:", filename, "\n")
        result <- readRDS(filename)
        cat("... loaded\n")
    } else {
        cat("Running function:", deparse(substitute(fn)), "\n")
        result <- fn(...)
        cat("--- Saving to file:", filename, "\n")
        saveRDS(result, file = filename)
    }
    return(result)
}


misclang$load_or_run_function <- function(
        varname, filename, fn, ...,
        forcerun = FALSE,
        cache_filetype = c("rds", "rda"))
{

    # e.g. load_or_run_function("blibble", "mydata.Rda", mean, c(1,2,3))

    cache_filetype <- match.arg(cache_filetype)

    if (cache_filetype == "rda") {
        # .Rda, .Rdata
        if (!forcerun && file.exists(filename)) {
            cat("Loading", varname, "from file:", filename, "\n")
            load(filename)  # assumes it will load into a variable whose textual name is in varname
            cat("... loaded\n")
        } else {
            cat("Running function:", deparse(substitute(fn)), "\n")
            assign(varname, fn(...))
            cat("--- Saving", varname, "to file:", filename, "\n")
            save(list = c(varname), file = filename)
        }
        return(get(varname))

    } else {
        # .Rds; cleaner; saves only a single object but doesn't care about its name
        if (!forcerun && file.exists(filename)) {
            cat("Loading", varname, "from file:", filename, "\n")
            result <- readRDS(filename)
            cat("... loaded\n")
        } else {
            cat("Running function:", deparse(substitute(fn)), "\n")
            result <- fn(...)
            cat("--- Saving to file:", filename, "\n")
            saveRDS(result, file = filename)
        }
        return(result)

    }
}

#==============================================================================
# Factors
#==============================================================================

misclang$numeric_factor_to_numeric <- function(f)
{
    # http://stackoverflow.com/questions/3418128
    as.numeric(levels(f))[f]
}

#==============================================================================
# Namespace-like method: http://stackoverflow.com/questions/1266279/#1319786
#==============================================================================

if ("misclang" %in% search()) detach("misclang")
attach(misclang)  # subsequent additions not found, so attach at the end