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
|
### =========================================================================
### Some low-level utilities
### -------------------------------------------------------------------------
###
### Nothing in this file is exported.
###
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### Detect and trim trailing slahes in a character vector
###
has_trailing_slash <- function(x)
{
stopifnot(is.character(x))
#nc <- nchar(x)
#substr(x, start=nc, stop=nc) == "/"
grepl("/$", x) # seems slightly faster than the above
}
trim_trailing_slashes <- function(x)
{
sub("/*$", "", x)
}
add_prefix_to_basename <- function(name, prefix=".")
{
stopifnot(isSingleString(name), isSingleString(prefix))
slash_idx <- which(safeExplode(name) == "/")
if (length(slash_idx) == 0L) {
dname <- ""
bname <- name
} else {
last_slash_idx <- max(slash_idx)
dname <- substr(name, start=1L, stop=last_slash_idx)
bname <- substr(name, start=last_slash_idx+1L, stop=nchar(name))
}
paste0(dname, prefix, bname)
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### A simple/naive/imperfect mechanism to lock/unlock a file so processes can
### get temporary exclusive access to it
###
### TODO: Use filelock::lock() and filelock::unlock() instead of this.
###
.locked_path <- function(filepath)
{
if (!isSingleString(filepath) || filepath == "")
stop("'filepath' must be a single non-empty string")
paste0(filepath, "-locked")
}
.safe_file_rename <- function(from, to)
{
!file.exists(to) && suppressWarnings(file.rename(from, to))
}
lock_file <- function(filepath)
{
locked_path <- .locked_path(filepath)
## Must wait if the file is already locked.
while (TRUE) {
if (.safe_file_rename(filepath, locked_path))
break
Sys.sleep(0.01)
}
locked_path
}
unlock_file <- function(filepath)
{
locked_path <- .locked_path(filepath)
if (!.safe_file_rename(locked_path, filepath))
stop("failed to unlock '", filepath, "' file")
}
### - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - - -
### A global counter that is safe to use in the context of parallelized
### execution
###
.read_counter <- function(filepath)
{
counter <- readLines(filepath)
stopifnot(length(counter) == 1L)
counter <- suppressWarnings(as.integer(counter))
if (is.na(counter))
stop("file '", filepath, "' does not contain a counter")
counter
}
### Will overwrite an existing file.
.write_counter <- function(counter, filepath)
{
writeLines(as.character(counter), filepath)
counter
}
### NOT safe to use in the context of parallel execution!
init_global_counter <- function(filepath, counter=1L)
{
if (!isSingleString(filepath) || filepath == "")
stop("'filepath' must be a single non-empty string")
if (file.exists(filepath))
stop("file '", filepath, "' already exists")
if (!isSingleNumber(counter))
stop("'counter' must be a single number")
if (!is.integer(counter))
counter <- as.integer(counter)
.write_counter(counter, filepath)
}
### Use a lock mechanism to prevent several processes from trying to increment
### the counter simultaneously. So is safe to use in the context of parallel
### execution e.g.
###
### library(BiocParallel)
### filepath <- tempfile()
### init_global_counter(filepath)
### bplapply(1:10, function(i) get_global_counter(filepath, increment=TRUE))
###
get_global_counter <- function(filepath, increment=FALSE)
{
if (!isTRUEorFALSE(increment))
stop("'increment' must be TRUE or FALSE")
locked_path <- lock_file(filepath)
on.exit(unlock_file(filepath))
counter <- .read_counter(locked_path)
if (increment)
.write_counter(counter + 1L, locked_path)
counter
}
|
