diff --git a/DESCRIPTION b/DESCRIPTION index 03765d3..6fe6e64 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,8 +1,8 @@ Package: Rfits Type: Package Title: FITS Readers and Writers -Version: 1.20.0 -Date: 2026-09-18 +Version: 1.23.0 +Date: 2026-09-23 Authors@R: c( person(given='Aaron', family='Robotham', email='aaron.robotham@uwa.edu.au', role=c('aut', 'cre'), comment=c(ORCID='0000-0003-0429-3579')), @@ -11,8 +11,8 @@ Authors@R: c( Maintainer: Aaron Robotham Description: Read and write FITS images, tables and headers. Has a mixture of fairly low level and very high level routines. Many methods for conveniently operating on FITS files are included. License: LGPL-3 -Imports: Rcpp, bit64, checkmate, foreach, doParallel, magicaxis -Suggests: data.table, FITSio, testthat, hdf5r, zarr, paws.storage (>= 0.9), ProFound, tdigest, R.utils, Rwcs (>= 1.8.7), knitr, rmarkdown, jsonlite +Imports: Rcpp, bit64, checkmate, foreach, doParallel, parallel, magicaxis +Suggests: data.table, FITSio, testthat, withr, hdf5r, zarr, paws.storage (>= 0.9), arrow, ProFound, tdigest, R.utils, Rwcs (>= 1.8.7), knitr, rmarkdown, jsonlite, shiny, bslib, plotly, DT, zip, fontawesome, promises, future, digest Remotes: asgr/Rwcs, asgr/ProFound diff --git a/NAMESPACE b/NAMESPACE index c312a47..0ba759b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -10,7 +10,7 @@ import("doParallel") #import functions -importFrom("utils", "object.size") +importFrom("utils", "object.size", "head") importFrom("graphics", "plot", "lines") importFrom("magicaxis", "magimage") @@ -110,6 +110,10 @@ export(Rfits_inspect_zarr) export(Rfits_s3_store_new) export(Rfits_dir_to_zarr) export(Rfits_cutout_zarr_dir) +export(Rfits_cutout_app) +export(Rfits_zarr_index) +export(Rfits_zarr_index_query) +export(Rfits_zarr_index_info) export(Rfits_length) export(Rfits_dim) @@ -150,6 +154,7 @@ S3method("print", Rfits_vector) S3method("print", Rfits_pointer) S3method("print", Rfits_pointer_zarr) S3method("print", Rfits_header) +S3method("print", Rfits_zarr_index_info) #S3method("print", Rfits_keylist) S3method("print", Rfits_list) diff --git a/R/Rfits_cutout_app.R b/R/Rfits_cutout_app.R new file mode 100644 index 0000000..a852102 --- /dev/null +++ b/R/Rfits_cutout_app.R @@ -0,0 +1,42 @@ +#Launch the bundled Shiny app for browsing and cutting out Zarr stores. +# +#The app itself is a single file under inst/shiny, so it can also be run directly with +#shiny::runApp(system.file('shiny', 'Rfits_cutout_app', package = 'Rfits')). This wrapper +#exists so that the dependency checks happen once, in R, where they can name the missing +#package, rather than as a failed requireNamespace deep inside the app's UI. + +Rfits_cutout_app = function(launch.browser = getOption('shiny.launch.browser', interactive()), + display.mode = c('normal', 'static'), + port = NULL, ...){ + #The same list the app checks for itself, so that a missing package is named here + #rather than reported from inside the app's own startup + need = c('shiny', 'bslib', 'plotly', 'Rwcs', 'arrow', 'data.table') + missing = need[!vapply(need, requireNamespace, logical(1), quietly = TRUE)] + if(length(missing) > 0){ + stop('Rfits_cutout_app needs: ', paste(missing, collapse = ', '), + '. Please install them from CRAN.', call. = FALSE) + } + app = system.file('shiny', 'Rfits_cutout_app', package = 'Rfits') + if(!nzchar(app) || !file.exists(file.path(app, 'app.R'))){ + #An empty path is what a namespace installed without its inst directory looks like, + #which is worth saying plainly rather than letting runApp report a missing app_dir + stop('The bundled app was not found inside the Rfits installation. Reinstall the ', + 'package from source.', call. = FALSE) + } + #Optional in the same sense the app treats them: a table without pagination and a + #download that cannot be zipped are both worse than useful, so they are advice rather + #than a refusal + for(opt in c('DT', 'zip')){ + if(!requireNamespace(opt, quietly = TRUE)){ + message('Install the ', opt, ' package for ', + if(opt == 'DT') 'paged tables in the app.' else 'bulk downloads from the app.') + } + } + display.mode = match.arg(display.mode) + args = list(appDir = app, launch.browser = launch.browser, + display.mode = display.mode) + if(!is.null(port)){ + args$port = port + } + return(do.call(shiny::runApp, c(args, list(...)))) +} diff --git a/R/Rfits_cutout_zarr.R b/R/Rfits_cutout_zarr.R index df8479e..4fd7b08 100644 --- a/R/Rfits_cutout_zarr.R +++ b/R/Rfits_cutout_zarr.R @@ -159,20 +159,6 @@ return(unique(out)) } -#Can a cached tile record build a lazy pointer? Only 'ok' stores are ever pointed at, -#and those must carry the untrimmed keywords and the array type; an entry written -#before the cache held either is treated as a miss and re-read, rather than handed -#back as a pointer whose header is quietly missing an axis. -.zarr_cache_entry_usable = function(info){ - if(is.null(info)){ - return(FALSE) - } - if(!identical(info$status, 'ok')){ - return(TRUE) - } - return(!is.null(info$full_keyvalues) && !is.null(info$type) && !is.null(info$dim)) -} - #Is the prefix itself a store? The root group document is the only thing that makes a #prefix a store, and it is one small key, so this is worth asking before listing. The #tri state probe is deliberately not used as a veto: a prefix that cannot be probed is @@ -568,34 +554,6 @@ Rfits_cutout_zarr_dir = function(dir = NULL, filelist = NULL, pattern = NULL, remote = !is.null(bucket) client = NULL - #The cache is loaded before the store list is built, because the listing of a - #remote prefix is itself one of the things worth caching: finding the stores costs - #a request per directory, and a bucket laid out as one directory of tiles pays - #that on every search. Metadata entries are keyed by store and extension; this one - #entry is keyed by the whole spec of the walk, so a narrower prefix or a different - #pattern cannot be served from a listing that did not make them. - cache_path = NULL - cached = list() - list_key = NULL - walked = NULL - if(!is.null(cache)){ - cache_path = path.expand(cache) - if(!isTRUE(refresh) && file.exists(cache_path)){ - loaded = tryCatch(readRDS(cache_path), error = function(e) NULL) - if(is.list(loaded)){ - cached = loaded - } - } - if(remote){ - #max_dirs is part of the spec because a walk that stopped early holds a partial - #list, and reusing that as though it were complete would be worse than the cost - #of walking again - list_key = paste0('LIST|', bucket, '|', prefix, '|', isTRUE(recursive), '|', - paste0(pattern, collapse = ','), '|', max_dirs) - } - } - cached_list = if(is.null(list_key)) NULL else cached[[list_key]] - if(remote){ if(!requireNamespace('paws.storage', quietly = TRUE)){ stop('The paws.storage package is needed to search a Zarr directory over S3. ', @@ -614,178 +572,124 @@ Rfits_cutout_zarr_dir = function(dir = NULL, filelist = NULL, pattern = NULL, access_key = creds$access_key, secret_key = creds$secret_key, session_token = creds$session_token)) - if(is.null(cached_list)){ - #A walk that gave up at max_dirs holds a partial list, and caching that would - #hide stores from every later search without saying so. Catching the warning - #here rather than in the helper keeps the batch paths untouched. - truncated = FALSE - filelist = withCallingHandlers( - .zarr_s3_find_stores(client, bucket, prefix, recursive = recursive, - pattern = pattern, max_dirs = max_dirs), - warning = function(w){ - #No muffleRestart here, so the warning still reaches the caller: it is - #their only notice that the search saw part of the directory - if(grepl('directories; use a narrower prefix', conditionMessage(w))){ - truncated <<- TRUE - } - }) - #Remember that this run paid for the walk, so the list is worth caching - if(!truncated){ - walked = filelist - } - }else{ - #Served straight from the cache. A listing whose directories were walked - #cannot be checked against the bucket without walking it again, which is the - #request refresh exists to skip, so this is trusted exactly as a cached header - #is and is reported as such when verbose. - filelist = as.character(cached_list) - if(verbose){ - message('Using cached store list for s3://', bucket, '/', - .zarr_s3_prefix(prefix), ' (', length(filelist), - ' stores); refresh = TRUE to re-list') - } - } - if(length(filelist) == 0){ - stop('No Zarr stores found under s3://', bucket, '/', .zarr_s3_prefix(prefix), - if(length(pattern) > 0) ' with the given pattern' else '', '!', call. = FALSE) - } - }else{ - if(is.null(filelist)){ - dir = path.expand(dir) - if(!dir.exists(dir)){ - stop('Directory does not exist: ', dir, call. = FALSE) + } + + #The index, if one is held for this store set. It is opened before anything is read + #because it answers two questions: which stores exist under a remote prefix, and what + #their headers say. A remote one is downloaded whole to a temporary file, since every + #query against it is an arrow scan and a scan needs a seekable file. + idx_path = NULL + idx_rows = NULL + idx_at = NULL + idx_src = NULL + if(!is.null(cache)){ + src = .zarr_index_open(cache, bucket = bucket, prefix = prefix, client = client) + if(!is.null(src$path)){ + ver = .zarr_index_version_of(src$path) + if(is.na(ver) || ver > .zarr_index_version){ + .zarr_index_close(src) + stop('The Zarr index at ', src$shown, ' is not a readable Rfits index (version ', + if(is.na(ver)) 'missing' else ver, '). Rebuild it with ', + 'Rfits_zarr_index(index = ..., refresh = TRUE).', call. = FALSE) } - #A Zarr store is a directory, so the search is for directories, not files. - #list.files reports what is below dir and never dir itself, so a directory named - #*.zarr is offered as its own store here, matching the remote path which probes - #the prefix before listing it. - filelist = character(0) - if(grepl('\\.zarr$', dir)){ - filelist = dir + #The file is kept open even when its rows are being ignored, because the merge at the + #end still needs the rows of stores this run is not searching. refresh means "do not + #trust these entries", not "these rows never existed". + idx_src = src + idx_path = src$path + if(!isTRUE(refresh)){ + idx_rows = .zarr_index_light_rows(idx_path) + idx_at = stats::setNames(as.list(seq_len(nrow(idx_rows))), idx_rows$cache_key) } - found = list.files(dir, full.names = TRUE, include.dirs = TRUE, - recursive = recursive) - filelist = c(filelist, grep('\\.zarr$', found, value = TRUE)) - filelist = filelist[dir.exists(filelist)] }else{ - filelist = path.expand(filelist) - filelist = filelist[dir.exists(filelist)] - } - if(length(pattern) > 0){ - for(p in pattern){ - filelist = grep(p, filelist, value = TRUE) - } - } - filelist = sort(unique(filelist)) - if(length(filelist) == 0){ - stop('No Zarr stores found', if(!is.null(dir)) paste0(' in ', dir) else '', - if(length(pattern) > 0) ' with the given pattern' else '', '!', call. = FALSE) + .zarr_index_close(src) } } + #The downloaded copy of a remote index is this call's own temporary file, and nothing + #after the scan needs it, so it goes whatever the search returns + on.exit(.zarr_index_close(idx_src)) + #The stores to search. This comes after the index has been opened because the index + #holds the listing of a remote prefix, and reading a cached walk out of it is the only + #way a search avoids a request per directory. Both this and the standalone builder go + #through .zarr_index_find_stores so they cannot disagree about which store is which, or + #about what makes a cached listing the one asked for. + stores = .zarr_index_find_stores(dir = dir, filelist = filelist, pattern = pattern, + recursive = recursive, bucket = bucket, + prefix = prefix, max_dirs = max_dirs, + index_path = idx_path, refresh = refresh, + client = client, verbose = verbose) + filelist = stores$store Nstore = length(filelist) - labels = if(remote) paste0('s3://', bucket, '/', filelist) else filelist - - #A cached copy of the search metadata, keyed by store and extension (the listing is - #keyed separately, above). Local entries are validated against the size and mtime - #of the metadata file, which costs a stat and so cannot go stale unnoticed. Over - #S3 the only check available would be the request the cache exists to avoid, so a - #cached remote entry is trusted and refresh = TRUE is the documented way to ignore it. - fresh = list() - if(!is.null(cache_path)){ - #Untouched entries carry over. A run filtered by pattern searches a subset of the - #stores, and rebuilding the cache from only that subset would quietly discard the - #work every other run had put into it. - fresh = cached - if(!is.null(list_key)){ - #Either the listing this run just walked and may keep, or the one it was served - #and must not drop. Only the exact spec that was searched is recorded, so a run - #narrowed by pattern cannot make a broad listing out of a partial one. - fresh[[list_key]] = if(is.null(cached_list)) walked else cached_list - } - } + labels = stores$label + client = stores$client + #The search works on the light rows, which carry everything the cone filter reads but + #not the keywords. A store's keywords are only needed once it has survived that filter, + #and they are the bulk of the index, so they are fetched for the candidates rather than + #for every store in the directory (see .zarr_index_heavy_col). tiles = vector(mode = 'list', length = Nstore) status = rep(NA_character_, Nstore) used_ext = rep(NA_character_, Nstore) store_errors = rep(NA_character_, Nstore) + #Where each tile's keywords are: in the index, to be fetched, or already in hand + from_index = rep(FALSE, Nstore) + idx_use = vector(mode = 'list', length = Nstore) + new_rows = vector(mode = 'list', length = Nstore) for(i in seq_len(Nstore)){ store = filelist[i] got = NULL fail = NULL for(name in extname){ - entry = NULL - stamp = NA_character_ - if(!is.null(cache_path)){ - hit = cached[[paste0(labels[i], '|', name)]] - #An entry written before the format carried the full keywords and the array - #type cannot build a correct lazy pointer (a cube would lose its third axis), - #so it counts as a miss and is rewritten by the read below - if(!is.null(hit) && !.zarr_cache_entry_usable(hit$info)){ - hit = NULL + key = .zarr_index_store_key(labels[i], name) + at = if(is.null(idx_at)) NULL else idx_at[[key]] + if(!is.null(at)){ + row = idx_rows[at, ] + if(!is.na(row$error) && nzchar(row$error)){ + store_errors[i] = row$error } - if(!is.null(hit)){ - if(remote){ - entry = hit$info - }else{ - info_stat = file.info(file.path(store, .zarr_meta_key(name))) - if(isTRUE(info_stat$exists) && !is.na(info_stat$size)){ - stamp = paste0(info_stat$size, '-', as.numeric(info_stat$mtime)) - if(identical(hit$stamp, stamp)){ - entry = hit$info - } - } - } - } - } - - if(!is.null(entry)){ - got = entry - }else if(remote){ - meta = .zarr_meta_from_s3(client, bucket, store, name) - if(is.null(meta)){ - next + #A row written without the full keywords and the array type cannot build a correct + #lazy pointer (a cube would lose its third axis), so it counts as a miss and is + #rewritten by the read below + ok_row = .zarr_index_row_usable(row) + if(ok_row && !remote){ + #Local rows are checked against the size and mtime of the metadata document, + #which costs a stat and so cannot go stale unnoticed. Over S3 the only check + #available is the request the index exists to avoid, so remote rows are trusted + #and refresh = TRUE is the documented way to ignore them. + ok_row = identical(row$stamp, .zarr_index_stamp(store, name)) } - if(!is.null(attr(meta, 'error'))){ - fail = attr(meta, 'error') + if(ok_row){ + got = .zarr_index_tile(row) + from_index[i] = TRUE + idx_use[i] = at + used_ext[i] = name break } - got = .zarr_cutout_tile_info(meta$keyvalues, meta$shape) - }else{ - meta = .zarr_meta_from_dir(store, name) - if(is.null(meta)){ - #Either a v2 store or one whose array is not named as asked. Only now is it - #worth opening the store properly, which also gives a better message than - #'not found' when the store is genuinely unreadable. - opened = tryCatch(Rfits_point_zarr(store, extname = name, header = TRUE), - error = function(e) e) - if(inherits(opened, 'error')){ - msg = conditionMessage(opened) - if(grepl('does not exist in the Zarr store', msg)){ - next - } - fail = msg - break - } - got = .zarr_cutout_tile_info(opened$keyvalues, opened$dim) - }else{ - got = .zarr_cutout_tile_info(meta$keyvalues, meta$shape) - } } - if(!is.null(cache_path)){ - fresh[[paste0(labels[i], '|', name)]] = list(stamp = stamp, info = got) + read = .zarr_store_meta(store, label = labels[i], extname = name, + remote = remote, client = client, bucket = bucket) + if(is.null(read$extname)){ + if(!is.null(read$info)){ + #A store that could not be read at all is a failure rather than a filtering + #choice, and the reason is reported whatever verbose says + fail = read$info$error + } + next } + got = read$info used_ext[i] = name + stamp = if(remote){ + NA_character_ + }else{ + .zarr_index_stamp(store, name) + } + new_rows[[i]] = .zarr_index_store_row(labels[i], store, name, got, stamp = stamp) break } - #A store that could not be read at all, or that holds none of the extensions asked - #for, is a failure rather than a filtering choice, so it is reported whatever - #verbose says. It is counted here and reported once after the loop: a directory of - #a thousand tiles with one typo in extname would otherwise emit a thousand - #identical warnings, which hides the message rather than making it. if(!is.null(fail)){ status[i] = 'error' store_errors[i] = fail @@ -800,18 +704,43 @@ Rfits_cutout_zarr_dir = function(dir = NULL, filelist = NULL, pattern = NULL, tiles[[i]] = got } - if(!is.null(cache_path)){ - saved = tryCatch({saveRDS(fresh, cache_path); TRUE}, error = function(e) FALSE) + #Built only when there is somewhere to put it. Assembling the rows means a data.table of + #every header this run read, which a search without a cache has no use for and no reason + #to depend on data.table and arrow for + fresh = NULL + if(!is.null(cache)){ + added = new_rows[!vapply(new_rows, is.null, logical(1))] + #The version travels with every write, including the first, since an index that cannot + #say which version it is cannot be read back safely + fresh = .zarr_index_rows(c(added, list(.zarr_index_meta_row('index_version', + .zarr_index_version)))) + if(!is.null(stores$walked)){ + fresh = .zarr_index_merge(fresh, .zarr_index_rows( + list(.zarr_index_walk_row(stores$walk_key, stores$walked)))) + } + } + if(!is.null(cache) && !is.null(fresh) && nrow(fresh) > 0){ + #The whole file is read first because a merge that carried rows over without their + #keywords would quietly strip the stores this run did not visit. That is the one place + #where loading an index rather than querying it is right, and it is a few hundred kB. + #A failed write is a warning rather than an error: the search already has its answers, + #and losing them because a cache could not be updated would be the worse outcome. + saved = tryCatch({ + if(!is.null(idx_path)){ + fresh = .zarr_index_merge(.zarr_index_load_all(idx_path), fresh) + } + .zarr_index_put(fresh, cache, bucket = bucket, prefix = prefix, client = client) + TRUE + }, error = function(e) e) if(!isTRUE(saved) && verbose){ - warning('Could not write the metadata cache: ', cache_path, call. = FALSE) + warning('Could not write the Zarr index: ', conditionMessage(saved), call. = FALSE) } } - #One warning per distinct reason rather than per store. The reason is usually a - #property of the request (a mistyped extname, a directory that is not a store at - #all) and so repeats for every store in the directory, and a thousand identical - #warnings is noise that buries the message rather than a way of making it. The - #per store detail is left in the scan table for whoever needs it. + #A store that could not be read, or that holds none of the extensions asked for, is a + #failure rather than a filtering choice. It is counted here and reported once after the + #loop: a directory of a thousand tiles with one typo in extname would otherwise emit a + #thousand identical warnings, which hides the message rather than making it. skipped = which(status %in% c('error', 'noext')) if(length(skipped) > 0){ reasons = store_errors[skipped] @@ -915,6 +844,36 @@ Rfits_cutout_zarr_dir = function(dir = NULL, filelist = NULL, pattern = NULL, #Stores opened so far, so one matched by several positions is not reopened each time open_ptrs = vector(mode = 'list', length = Nstore) + #The keywords of the candidates, now that the cheap stage has said which ones matter. + #This is the second half of the staged read: the light rows gave the coarse filter + #everything it needed without decoding a single header, and only the handful that + #survive to the boundary test have their full header pulled out of the index, by key. + #The order of the survivors is irrelevant, so they are fetched once for all positions + #rather than per position, which keeps it to one scan of the file. + need_kv = which(from_index & !vapply(tiles, function(t) !is.null(t$full_keyvalues), + logical(1))) + cand = unique(unlist(candidates, use.names = FALSE)) + need_kv = intersect(need_kv, cand) + if(length(need_kv) > 0){ + keys = vapply(need_kv, function(i) .zarr_index_store_key(labels[i], used_ext[i]), + character(1)) + pay = .zarr_index_payload_rows(idx_path, keys) + blobs = stats::setNames(as.list(pay$keyvalues), pay$cache_key) + for(i in need_kv){ + key = .zarr_index_store_key(labels[i], used_ext[i]) + tile = .zarr_index_tile(idx_rows[idx_use[[i]], ], keyvalues = blobs[[key]]) + if(identical(tile$status, 'error')){ + #An index row whose blob will not unpick is treated as a miss rather than as a + #store that does not overlap, because that is what it is + status[i] = 'error' + store_errors[i] = tile$error + from_index[i] = FALSE + next + } + tiles[[i]] = tile + } + } + for(k in seq_len(Npos)){ for(i in candidates[[k]]){ tile = tiles[[i]] diff --git a/R/Rfits_image_zarr.R b/R/Rfits_image_zarr.R index 8257c52..82bcefa 100644 --- a/R/Rfits_image_zarr.R +++ b/R/Rfits_image_zarr.R @@ -1397,10 +1397,100 @@ Rfits_read_array_zarr = Rfits_read_image_zarr return(invisible(header)) } +#Split the space into contiguous runs of whole chunks along one axis, so that no two +#bands share a chunk. That is what makes it safe for a worker to write a band without +#reading anything another worker has written: a chunk is only ever opened by one +#process, and zarr flushes a chunk in full. Returns one list per band of the 1 based +#inclusive bounds per dimension, which is what zarr node$write wants as a selection, or +#NULL when no axis has two chunks to split. The highest such axis is used, since R +#stores dim 1 fastest varying, so a band cut along a later axis is contiguous in memory. +.zarr_chunk_bands = function(shape, chunk_shape, nbands){ + Nd = length(shape) + nchunks = ceiling(shape/chunk_shape) + splittable = which(nchunks >= 2) + if(length(splittable) == 0){ + return(NULL) + } + axis = max(splittable) + nch = nchunks[axis] + nbands = min(nbands, nch) + #Whole chunks per band, front loaded, so the bands differ in size by at most one chunk + per = integer(nbands) + rest = nch + for(k in seq_len(nbands)){ + left = nbands - k + 1L + per[k] = ceiling(rest/left) + rest = rest - per[k] + } + hi_chunk = cumsum(per) + lo_chunk = hi_chunk - per + 1L + full = lapply(seq_len(Nd), function(d) c(1L, as.integer(shape[d]))) + return(lapply(seq_len(nbands), function(k){ + sel = full + sel[[axis]] = c(as.integer((lo_chunk[k] - 1L) * chunk_shape[axis] + 1L), + as.integer(min(hi_chunk[k] * chunk_shape[axis], shape[axis]))) + return(sel) + })) +} + +#Write one chunk aligned band, which is the whole of a worker's job. Everything is +#reached through :: or through the job, since a worker starts with nothing from the +#parent. The store is reopened from its path rather than carried across, because a +#store object keeps its data and its connection in the process that opened it. +.zarr_write_band = function(job){ + #Rfits is attached rather than assumed, since the function is reached by name on the + #worker. zarr is not: every call into it here goes through zarr::, which loads the + #namespace without attaching it, and attaching a package from Suggests is what R CMD + #check objects to. + suppressPackageStartupMessages(library(Rfits)) + store = .zarr_store_open(job$filename, write = TRUE) + node = store$get_node(job$path) + node$write(job$band, selection = job$selection) + return(length(job$band)) +} + +#Fan the data out over workers as whole bands +.zarr_write_bands_parallel = function(filename, path, data, shape, chunk_shape, cores){ + bands = .zarr_chunk_bands(shape, chunk_shape, cores) + if(is.null(bands)){ + return(invisible(FALSE)) + } + cluster = parallel::makeCluster(min(cores, length(bands)), type = 'PSOCK') + on.exit(parallel::stopCluster(cluster), add = TRUE) + #The worker is named rather than passed as a function object, because parLapply ships + #a closure together with its environment, and the environment of the caller holds the + #array being written, so every worker would receive its own copy of all of it. A name + #is resolved on the node, which is why it is defined there first. invisible() because + #clusterEvalQ would print the value from every node. + invisible(parallel::clusterEvalQ(cluster, { + #::: and not a bare name. The expression runs on the worker, where Rfits is in the + #namespace but its internals are not on the search path, so a bare .zarr_write_band + #is not found and every band fails before a pixel is written. + zarr_band_worker = Rfits:::.zarr_write_band + })) + jobs = lapply(bands, function(selection){ + #Sliced here rather than in the worker, so what each worker is sent is only its own + #band. This is also why the split is taken along a trailing dimension, since R + #stores the leading dimension fastest and such a band is one contiguous block. + #drop = FALSE because a band that covers a whole axis of length one is otherwise + #flattened to a vector, and a store cannot broadcast that into its selection. + band = do.call(`[`, c(list(data), lapply(selection, function(b) b[1]:b[2]), + list(drop = FALSE))) + return(list(filename = filename, path = path, selection = selection, band = band)) + }) + counts = parallel::parLapply(cluster, jobs, 'zarr_band_worker') + written = sum(vapply(counts, function(n) if(is.numeric(n)) n else 0, numeric(1))) + if(!identical(as.numeric(written), as.numeric(prod(shape)))){ + stop('The parallel Zarr write only covered ', written, ' of ', prod(shape), + ' pixels!', call. = FALSE) + } + return(invisible(TRUE)) +} + Rfits_write_image_zarr = function(data, filename='temp.zarr', extname='data1', create_ext=TRUE, overwrite_file=FALSE, data_type=NULL, chunk_shape=NULL, clevel=6L, compressor='blosc', shuffle=NULL, - append=FALSE, update_root=TRUE, + append=FALSE, update_root=TRUE, cores=NULL, keyvalues, keycomments, keynames, comment, history){ .zarr_require() @@ -1417,6 +1507,7 @@ Rfits_write_image_zarr = function(data, filename='temp.zarr', extname='data1', c assertFlag(append) assertFlag(update_root) assertIntegerish(clevel, len=1, lower=0, upper=9) + assertIntegerish(cores, len=1, lower=1, null.ok=TRUE) if(append & overwrite_file){ stop('Cannot use both append and overwrite_file!', call. = FALSE) @@ -1517,6 +1608,14 @@ Rfits_write_image_zarr = function(data, filename='temp.zarr', extname='data1', c #Appending grows the array that is already there, so it has to branch before #anything is deleted or created if(append){ + #Appending has to resize the array before any of it can be written, and a resize is + #a single metadata operation that the bands cannot be arranged around, so the + #increment is written in one. Said out loud because a caller who sets cores batch + #wide would otherwise have no idea which of their appends were parallel. + if(!is.null(cores)){ + message('cores is ignored when append = TRUE; the increment is written in one.', + call. = FALSE) + } return(invisible(.zarr_append(store = store, extname = extname, data = data, shape = shape, typed = typed, data_type_requested = data_type, @@ -1552,7 +1651,35 @@ Rfits_write_image_zarr = function(data, filename='temp.zarr', extname='data1', c node = store$add_array('/', sub('^/', '', extname), .zarr_array_metadata(builder, store$store)) - node$write(data) + #The pixels go in either as one write or as a set of disjoint bands, and the metadata + #afterwards either way, since the bands write into the array the node already describes + in_bands = FALSE + if(!is.null(cores)){ + #A store object cannot be handed to a worker. zarr keeps a store's contents in + #memory for some store types, and a client connected by the parent for others, so + #whatever a worker wrote would either be invisible here or go through a connection + #that belongs to another process. Only a path names a store two processes can each + #open for themselves, which is what makes the parallel write safe. + if(filename_is_store){ + message('cores is ignored for a Zarr store object, since only a local store path ', + 'can be opened by the workers independently. The array is written in one.', + call. = FALSE) + }else{ + in_bands = .zarr_write_bands_parallel(filename = filename, path = path, data = data, + shape = shape, chunk_shape = chunk_shape, + cores = cores) + if(!in_bands){ + message('cores is ignored: no dimension of ', paste(shape, collapse = ' x '), + ' is large enough to hold two ', paste(chunk_shape, collapse = ' x '), + ' chunks, so there is nothing to split. The array is written in one.', + call. = FALSE) + } + } + } + + if(!in_bands){ + node$write(data) + } #FITS style metadata, stored as attributes on the array node if(!is.null(header)){ @@ -1634,11 +1761,94 @@ Rfits_append_array_zarr = Rfits_append_image_zarr #The FITS names the readers take, matched the way Rfits_key_scan matches them .zarr_fits_pattern = '\\.(fits|fit)(\\.gz)?$' +#Convert one FITS file to one store and report what happened as a single row. Kept +#out of Rfits_dir_to_zarr so that the serial and parallel paths run exactly the same +#code, and so that nothing here writes into a shared data frame from inside a worker, +#where the row would be lost the moment it came back. +# +#Both the progress message and the warning about a skipped file are raised in here +#rather than by the caller, so that the serial path reports a file the moment it is +#handled, exactly as it did before this was pulled out of the loop. In a worker the +#message streams out as it is raised, but the warning is collected and only raised +#once the batch is over, which is later but not lost. +.zarr_convert_one = function(i, fullnames, filelist, stubs, target, prefix, + bucket, region, endpoint, access_key, secret_key, + session_token, ext, extname, args, verbose = TRUE){ + remote = !is.null(bucket) + + file_in = fullnames[i] + name_out = stubs[i] + + #Decided before the read, so a file that fails still records where it was aimed + if(remote){ + store_prefix = paste0(.zarr_s3_prefix(prefix), name_out) + dest = paste0('s3://', bucket, '/', store_prefix) + shown = paste0(bucket, '/', store_prefix) + }else{ + dest = file.path(target, name_out) + shown = dest + } + + if(verbose){ + message('[', i, '/', length(fullnames), '] ', filelist[i], ' -> ', shown) + } + + #Recorded rather than returned directly, because an assignment inside a handler is + #local to that handler and would be lost the moment the loop moved on + written = NULL + nkey = NA_integer_ + fail = NULL + + tryCatch({ + data = Rfits_read_image(file_in, ext = ext, header = TRUE) + if(!inherits(data, c('Rfits_vector', 'Rfits_image', 'Rfits_cube', 'Rfits_array'))){ + stop('Extension ', ext, ' of ', basename(file_in), ' is not an image!') + } + nkey = length(data$keyvalues) + + if(remote){ + #One store per file, so the store object is built per iteration + store = .zarr_s3_store_for(bucket = bucket, prefix = store_prefix, region = region, + endpoint = endpoint, access_key = access_key, + secret_key = secret_key, session_token = session_token) + }else{ + store = dest + } + + written = do.call(Rfits_write_image_zarr, + c(list(data = data, filename = store, extname = extname), args)) + }, error = function(e) { + fail <<- conditionMessage(e) + }) + + if(is.null(fail)){ + #The writer reports the name it used, which for a store object is the URI + #including the trailing slash. The pre-computed dest is kept for a failure, + #where it records what the run was aimed at + return(list(store = written$filename, + dim = paste(written$dim, collapse = 'x'), + data_type = written$data_type, + nkey = nkey, + status = 'ok', + error = NA_character_)) + } + + if(verbose){ + warning('Skipping ', basename(file_in), ': ', fail, call. = FALSE) + } + return(list(store = dest, + dim = NA_character_, + data_type = NA_character_, + nkey = NA_integer_, + status = 'error', + error = fail)) +} + Rfits_dir_to_zarr = function(dir = NULL, filelist = NULL, pattern = NULL, recursive = TRUE, target = NULL, bucket = NULL, prefix = '', region = NULL, endpoint = NULL, access_key = NULL, secret_key = NULL, session_token = NULL, - ext = 1L, extname = 'data1', verbose = TRUE, ...){ + ext = 1L, extname = 'data1', cores = NULL, verbose = TRUE, ...){ .zarr_require() assertString(dir, null.ok = TRUE) @@ -1655,6 +1865,7 @@ Rfits_dir_to_zarr = function(dir = NULL, filelist = NULL, pattern = NULL, recurs assertString(session_token, null.ok = TRUE) assertIntegerish(ext, len = 1) assertString(extname) + assertIntegerish(cores, len = 1, lower = 1, null.ok = TRUE) #Reading the credentials out of the environment is worth doing here, since the #alternative is a key in a script and this function exists to be scripted. bucket @@ -1767,72 +1978,70 @@ Rfits_dir_to_zarr = function(dir = NULL, filelist = NULL, pattern = NULL, recurs status = rep(NA_character_, Nfile), error = rep(NA_character_, Nfile), stringsAsFactors = FALSE) + #The per-file index is supplied by the caller, and deliberately not given a value + #here: an entry in this list would collide with the one added by do.call + batch = c(list(fullnames = fullnames, filelist = filelist, stubs = stubs, + target = target, prefix = prefix, bucket = bucket, region = region, + endpoint = endpoint, access_key = access_key, secret_key = secret_key, + session_token = session_token, ext = ext, extname = extname, + args = args, verbose = verbose)) + + if(is.null(cores)){ + rows = lapply(seq_len(Nfile), function(i){ + return(do.call(.zarr_convert_one, c(list(i = i), batch))) + }) + }else{ + #A cluster owned by this call rather than registerDoParallel plus %dopar%, because + #that pair changes a backend shared by the whole session. Registering here would + #take over a cluster the caller had made, and the one made here would stay + #registered after this call returned, so their next %dopar% would fail with a + #message about dead workers that points nowhere near here. PSOCK on every platform, + #since forking with cfitsio and OpenMP state in the parent is not safe. + #More workers than files only pays for idle processes, hence the cap. + # + #outfile = '' is what makes the per-file progress visible: without it a message + #raised in a worker is swallowed, and a batch that takes an hour would report + #nothing at all until it finished. The cost is one 'starting worker' line each. + cluster = parallel::makeCluster(min(cores, Nfile), type = 'PSOCK', outfile = '') + #The cluster is stopped on the way out even if a worker dies, since idle workers + #would each hold the memory of a whole image until the session ended + on.exit(parallel::stopCluster(cluster), add = TRUE) + #Workers start empty, so the package has to be loaded there before the helper can be + #found. zarr is not attached: the reader and the writer reach it through zarr::, and + #attaching a package from Suggests is what R CMD check objects to + parallel::clusterEvalQ(cluster, { + suppressPackageStartupMessages(library(Rfits)) + return(NULL) + }) + #Each file is read, compressed and written by one worker, so the parallelism is + #embarrassing: no worker touches a store another worker has opened + rows = parallel::parLapply(cluster, seq_len(Nfile), function(i){ + #Wrapped again because the helper catches what it expects to catch, and anything + #else should still cost one row rather than the whole batch + tryCatch(do.call(.zarr_convert_one, c(list(i = i), batch)), + error = function(e){ + return(list(store = NA_character_, dim = NA_character_, + data_type = NA_character_, nkey = NA_integer_, + status = 'error', + error = paste0('worker failed: ', conditionMessage(e)))) + }) + }) + } + n_ok = 0L n_fail = 0L - for(i in seq_len(Nfile)){ - file_in = fullnames[i] - name_out = stubs[i] - - #Decided before the read, so a file that fails still records where it was aimed - if(remote){ - store_prefix = paste0(.zarr_s3_prefix(prefix), name_out) - dest = paste0('s3://', bucket, '/', store_prefix) - shown = paste0(bucket, '/', store_prefix) - }else{ - dest = file.path(target, name_out) - shown = dest - } - - if(verbose){ - message('[', i, '/', Nfile, '] ', filelist[i], ' -> ', shown) - } - - #Recorded rather than returned, because an assignment inside a handler is local - #to that handler and would be lost the moment the loop moved on - written = NULL - data = NULL - fail = NULL - - tryCatch({ - data = Rfits_read_image(file_in, ext = ext, header = TRUE) - if(!inherits(data, c('Rfits_vector', 'Rfits_image', 'Rfits_cube', 'Rfits_array'))){ - stop('Extension ', ext, ' of ', basename(file_in), ' is not an image!') - } - - if(remote){ - #One store per file, so the store object is built per iteration - store = .zarr_s3_store_for(bucket = bucket, prefix = store_prefix, region = region, - endpoint = endpoint, access_key = access_key, - secret_key = secret_key, session_token = session_token) - }else{ - store = dest - } - - written = do.call(Rfits_write_image_zarr, - c(list(data = data, filename = store, extname = extname), args)) - }, error = function(e) { - fail <<- conditionMessage(e) - }) - - if(is.null(fail)){ - #The writer reports the name it used, which for a store object is the URI - #including the trailing slash. The pre-computed dest is kept for a failure, - #where it records what the run was aimed at - output$store[i] = written$filename - output$dim[i] = paste(written$dim, collapse = 'x') - output$data_type[i] = written$data_type - output$nkey[i] = length(data$keyvalues) - output$status[i] = 'ok' + row = rows[[i]] + output$store[i] = row$store + output$dim[i] = row$dim + output$data_type[i] = row$data_type + output$nkey[i] = row$nkey + output$status[i] = row$status + output$error[i] = row$error + if(identical(row$status, 'ok')){ n_ok = n_ok + 1L }else{ - output$store[i] = dest - output$status[i] = 'error' - output$error[i] = fail n_fail = n_fail + 1L - if(verbose){ - warning('Skipping ', basename(file_in), ': ', fail, call. = FALSE) - } } } diff --git a/R/Rfits_zarr_index.R b/R/Rfits_zarr_index.R new file mode 100644 index 0000000..063d343 --- /dev/null +++ b/R/Rfits_zarr_index.R @@ -0,0 +1,1235 @@ +#A parquet index of the search metadata of a directory (or S3 prefix) of Zarr stores. +# +#Rfits_cutout_zarr_dir decides which stores are worth opening from their headers alone, +#which costs one small read per store. That is a cheap read but not a free one: a release +#of a few thousand tiles asks for a few thousand requests before the first pixel is +#fetched, and every user pays for it again in a new session. The index removes that. It +#holds once what a scan extracts from each store -- the reference position, pixel scale +#and shape that the coarse filter reads, and the full keywords a lazy pointer is built +#from -- in a single parquet file, which can sit beside the tiles it describes so that +#every user queries the same copy instead of rebuilding one. +# +#A few thousand rows is small enough to download whole, but small enough to load is not +#the same as cheap to query, so the rows are asked for in the order a search needs them +#and with arrow's own pushdown rather than by reading a table and subsetting it. First +#the columns the cone filter uses, which are all scalar, so arrow never decodes the +#keyword blob of the thousands of stores nowhere near the position. Then the keywords of +#the handful that survived, selected by store key. arrow also skips whole row groups +#whose statistics cannot match, which is why the file is written in sorted store order. +# +#The file holds three kinds of row, named by the kind column. Store rows carry the +#metadata of one array of one store. Walk rows carry the list of stores found under a +#remote prefix, kept beside the headers because finding them costs a request per directory +#as well. Meta rows are scalars about the file itself, of which the version is the only +#one anyone else reads. + +#The format of the file. An index written by a later version is refused rather than half +#read, because a search that quietly found nothing in a file whose columns had moved would +#look exactly like a directory of tiles that did not overlap. +.zarr_index_version = 1L + +#The payload column: the whole keyword header of a store, serialised. It is one column +#rather than a wide table of keywords because a search needs the header intact (to rebuild +#the trimmed WCS it filters with, and to hand to a pointer), and no keyword is common +#enough across a mixed release to be worth a column of its own. Splitting it off is what +#makes the light pass light. +.zarr_index_heavy_col = 'keyvalues' + +.zarr_index_num_cols = function(){ + return(c('ra', 'dec', 'crpix1', 'crpix2', 'naxis1', 'naxis2', 'pixscale_x', + 'pixscale_y', 'created')) +} + +.zarr_index_list_cols = function(){ + return(c('array_dim', 'stores', 'keyvalues')) +} + +#The columns, in the order they are written. kind separates the three sorts of row; +#cache_key is what they are looked up by, and is a quoted column name rather than key +#because data.table() has an argument of that name. +.zarr_index_cols = function(){ + return(c('kind', 'cache_key', 'store', 'extname', 'label', 'status', 'error', 'type', + 'stamp', .zarr_index_num_cols(), 'has_keyvalues', 'array_dim', 'stores', + 'text_value', .zarr_index_heavy_col)) +} + +#Everything but the keywords, which is what a search filters with +.zarr_index_light_cols = function(){ + return(setdiff(.zarr_index_cols(), .zarr_index_heavy_col)) +} + +#The empty value of a payload column. NULL cannot be used, because arrow works out a list +#column's type from the values it is given and the first row of an index is often one with +#nothing in it (a store that could not be read, or a file with no walk yet). +.zarr_index_empty = function(col){ + if(identical(col, 'keyvalues')){ + return(raw(0)) + } + if(identical(col, 'array_dim')){ + return(integer(0)) + } + return(character(0)) +} + +#The types, pinned rather than inferred for the same reason. A parquet file written by +#hand (or by another tool) is still readable, since nothing here depends on the writer's +#type choices beyond these columns. +#The value of one payload cell, in the form arrow wants: a bare atomic vector, never a +#list of one and never NULL. Rows are built with the wrapped spelling because that is what +#keeps an empty cell typed through data.frame(), while a value read back from parquet +#arrives bare, and a single row subset can arrive as the vector itself. The rule differs +#per column because the three hold different things: keyvalues and array_dim are one +#vector each so a list wrapper is peeled, whereas stores is a vector whose length varies +#per row and so must be flattened rather than peeled. +.zarr_index_cell = function(col, val){ + if(col == 'stores'){ + if(is.null(val)){ + return(character(0)) + } + if(is.list(val)){ + val = unlist(val, use.names = FALSE) + } + if(length(val) == 0){ + return(character(0)) + } + return(as.character(val)) + } + if(is.list(val)){ + val = if(length(val) == 0) NULL else val[[1]] + } + if(is.null(val)){ + return(.zarr_index_empty(col)) + } + if(col == 'array_dim'){ + return(as.integer(val)) + } + return(as.raw(val)) +} + +.zarr_index_schema = function(){ + return(arrow::schema( + kind = arrow::string(), cache_key = arrow::string(), store = arrow::string(), + extname = arrow::string(), label = arrow::string(), status = arrow::string(), + error = arrow::string(), type = arrow::string(), stamp = arrow::string(), + ra = arrow::float64(), dec = arrow::float64(), crpix1 = arrow::float64(), + crpix2 = arrow::float64(), naxis1 = arrow::float64(), naxis2 = arrow::float64(), + pixscale_x = arrow::float64(), pixscale_y = arrow::float64(), + created = arrow::float64(), has_keyvalues = arrow::bool(), + array_dim = arrow::list_of(arrow::int32()), stores = arrow::list_of(arrow::string()), + text_value = arrow::string(), keyvalues = arrow::binary())) +} + +#arrow rather than nanoparquet, the other CRAN parquet reader. arrow is the one that can +#push both a row filter and a column projection into the scan, which is the point of +#querying an index rather than loading a table. data.table is checked alongside it because +#the rows are held as one whatever the file format is, and both are only Suggests. +# +#This is called at the top of the index paths and nowhere else. A search run without a +#cache reads stores and never builds index rows, so it must not be made to depend on +#either package. +.zarr_index_require = function(what = 'to read or write a Zarr index'){ + if(!requireNamespace('arrow', quietly = TRUE)){ + stop('The arrow package is needed ', what, '. Please install it from CRAN.', + call. = FALSE) + } + #Rows are held as a data.table whatever the file format is, and data.table is only a + #Suggests package, so it is checked here rather than left to fail from inside the row + #builder with a bare 'there is no package called data.table' + if(!requireNamespace('data.table', quietly = TRUE)){ + stop('The data.table package is needed ', what, '. Please install it from CRAN.', + call. = FALSE) + } +} + +.zarr_index_blank_row = function(){ + row = lapply(.zarr_index_cols(), function(col){ + if(col %in% .zarr_index_list_cols()){ + return(list(.zarr_index_empty(col))) + } + if(col %in% .zarr_index_num_cols()){ + return(NA_real_) + } + if(identical(col, 'has_keyvalues')){ + return(FALSE) + } + return(NA_character_) + }) + names(row) = .zarr_index_cols() + return(row) +} + +#The key of a store row: which store, and which array of it. One store may hold several +#extensions and they do not share a header, so both are needed. The label is the store as +#the search names it (a path, or an s3:// URI), so a local mirror of a bucket and the +#bucket itself cannot overwrite each other's rows. +.zarr_index_store_key = function(label, extname){ + return(paste0(label, '|', extname)) +} + +#The key of a walk row. max_dirs belongs to the spec because a walk that stopped early +#holds a partial list, and serving a broad search from one would hide stores silently. +.zarr_index_walk_key = function(bucket, prefix, recursive, pattern, max_dirs){ + return(paste0('WALK|', bucket, '|', prefix, '|', isTRUE(recursive), '|', + paste0(pattern, collapse = ','), '|', max_dirs)) +} + +.zarr_index_meta_key = function(name){ + return(paste0('META|', name)) +} + +#A data.table of index rows from a list of one row per store. Built column by column +#rather than with data.frame(), which would turn the list columns into characters, and +#with the payload columns forced to their empty value where a row has nothing. +.zarr_index_rows = function(rows){ + #A data.frame in already, which is what the readers hand back; a list of one row list + #per store, which is what the scan builds + if(is.data.frame(rows)){ + return(.zarr_index_rows_clean(rows)) + } + cols = .zarr_index_cols() + rows = rows[!vapply(rows, is.null, logical(1))] + if(length(rows) == 0){ + out = lapply(cols, function(col){ + if(col %in% .zarr_index_list_cols()){ + return(list()) + } + if(col %in% .zarr_index_num_cols()){ + return(numeric(0)) + } + if(identical(col, 'has_keyvalues')){ + return(logical(0)) + } + return(character(0)) + }) + names(out) = cols + return(data.table::as.data.table(out)) + } + out = lapply(cols, function(col){ + if(col %in% .zarr_index_list_cols()){ + return(lapply(rows, function(r) .zarr_index_cell(col, r[[col]]))) + } + if(col %in% .zarr_index_num_cols()){ + return(vapply(rows, function(r){ + val = r[[col]] + if(is.null(val) || length(val) == 0){ + return(NA_real_) + } + return(as.numeric(val)[1]) + }, numeric(1))) + } + if(identical(col, 'has_keyvalues')){ + return(vapply(rows, function(r) isTRUE(r[[col]]), logical(1))) + } + return(vapply(rows, function(r){ + val = r[[col]] + if(is.null(val) || length(val) == 0){ + return(NA_character_) + } + return(as.character(val)[1]) + }, character(1))) + }) + names(out) = cols + return(data.table::as.data.table(out)) +} + +#The row one searched store contributes. info is what .zarr_cutout_tile_info makes of a +#store's header, which holds both the two axis view the search filters with and the full +#keywords and shape a pointer needs. Only the keywords and the shape are kept beside the +#scalars: the trimmed header is rebuilt from the keywords on read, so the copy a pointer +#carries can never have lost its third axis. +.zarr_index_store_row = function(label, store, extname, info, stamp = NA_character_){ + if(is.null(info)){ + return(NULL) + } + row = .zarr_index_blank_row() + row$kind = 'store' + row$cache_key = .zarr_index_store_key(label, extname) + row$store = store + row$extname = extname + row$label = label + row$status = info$status + if(!is.null(info$error)){ + row$error = info$error + } + row$stamp = stamp + row$created = as.numeric(Sys.time()) + + #A store that could not be searched is recorded all the same, so the next run knows it + #was asked and what the answer was. Without these rows a directory whose extname had + #been mistyped would be re-read in full every time, which is the cost the index exists + #to remove. + if(!identical(info$status, 'ok')){ + return(row) + } + + full = info$full_keyvalues + if(is.null(full)){ + full = info$keyvalues + } + dim = info$dim + if(is.null(dim) || length(dim) == 0 || is.null(full)){ + #Nothing usable to write, so this is a miss rather than a row: an empty ok row would + #make a later search believe the store had already been read + return(NULL) + } + row$type = info$type + row$ra = as.numeric(info$ra) + row$dec = as.numeric(info$dec) + row$crpix1 = as.numeric(info$crpix[1]) + row$crpix2 = as.numeric(info$crpix[2]) + row$naxis1 = as.numeric(info$naxis[1]) + row$naxis2 = as.numeric(info$naxis[2]) + row$pixscale_x = as.numeric(info$scale$x) + row$pixscale_y = as.numeric(info$scale$y) + row$array_dim = list(as.integer(dim)) + row$keyvalues = list(serialize(full, connection = NULL, version = 2)) + row$has_keyvalues = TRUE + return(row) +} + +.zarr_index_walk_row = function(cache_key, stores){ + row = .zarr_index_blank_row() + row$kind = 'walk' + row$cache_key = cache_key + row$stores = list(as.character(stores)) + row$created = as.numeric(Sys.time()) + return(row) +} + +.zarr_index_meta_row = function(name, value){ + row = .zarr_index_blank_row() + row$kind = 'meta' + row$cache_key = .zarr_index_meta_key(name) + row$text_value = as.character(value) + row$created = as.numeric(Sys.time()) + return(row) +} + +#Turn the index row of one store back into the tile record the search works with. Without +#the keywords a tile can be filtered with but not pointed at, which is exactly the state +#the cheap stage wants; with them it is the same list .zarr_cutout_tile_info returns. +.zarr_index_tile = function(row, keyvalues = NULL){ + #The cell helpers are needed rather than the raw column, because a single row pulled out + #of a data.table gives a one element list for a payload column + dim = .zarr_index_cell('array_dim', row$array_dim) + if(length(dim) == 0){ + dim = c(row$naxis1, row$naxis2) + } + tile = list(status = row$status, keyvalues = NULL, full_keyvalues = NULL, + naxis = c(row$naxis1, row$naxis2), + scale = list(x = row$pixscale_x, y = row$pixscale_y), + ra = row$ra, dec = row$dec, crpix = c(row$crpix1, row$crpix2), + store_shape = as.integer(dim), dim = as.integer(dim), type = row$type) + if(is.null(keyvalues) || length(keyvalues) == 0){ + return(tile) + } + full = tryCatch(unserialize(keyvalues), error = function(e) NULL) + if(is.null(full)){ + return(list(status = 'error', error = 'the index keywords could not be unserialised')) + } + #Only the trimmed copy may be given to Rwcs (see .wcs2_axes), and it is rebuilt here + #rather than stored so that the two cannot drift apart + tile$keyvalues = .wcs2_axes(full)$keyvalues + tile$full_keyvalues = full + return(tile) +} + +#Can a row be pointed at? Only 'ok' stores are, and those must carry the full keywords and +#the array type. A row written without them is treated as a miss and re-read, rather than +#handed back as a pointer whose header is quietly missing an axis. +.zarr_index_row_usable = function(row){ + if(is.na(row$status) || !identical(row$status, 'ok')){ + return(TRUE) + } + return(isTRUE(row$has_keyvalues) && !is.na(row$type) && !is.na(row$naxis1)) +} + +#The stamp a local store's metadata file carries, which is what its index row is checked +#against. Size and mtime cost a stat rather than a read, so a header that has genuinely +#changed is noticed on its own rather than waiting for someone to pass refresh. Over S3 +#the only check available is the request the index exists to avoid, so remote rows are +#trusted and refresh is the documented way to ignore them. +.zarr_index_stamp = function(store, extname){ + info = file.info(file.path(store, .zarr_meta_key(extname))) + if(is.na(info$size) || isTRUE(info$isdir) || info$size <= 0){ + return(NA_character_) + } + return(paste0(info$size, '-', as.numeric(info$mtime))) +} + +#arrow expressions, built through arrow's own namespace so that nothing here depends on +#which of the several packages that export read_parquet happens to be attached +.zarr_idx_field = function(col){ + return(arrow::Expression$field_ref(col)) +} + +.zarr_idx_is = function(col, val){ + if(length(val) == 1 && is.na(val)){ + return(arrow::Expression$create('is_null', .zarr_idx_field(col))) + } + return(.zarr_idx_field(col) == arrow::Expression$scalar(val)) +} + +.zarr_idx_and = function(a, b){ + if(is.null(a)){ + return(b) + } + if(is.null(b)){ + return(a) + } + return(arrow::Expression$create('and', a, b)) +} + +.zarr_idx_or = function(a, b){ + if(is.null(a)){ + return(b) + } + if(is.null(b)){ + return(a) + } + return(arrow::Expression$create('or', a, b)) +} + +#A filter matching any of a set of exact keys. arrow's is_in cannot be built from R in the +#version this was written against, so the keys are or-ed, which is what arrow's own dplyr +#backend does for %in% as well. The set is the survivors of the cheap stage and so is +#small; a search that needed thousands of keys would be better off reading the whole light +#pass, which it has already done. +.zarr_idx_keys = function(col, keys){ + ex = NULL + for(k in keys){ + ex = .zarr_idx_or(ex, .zarr_idx_is(col, k)) + } + return(ex) +} + +#Query an index file. Every read of an index goes through the scanner rather than through +#read_parquet and [ so that unqueried columns are never decoded and row groups whose +#statistics cannot match are never read; a file with nothing to return is the ordinary +#case for a search over one corner of a big release, not an error. +.zarr_index_scan = function(path, cols, filter = NULL){ + .zarr_index_require('to read a Zarr index') + tab = arrow::Scanner$create(arrow::open_dataset(path), projection = cols, + filter = filter)$ToTable() + out = as.data.frame(tab, stringsAsFactors = FALSE) + #A zero row result drops the list columns to something unusable, so they are restored + #to the shape the callers index by + for(col in .zarr_index_list_cols()){ + if(col %in% cols){ + out[[col]] = if(nrow(out) == 0){ + list() + }else{ + as.list(out[[col]]) + } + } + } + return(out) +} + +#The rows a search filters with, which is every column but the keywords. +.zarr_index_light_rows = function(path){ + return(.zarr_index_scan(path, .zarr_index_light_cols(), .zarr_idx_is('kind', 'store'))) +} + +#The keywords of specific stores, by key. Kept apart from the light pass so the blobs of +#the stores that were filtered out are never read. +.zarr_index_payload_rows = function(path, keys){ + cols = c('cache_key', .zarr_index_heavy_col) + if(length(keys) == 0){ + #The same columns, no rows. Filtering on an impossible key keeps the shape of the + #result the same as a query that matched, which is what the callers index by. + return(.zarr_index_scan(path, cols, .zarr_idx_is('cache_key', NA_character_))) + } + return(.zarr_index_scan(path, cols, .zarr_idx_keys('cache_key', keys))) +} + +.zarr_index_walk_rows = function(path, keys = NULL){ + ex = .zarr_idx_is('kind', 'walk') + if(!is.null(keys)){ + ex = .zarr_idx_and(ex, .zarr_idx_keys('cache_key', keys)) + } + return(.zarr_index_scan(path, c('kind', 'cache_key', 'stores', 'created'), ex)) +} + +.zarr_index_meta_rows = function(path){ + return(.zarr_index_scan(path, c('kind', 'cache_key', 'text_value', 'created'), + .zarr_idx_is('kind', 'meta'))) +} + +.zarr_index_version_of = function(path){ + rows = .zarr_index_meta_rows(path) + at = which(rows$cache_key == .zarr_index_meta_key('index_version')) + if(length(at) == 0){ + return(NA_integer_) + } + return(suppressWarnings(as.integer(rows$text_value[at[1]]))) +} + +#How many index rows go in a parquet row group. arrow's default puts the whole table in +#one group when the file is small, which is right for most data and wrong here: the +#keywords dominate the file by volume, and a group that holds all of them cannot be skipped, +#so selecting the keywords of twelve stores decodes the headers of all five thousand. +#Groups of a few hundred rows let the key filter read only the groups that hold the keys it +#wants, and cost little elsewhere because the light pass reads none of that column anyway. +.zarr_index_row_group = 500L + +#Write rows out as parquet. Sorted by cache key so the statistics arrow tests before +#reading a group at all describe a contiguous slice of the directory rather than a +#permutation of it. +.zarr_index_write = function(dt, path){ + .zarr_index_require('to write a Zarr index') + dt = data.table::copy(data.table::as.data.table(dt)) + cols = .zarr_index_cols() + for(col in setdiff(cols, names(dt))){ + n = nrow(dt) + dt[[col]] = if(col %in% .zarr_index_list_cols()){ + rep(list(.zarr_index_empty(col)), n) + }else if(col %in% .zarr_index_num_cols()){ + rep(NA_real_, n) + }else if(identical(col, 'has_keyvalues')){ + rep(FALSE, n) + }else{ + rep(NA_character_, n) + } + } + for(col in .zarr_index_list_cols()){ + dt[[col]] = lapply(dt[[col]], function(val){ + if(is.null(val)){ + val = .zarr_index_empty(col) + } + val + }) + } + dt = dt[order(dt$cache_key), cols, with = FALSE] + #The types come from the schema rather than the data, because the first row of an index + #is often one with an empty payload and an inferred column would take its type from that + tab = arrow::Table$create(dt, schema = .zarr_index_schema()) + arrow::write_parquet(tab, path, chunk_size = .zarr_index_row_group) + return(invisible(path)) +} + +#Merge new rows over the ones an index already holds. Untouched rows carry over, so a run +#narrowed by pattern does not discard the work every other run put into the file. +.zarr_index_merge = function(old, new){ + if(is.null(old) || nrow(old) == 0){ + return(new) + } + if(is.null(new) || nrow(new) == 0){ + return(old) + } + keep = old[!(old$cache_key %in% new$cache_key), ] + if(nrow(keep) == 0){ + return(new) + } + return(rbind(keep, new)) +} + +#The full contents of an index, every column. Only used when an index is about to be +#rewritten, because a merge that carried over rows without their keywords would quietly +#strip the stores this run did not visit. For that it is the one place where reading the +#whole file is right, and the file is a few hundred kB. +.zarr_index_load_all = function(path){ + .zarr_index_require('to read a Zarr index') + dt = tryCatch(arrow::read_parquet(path), error = function(e) NULL) + if(is.null(dt)){ + return(.zarr_index_rows(list())) + } + return(.zarr_index_rows_clean(dt)) +} + +#Bring a data.table read back from parquet into the shape the writers and readers here +#expect: the columns that were queried, in the written order, list columns as plain lists, +#and no row of a payload column holding NULL where an empty vector was written. Columns +#that were not queried are left absent rather than filled in, so that a light row cannot be +#mistaken for a store whose keywords are known to be missing. +.zarr_index_rows_clean = function(dt){ + #The subset at the end is data.table syntax, and what arrives here is not always a + #data.table: .zarr_index_scan converts its table to a plain data.frame, and + #arrow::read_parquet returns a tibble unless something in the session has asked it not + #to. Either would fail here with 'unused argument (with = FALSE)', which does not read + #anything like the cause. + dt = data.table::as.data.table(dt) + keep = intersect(.zarr_index_cols(), names(dt)) + for(col in intersect(.zarr_index_list_cols(), keep)){ + dt[[col]] = lapply(dt[[col]], function(val) .zarr_index_cell(col, val)) + } + return(dt[, keep, with = FALSE]) +} + +#The object key of an index. A bare name is put under the prefix the tiles live under, so +#that the index and the data it describes are found together and share one set of +#credentials. A name that already carries a path is taken as the key itself, since that is +#how an index is addressed once it has been published. +.zarr_index_object_key = function(index, prefix = NULL){ + name = sub('\\.rds$', '', index) + if(!grepl('\\.parquet$', name)){ + name = paste0(name, '.parquet') + } + if(grepl('/', name) || is.null(prefix) || !nzchar(prefix)){ + return(sub('^/+', '', name)) + } + return(paste0(.zarr_s3_prefix(prefix), name)) +} + +#Where an index is. A bare name with no bucket is a local path. A bare name with a bucket +#is an object under the prefix being searched, which is how an index comes to sit beside +#the tiles it describes and be reachable by anyone who can reach them. An s3:// URI says +#both, and is the form a user of a published index is handed. +.zarr_index_resolve = function(index, bucket = NULL, prefix = NULL){ + if(grepl('^s3://', index)){ + rest = sub('^s3://', '', index) + if(!grepl('/', rest)){ + stop('An s3:// index path must name an object, e.g. ', + "'s3://my-bucket/survey/index.parquet'!", call. = FALSE) + } + return(list(index = sub('^[^/]+/', '', rest), + bucket = sub('/.*$', '', rest), prefix = NULL)) + } + return(list(index = index, bucket = bucket, prefix = prefix)) +} + +#The local file an index argument names, with the extension the format wants. An index is +#named the way a store is, by its stem, so that the extension can be left off. +.zarr_index_local_path = function(index){ + index = path.expand(index) + #Caches were .rds files before this format, and a caller who has kept passing the same + #path should find the index where they expect rather than beside an old cache + index = sub('\\.rds$', '', index) + if(!grepl('\\.parquet$', index)){ + index = paste0(index, '.parquet') + } + return(index) +} + +#Reach an index, local or remote. A remote one is downloaded rather than opened in place +#because the queries here are arrow scans, and an arrow scan needs a seekable file: the +#alternative is one GET per page of a file that is a few hundred kB anyway, which is what +#the pushdown was supposed to avoid. +.zarr_index_open = function(index, bucket = NULL, prefix = NULL, client = NULL, + region = NULL, endpoint = NULL, access_key = NULL, + secret_key = NULL, session_token = NULL){ + where = .zarr_index_resolve(index, bucket = bucket, prefix = prefix) + index = where$index + bucket = where$bucket + prefix = where$prefix + if(is.null(bucket)){ + path = .zarr_index_local_path(index) + return(list(path = if(file.exists(path)) path else NULL, shown = path, + remote = FALSE, tempfile = FALSE)) + } + key = .zarr_index_object_key(index, prefix) + if(is.null(client)){ + client = .zarr_index_client(bucket = bucket, region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token) + } + shown = paste0('s3://', bucket, '/', key) + got = tryCatch(client$get_object(Bucket = bucket, Key = key), error = function(e) e) + if(inherits(got, 'error')){ + if(.zarr_s3_not_found(conditionMessage(got))){ + #Absent is ordinary: the first run against a release that has no index yet is how + #every index starts. Anything else (notably AccessDenied) is not, and must not be + #taken for permission to go and build one from scratch + return(list(path = NULL, shown = shown, remote = TRUE, tempfile = FALSE, + missing = TRUE)) + } + stop('Cannot read the Zarr index at ', shown, ': ', conditionMessage(got), + call. = FALSE) + } + body = got$Body + if(is.character(body)){ + body = charToRaw(body) + } + if(!(is.raw(body) && length(body) > 0)){ + return(list(path = NULL, shown = shown, remote = TRUE, tempfile = FALSE, + missing = TRUE)) + } + dest = tempfile(fileext = '.parquet') + writeBin(body, dest) + return(list(path = dest, shown = shown, remote = TRUE, tempfile = TRUE, + missing = FALSE)) +} + +.zarr_index_close = function(src){ + if(isTRUE(src$tempfile) && !is.null(src$path)){ + unlink(src$path) + } + return(invisible(NULL)) +} + +.zarr_index_client = function(bucket, region = NULL, endpoint = NULL, access_key = NULL, + secret_key = NULL, session_token = NULL){ + if(!requireNamespace('paws.storage', quietly = TRUE)){ + stop('The paws.storage package is needed to reach a Zarr index over S3. Please ', + 'install it from CRAN.', call. = FALSE) + } + creds = .zarr_s3_env_defaults(region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token) + if(is.null(creds$access_key) || is.null(creds$secret_key)){ + stop('access_key and secret_key are required to reach a Zarr index over S3, whether ', + 'given directly or by RFITS_S3_ACCESS_KEY and RFITS_S3_SECRET_KEY.', + call. = FALSE) + } + return(paws.storage::s3(config = .zarr_s3_config(region = creds$region, + endpoint = creds$endpoint, + access_key = creds$access_key, + secret_key = creds$secret_key, + session_token = creds$session_token))) +} + +#Write an index out, locally or to a bucket. Remotely the bytes are built in a temporary +#file and put as one object, because parquet writes are not something an S3 client can be +#handed a stream to in pieces here, and a half written index is worse than none: it is the +#one artefact every later search reads. +.zarr_index_put = function(dt, index, bucket = NULL, prefix = NULL, client = NULL, + region = NULL, endpoint = NULL, access_key = NULL, + secret_key = NULL, session_token = NULL){ + where = .zarr_index_resolve(index, bucket = bucket, prefix = prefix) + index = where$index + bucket = where$bucket + prefix = where$prefix + tmp = tempfile(fileext = '.parquet') + .zarr_index_write(dt, tmp) + if(is.null(bucket)){ + dest = .zarr_index_local_path(index) + dir.create(dirname(dest), recursive = TRUE, showWarnings = FALSE) + moved = file.rename(tmp, dest) + if(!moved){ + file.copy(tmp, dest, overwrite = TRUE) + unlink(tmp) + } + return(invisible(dest)) + } + key = .zarr_index_object_key(index, prefix) + if(is.null(client)){ + client = .zarr_index_client(bucket = bucket, region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token) + } + size = file.info(tmp)$size + body = readBin(tmp, what = 'raw', n = as.integer(size)) + unlink(tmp) + put = tryCatch(client$put_object(Bucket = bucket, Key = key, Body = body), + error = function(e) e) + if(inherits(put, 'error')){ + stop('Cannot write the Zarr index to s3://', bucket, '/', key, ': ', + conditionMessage(put), call. = FALSE) + } + return(invisible(paste0('s3://', bucket, '/', key))) +} + +#Extract the search metadata of a directory of Zarr stores into a data.table, optionally +#writing it as the parquet file Rfits_cutout_zarr_dir reads. This is the same extraction +#the search performs on the fly, done once and kept, so that a release can publish one +#file beside its tiles and every user's first query then costs that file rather than one +#small read per store. +# +#The rows returned are the light rows: every column the search filters with, plus a +#has_keyvalues flag, but without the serialised keywords. Those are the bulk of the file +#and are only wanted for the stores a search actually cuts, so they are fetched separately +#(by Rfits_cutout_zarr_dir, or by Rfits_zarr_index_query with keywords = TRUE). +Rfits_zarr_index = function(dir = NULL, filelist = NULL, pattern = NULL, recursive = TRUE, + bucket = NULL, prefix = '', + region = NULL, endpoint = NULL, + access_key = NULL, secret_key = NULL, session_token = NULL, + extname = 'data1', + index = NULL, refresh = FALSE, + data.table = TRUE, verbose = TRUE, ...){ + .zarr_require() + #Asked for up front, because a refresh = TRUE run reaches the row builder without ever + #scanning a file, and the failure would otherwise come from data.table:: rather than + #naming the package that is missing + .zarr_index_require('to build a Zarr index') + assertString(dir, null.ok = TRUE) + assertCharacter(filelist, null.ok = TRUE) + assertCharacter(pattern, null.ok = TRUE) + assertFlag(recursive) + assertFlag(verbose) + assertString(bucket, null.ok = TRUE) + assertString(prefix) + assertString(region, null.ok = TRUE) + assertString(endpoint, null.ok = TRUE) + assertString(access_key, null.ok = TRUE) + assertString(secret_key, null.ok = TRUE) + assertString(session_token, null.ok = TRUE) + assertCharacter(extname, min.len = 1) + assertString(index, null.ok = TRUE) + assertFlag(refresh) + assertFlag(data.table) + + if(is.null(bucket) && is.null(dir) && is.null(filelist) && is.null(index)){ + stop('One of dir, filelist, bucket, or index is required!', call. = FALSE) + } + if(!is.null(bucket) && (!is.null(dir) || !is.null(filelist))){ + stop('Give bucket (a remote prefix) or dir/filelist (local stores), not both!', + call. = FALSE) + } + + #An existing index answers the question without the stores being read at all, which is + #the point of having built one. refresh is what says otherwise. + if(!is.null(index) && !isTRUE(refresh)){ + src = .zarr_index_open(index, bucket = bucket, prefix = prefix, region = region, + endpoint = endpoint, access_key = access_key, + secret_key = secret_key, session_token = session_token) + if(!is.null(src$path)){ + on.exit(.zarr_index_close(src)) + ver = .zarr_index_version_of(src$path) + if(is.na(ver)){ + stop('The Zarr index at ', src$shown, ' has no version and cannot be read. ', + 'Rebuild it with refresh = TRUE.', call. = FALSE) + } + if(ver > .zarr_index_version){ + stop('The Zarr index at ', src$shown, ' was written by a newer version of ', + 'Rfits (', ver, ' > ', .zarr_index_version, ') and cannot be read safely. ', + 'Update the package, or rebuild it with refresh = TRUE.', call. = FALSE) + } + rows = .zarr_index_light_rows(src$path) + if(verbose){ + message('Read ', nrow(rows), ' store row(s) from ', src$shown) + } + out = .zarr_index_rows(as.data.frame(rows, stringsAsFactors = FALSE)) + if(!data.table){ + out = as.data.frame(out, stringsAsFactors = FALSE) + } + return(invisible(out)) + } + .zarr_index_close(src) + } + + stores = .zarr_index_find_stores(dir = dir, filelist = filelist, pattern = pattern, + recursive = recursive, bucket = bucket, prefix = prefix, + region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token, ...) + if(verbose){ + message('Indexing ', length(stores$store), ' Zarr store(s)') + } + + rows = .zarr_index_scan_stores(stores, extname = extname) + ok = sum(vapply(rows, function(r) !is.null(r), logical(1))) + if(verbose){ + message('Recorded ', ok, ' store(s) with readable metadata') + } + dt = .zarr_index_rows(rows) + dt = dt[order(dt$label, dt$extname), ] + + if(!is.null(index)){ + #The index is written whether or not stores were found this time, because the walk + #list is one of the things it holds and a search that found nothing under a prefix is + #still an answer worth keeping. Existing rows are merged rather than replaced, so an + #index narrowed by pattern cannot throw away the work of a broader run. + old = NULL + src = NULL + if(!isTRUE(refresh)){ + src = .zarr_index_open(index, bucket = bucket, prefix = prefix, region = region, + endpoint = endpoint, access_key = access_key, + secret_key = secret_key, session_token = session_token) + if(!is.null(src$path)){ + old = .zarr_index_load_all(src$path) + } + .zarr_index_close(src) + } + #The walk is recorded too, since a remote listing costs a request per directory and + #is otherwise repeated on the next search. Only a walk this run completed is kept: + #one that stopped at max_dirs holds a partial list. + rows = list(.zarr_index_meta_row('index_version', .zarr_index_version)) + if(!is.null(stores$walked)){ + rows = c(rows, list(.zarr_index_walk_row(stores$walk_key, stores$walked))) + } + out = .zarr_index_merge(.zarr_index_merge(old, dt), .zarr_index_rows(rows)) + written = .zarr_index_put(out, index, bucket = bucket, prefix = prefix, + region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token) + #The remote write goes through paws, so a client built here has to be discarded with + #the ones the walk used; both are local objects and neither holds a connection + if(verbose){ + message('Wrote Zarr index: ', written, ' (', nrow(out), ' row(s))') + } + } + + if(!data.table){ + dt = as.data.frame(dt, stringsAsFactors = FALSE) + } + return(invisible(dt)) +} + +#The stores to index, and the labels they are searched under. Shared with +#Rfits_cutout_zarr_dir so that the two cannot disagree about which store is which. +.zarr_index_find_stores = function(dir = NULL, filelist = NULL, pattern = NULL, + recursive = TRUE, bucket = NULL, prefix = '', + region = NULL, endpoint = NULL, access_key = NULL, + secret_key = NULL, session_token = NULL, + max_dirs = 1000, index_path = NULL, refresh = FALSE, + client = NULL, verbose = FALSE){ + remote = !is.null(bucket) + walked = NULL + if(remote){ + if(is.null(client)){ + client = .zarr_index_client(bucket = bucket, region = region, endpoint = endpoint, + access_key = access_key, secret_key = secret_key, + session_token = session_token) + } + walk_key = .zarr_index_walk_key(bucket, prefix, recursive, pattern, max_dirs) + cached = NULL + #index_path is the local copy of an already downloaded index, not the spec of where it + #is. A remote search reads the object once and passes that copy to both lookups, so a + #search never pays twice for the same download. + if(!is.null(index_path) && !isTRUE(refresh)){ + walks = .zarr_index_walk_rows(index_path, keys = walk_key) + if(nrow(walks) > 0 && length(walks$stores[[1]]) > 0){ + cached = walks$stores[[1]] + } + } + if(!is.null(cached)){ + found = as.character(cached) + if(verbose){ + message('Using cached store list for s3://', bucket, '/', + .zarr_s3_prefix(prefix), ' (', length(found), + ' stores); refresh = TRUE to re-list') + } + }else{ + #A walk that gave up at max_dirs holds a partial list, and caching that would hide + #stores from every later search without saying so + truncated = FALSE + found = withCallingHandlers( + .zarr_s3_find_stores(client, bucket, prefix, recursive = recursive, + pattern = pattern, max_dirs = max_dirs), + warning = function(w){ + #No muffleRestart, so the warning still reaches the caller: it is their only + #notice that the search saw part of the directory + if(grepl('directories; use a narrower prefix', conditionMessage(w))){ + truncated <<- TRUE + } + }) + if(!truncated){ + walked = found + } + } + if(length(found) == 0){ + stop('No Zarr stores found under s3://', bucket, '/', .zarr_s3_prefix(prefix), + if(length(pattern) > 0) ' with the given pattern' else '', '!', call. = FALSE) + } + return(list(store = found, label = paste0('s3://', bucket, '/', found), + remote = TRUE, bucket = bucket, client = client, walked = walked, + walk_key = walk_key)) + } + + if(is.null(filelist)){ + dir = path.expand(dir) + if(!dir.exists(dir)){ + stop('Directory does not exist: ', dir, call. = FALSE) + } + #A Zarr store is a directory, so the search is for directories, not files. + #list.files reports what is below dir and never dir itself, so a directory named + #*.zarr is offered as its own store here, matching the remote path which probes the + #prefix before listing it. + found = character(0) + if(grepl('\\.zarr$', dir)){ + found = dir + } + below = list.files(dir, full.names = TRUE, include.dirs = TRUE, recursive = recursive) + found = c(found, grep('\\.zarr$', below, value = TRUE)) + found = found[dir.exists(found)] + }else{ + found = path.expand(filelist) + found = found[dir.exists(found)] + } + if(length(pattern) > 0){ + for(p in pattern){ + found = grep(p, found, value = TRUE) + } + } + found = sort(unique(found)) + if(length(found) == 0){ + stop('No Zarr stores found', if(!is.null(dir)) paste0(' in ', dir) else '', + if(length(pattern) > 0) ' with the given pattern' else '', '!', call. = FALSE) + } + return(list(store = found, label = found, remote = FALSE, walked = NULL, + walk_key = NULL)) +} + +#Read the search metadata of each store, in the order asked for, trying each extension +#candidate in turn. Returns one row list per store (or NULL where nothing could be read), +#which both the standalone builder and the search consume. +.zarr_index_scan_stores = function(stores, extname){ + out = vector(mode = 'list', length = length(stores$store)) + for(i in seq_along(stores$store)){ + read = .zarr_store_meta(stores$store[i], stores$label[i], extname = extname, + remote = stores$remote, client = stores$client, + bucket = stores$bucket) + stamp = NA_character_ + if(!stores$remote && !is.null(read$extname)){ + stamp = .zarr_index_stamp(stores$store[i], read$extname) + } + out[[i]] = .zarr_index_store_row(label = stores$label[i], store = stores$store[i], + extname = read$extname, info = read$info, + stamp = stamp) + } + return(out) +} + +#The metadata of one store, and which of the candidate extensions it came from. Reads the +#array document directly where it can, since opening a store costs a probe and a hierarchy +#walk before a single keyword is in hand. +.zarr_store_meta = function(store, label = store, extname = 'data1', remote = FALSE, + client = NULL, bucket = NULL){ + for(name in extname){ + if(remote){ + meta = .zarr_meta_from_s3(client, bucket, store, name) + if(is.null(meta)){ + #nothing at that key, so try the next candidate + next + } + if(!is.null(attr(meta, 'error'))){ + return(list(info = list(status = 'error', error = attr(meta, 'error')), + extname = NULL)) + } + return(list(info = .zarr_cutout_tile_info(meta$keyvalues, meta$shape), + extname = name)) + } + meta = .zarr_meta_from_dir(store, name) + if(is.null(meta)){ + #Either a v2 store or one whose array is not named as asked. Only now is it worth + #opening the store properly, which also gives a better message than 'not found' + #when the store is genuinely unreadable. + opened = tryCatch(Rfits_point_zarr(store, extname = name, header = TRUE), + error = function(e) e) + if(inherits(opened, 'error')){ + msg = conditionMessage(opened) + if(grepl('does not exist in the Zarr store', msg)){ + next + } + return(list(info = list(status = 'error', error = msg), extname = NULL)) + } + return(list(info = .zarr_cutout_tile_info(opened$keyvalues, opened$dim), + extname = name)) + } + return(list(info = .zarr_cutout_tile_info(meta$keyvalues, meta$shape), + extname = name)) + } + return(list(info = NULL, extname = NULL)) +} + +#Ask an index which stores could overlap a set of positions, without reading any store. +#The light columns are small enough to take as a whole (a few tens of bytes per store, so +#a five thousand tile release is a couple of hundred kB), which is what lets the cone test +#be plain vectorised R rather than an expression arrow has to interpret. What is not read +#here is the keywords, which are over 99% of the file by volume; those are fetched per +#surviving store by key, and it is that fetch which the sorted row groups prune. +# +#The generous bounds are deliberate. Each store's reference position is only one point in +#it, so a store is a candidate when its reference position is within its own half diagonal +#plus the box half diagonal plus a margin of the requested position. Anything tighter would +#risk dropping a store the precise test would have kept, which is the one mistake this +#stage must not make. +Rfits_zarr_index_query = function(index, RA = NULL, Dec = NULL, loc = NULL, + box = 101, box.unit = c('pix', 'arcsec'), + bucket = NULL, prefix = NULL, + region = NULL, endpoint = NULL, + access_key = NULL, secret_key = NULL, + session_token = NULL, + buffer = 0, safety = 0.1, + keywords = FALSE, data.table = TRUE, + verbose = TRUE){ + assertString(index, null.ok = TRUE) + assertFlag(verbose) + assertFlag(keywords) + assertFlag(data.table) + assertNumeric(buffer, len = 1, lower = 0) + assertNumeric(safety, len = 1, lower = 0) + box.unit = match.arg(box.unit) + assertNumeric(box, min.len = 1, max.len = 2) + + if(is.null(index)){ + stop('index is required!', call. = FALSE) + } + + pos = .zarr_cutout_positions(RA = RA, Dec = Dec, loc = loc) + #A single number is the same box in both axes, which is what the search does; indexing + #box[2] without this gives NA and every bound below silently follows it + if(length(box) == 1){ + box = c(box, box) + } + + src = .zarr_index_open(index, bucket = bucket, prefix = prefix, region = region, + endpoint = endpoint, access_key = access_key, + secret_key = secret_key, session_token = session_token) + if(is.null(src$path)){ + .zarr_index_close(src) + stop('No Zarr index at ', src$shown, call. = FALSE) + } + on.exit(.zarr_index_close(src)) + + rows = .zarr_index_light_rows(src$path) + rows = rows[rows$status == 'ok', ] + n_all = nrow(rows) + if(n_all == 0){ + out = rows[0, ] + if(!data.table){ + out = as.data.frame(out, stringsAsFactors = FALSE) + } + if(verbose){ + message('No index row holds usable WCS metadata') + } + return(invisible(out)) + } + + #The radius is per store and depends only on the store, so it is worked out in R rather + #than pushed into an expression: the test is then a separation, which needs trigonometry + #arrow does not have. It is the search's own .zarr_cutout_max_sep, called per store, so + #that the two cannot disagree about what counts as a candidate. That includes the offset + #from the reference point to the tile centre, which a hand written version of this + #formula left out and which would let a store with an off centre CRPIX be rejected here + #even though the search would have taken it. + scale = Map(list, x = rows$pixscale_x, y = rows$pixscale_y) + limit = vapply(seq_len(nrow(rows)), function(i){ + this_box = tryCatch(.zarr_cutout_box_pix(box, box.unit, scale[[i]]), + error = function(e) NULL) + if(is.null(this_box)){ + #A box this store cannot express is kept rather than dropped: the search decides + #that, and reports it as its own status rather than silently matching nothing here + this_box = suppressWarnings(ceiling(if(box.unit == 'arcsec'){ + box/scale[[i]] + }else{ + box + })) + } + test_box = .zarr_cutout_test_box(this_box, buffer = buffer, scale = scale[[i]]) + naxis = c(rows$naxis1[i], rows$naxis2[i]) + crpix = c(rows$crpix1[i], rows$crpix2[i]) + .zarr_cutout_max_sep(naxis, crpix, scale[[i]], test_box, safety = safety) + }, numeric(1)) + #A store whose bound could not be worked out is kept, since this stage may be generous + #but must never reject what the precise test would have taken + limit[is.finite(rows$ra) & is.na(limit)] = Inf + + #The degrees box is only a pre-filter to keep the trigonometry off rows that cannot + #match, so it is built from the widest bound in the file rather than per row. The RA + #half width divides by cos(Dec), which grows without bound near the poles; a store is + #never further than a full turn away, so the width is capped at the whole sky and the + #test falls back to declination alone up there rather than keeping every row. + keep = rep(FALSE, nrow(rows)) + widest = max(limit, na.rm = TRUE) + for(k in seq_len(nrow(pos))){ + ddec = (widest + 3600) / 3600 + dra = min(360, (widest + 3600) / 3600 / max(abs(cos(pos[k, 2] * pi/180)), 1e-6)) + near = (abs(((rows$ra - pos[k, 1] + 540) %% 360) - 180) <= dra) & + (abs(rows$dec - pos[k, 2]) <= ddec) + near[is.na(near)] = TRUE + if(any(near)){ + at = which(near) + sep = .zarr_ang_sep_arcsec(pos[k, 1], pos[k, 2], rows$ra[at], rows$dec[at]) + #An NA here is treated as a keep, which is what near[is.na(near)] above already + #does for a store whose position could not be compared. A row written 'ok' always + #carries a finite reference position, so this is the same defensive stance rather + #than a case that is expected to arise; the logical goes through which() because + #[<- drops an NA subscript silently instead of keeping the row it stands for + inside = sep <= limit[at] + inside[is.na(inside)] = TRUE + keep[at[which(inside)]] = TRUE + } + } + hit = rows[keep, ] + + if(isTRUE(keywords)){ + pay = .zarr_index_payload_rows(src$path, hit$cache_key) + blobs = stats::setNames(as.list(pay$keyvalues), pay$cache_key) + hit$keyvalues = blobs[hit$cache_key] + #A store the payload query did not return has had its blob dropped since the light + #pass; the empty vector is what both .zarr_index_tile and a caller testing with + #length() understand as 'no keywords here' + hit$keyvalues = lapply(hit$keyvalues, function(val){ + if(is.null(val)){ + raw(0) + }else{ + .zarr_index_cell('keyvalues', val) + } + }) + } + + if(verbose){ + message('Index holds ', n_all, ' searchable store(s); ', nrow(hit), + ' could overlap the requested position(s)') + } + if(!data.table){ + hit = as.data.frame(hit, stringsAsFactors = FALSE) + }else{ + hit = data.table::as.data.table(hit) + } + return(invisible(hit)) +} + +#What an index holds, without reading its rows. This is the thing to run before deciding +#whether an index is current, since the answer comes from the columns only. +Rfits_zarr_index_info = function(index, bucket = NULL, prefix = NULL, + region = NULL, endpoint = NULL, + access_key = NULL, secret_key = NULL, + session_token = NULL){ + assertString(index, null.ok = TRUE) + if(is.null(index)){ + stop('index is required!', call. = FALSE) + } + src = .zarr_index_open(index, bucket = bucket, prefix = prefix, region = region, + endpoint = endpoint, access_key = access_key, + secret_key = secret_key, session_token = session_token) + if(is.null(src$path)){ + .zarr_index_close(src) + stop('No Zarr index at ', src$shown, call. = FALSE) + } + on.exit(.zarr_index_close(src)) + + rows = .zarr_index_light_rows(src$path) + walks = .zarr_index_walk_rows(src$path) + meta = .zarr_index_meta_rows(src$path) + ver = NA_integer_ + at = which(meta$cache_key == .zarr_index_meta_key('index_version')) + if(length(at) > 0){ + ver = suppressWarnings(as.integer(meta$text_value[at[1]])) + } + status = rows$status + counts = data.frame(status = character(0), n = integer(0), stringsAsFactors = FALSE) + if(nrow(rows) > 0){ + counts = as.data.frame(table(status = status), stringsAsFactors = FALSE) + names(counts) = c('status', 'n') + counts = counts[order(-counts$n), ] + } + output = list(path = src$shown, + version = ver, + n_rows = nrow(rows), + extnames = sort(unique(rows$extname)), + stores = unique(rows$store), + status = counts, + n_walks = nrow(walks), + created = if(nrow(rows) > 0 && any(is.finite(rows$created))){ + as.POSIXct(max(rows$created, na.rm = TRUE), origin = '1970-01-01') + }else{ + as.POSIXct(NA_real_, origin = '1970-01-01') + }) + class(output) = 'Rfits_zarr_index_info' + return(invisible(output)) +} + +print.Rfits_zarr_index_info = function(x, ...){ + cat('Zarr index: ', x$path, '\n', sep = '') + cat(' format version: ', if(is.na(x$version)) 'unknown' else x$version, '\n', sep = '') + cat(' stores: ', x$n_rows, ' row(s)', + if(length(x$extnames) > 0) paste0(', extname(s): ', + paste(x$extnames, collapse = ', ')) else '', + '\n', sep = '') + if(nrow(x$status) > 0){ + for(i in seq_len(nrow(x$status))){ + cat(' ', x$status$status[i], ': ', x$status$n[i], '\n', sep = '') + } + } + cat(' store lists: ', x$n_walks, '\n', sep = '') + if(!is.null(x$created) && !is.na(x$created)){ + cat(' last written: ', format(x$created), '\n', sep = '') + } + return(invisible(x)) +} + + + + diff --git a/inst/shiny/Rfits_cutout_app/app.R b/inst/shiny/Rfits_cutout_app/app.R new file mode 100644 index 0000000..cd2b0bd --- /dev/null +++ b/inst/shiny/Rfits_cutout_app/app.R @@ -0,0 +1,2847 @@ +#Cutout explorer for a directory (or S3 prefix) of Zarr stores written by Rfits. +# +#The point of this app is that a request is answered from the index rather than from the +#tiles. Rfits_cutout_zarr_dir can search a store set by reading one small metadata +#document per store, but over S3 that is still one request per store, so a release of a +#few thousand tiles spends a few thousand requests before the first pixel. index.parquet, +#built by Rfits_zarr_index, holds the same information once, and +#Rfits_zarr_index_query narrows a request to the handful of stores that can possibly +#overlap it. The app then cuts only those. +# +#Everything here is read-only against the store being browsed. When an index is missing +#the app builds one and keeps it in its own temporary file rather than uploading it +#beside the data, because a shared release is not the place to write a private cache: +#whoever publishes the tiles should decide whether an index ships with them. That is also +#why the search is issued per store instead of passing cache = to +#Rfits_cutout_zarr_dir, which would write what it learns back to the bucket. +# +#Run it with: +# Rfits_cutout_app() +#or: +# shiny::runApp(system.file('shiny', 'Rfits_cutout_app', package = 'Rfits')) + +#Checked before they are attached, because library() on a missing package reports +#'there is no package called shiny', which says nothing about what to do next. arrow and +#data.table are here rather than left to fail from inside a Rfits::: internal: the app +#always reads its store list through the index, and the index is parquet rows held as a +#data.table. +need = c('shiny', 'bslib', 'Rfits', 'plotly', 'arrow', 'data.table') +missing = need[!vapply(need, requireNamespace, logical(1), quietly = TRUE)] +if(length(missing) > 0){ + stop('The Rfits cutout app needs: ', paste(missing, collapse = ', '), + '. Please install them from CRAN.', call. = FALSE) +} + +library(shiny) +library(bslib) + +if(!requireNamespace('Rwcs', quietly = TRUE)){ + #Without Rwcs there is no WCS aware plot method, and no overlap or position test + stop('The Rfits cutout app needs the Rwcs package to plot and to search by RA/Dec. ', + 'Please install it from CRAN.', call. = FALSE) +} +has_dt = requireNamespace('DT', quietly = TRUE) +if(has_dt){ + library(DT) +} + +#bslib renamed nav_panel to tab_panel in 1.0, and the two take the same arguments. The +#app ships inside the package, so it has to start on whatever version the user has rather +#than the one it was written against +tab_panel = if(exists('tab_panel', envir = asNamespace('bslib'), inherits = FALSE)){ + bslib::tab_panel +}else{ + bslib::nav_panel +} + +#The index readers below are internal to Rfits. This app ships inside the package, so +#reaching for them is closer to the intent than rebuilding their logic here. They are the +#read-only half of the index layer; nothing in this file calls .zarr_index_put, which is +#the one function in that file that would write to the bucket. +zarr_open_index = function(index, bucket, prefix, creds){ + src = tryCatch(Rfits:::.zarr_index_open(index = index, bucket = bucket, prefix = prefix, + region = creds$region, + endpoint = creds$endpoint, + access_key = creds$access_key, + secret_key = creds$secret_key, + session_token = creds$session_token), + error = function(e) e) + if(inherits(src, 'error')){ + return(list(src = NULL, error = conditionMessage(src))) + } + return(list(src = src, error = NULL)) +} + +#Three states an index probe can come back with. Absent is ordinary (a release nobody has +#indexed yet) and is the only thing that licenses building one: an AccessDenied or a +#malformed file is reported rather than quietly worked around by rebuilding, because a +#rebuild of the same prefix meets the same permission problem and costs a request per +#store on the way to it. +load_index = function(con, rebuild = FALSE, note = function(...){}){ + creds = con$creds + if(!rebuild){ + got = zarr_open_index(con$index_name, bucket = con$bucket, prefix = con$index_prefix, + creds = creds) + if(!is.null(got$error)){ + return(list(error = got$error)) + } + src = got$src + if(!is.null(src$path)){ + #Closing an index source deletes the file when it was downloaded, so the read + #below happens first and the close is only taken on the paths that do not keep + #the file. Releasing it here would leave the caller holding a path to a parquet + #file that no longer exists, which for a remote index means every later query + #fails while the local one still works, the worst possible way to be wrong + rows = tryCatch(Rfits:::.zarr_index_light_rows(src$path), error = function(e) e) + if(inherits(rows, 'error')){ + Rfits:::.zarr_index_close(src) + return(list(error = conditionMessage(rows))) + } + if(nrow(rows) == 0){ + Rfits:::.zarr_index_close(src) + return(list(error = paste('The index at', src$shown, 'holds no store rows.'))) + } + note('Read ', nrow(rows), ' store row(s) from ', src$shown) + return(list(path = src$path, shown = src$shown, rows = rows, + owned = isTRUE(src$tempfile), error = NULL)) + } + #Nothing to keep, so any downloaded copy goes now rather than with the session + Rfits:::.zarr_index_close(src) + #A remote object that is not there comes back with missing = TRUE, but a local path + #that does not exist comes back with no such field at all, and both mean the same + #thing here: there is no index to read, so one may be built. Only a remote failure + #that is not 'absent' (notably AccessDenied) is a real error, and must not be worked + #around by a rebuild that meets the same problem at a cost of a request per store + if(isTRUE(src$remote) && !isTRUE(src$missing)){ + return(list(error = paste('No readable index at', src$shown))) + } + note('No index at ', src$shown, '; building one for this session.') + }else{ + note('Rebuilding the index from the tiles (one metadata read per store).') + } + + #Built in memory and written to this session's own temporary file. Rfits_zarr_index is + #deliberately called without index = so that it returns rows rather than publishing + #them, and max_dirs is forwarded so a walk that would stop early still warns. + built = tryCatch({ + if(is.null(con$bucket)){ + Rfits::Rfits_zarr_index(dir = con$dir, pattern = con$pattern, + extname = con$extname, max_dirs = con$max_dirs, + verbose = FALSE) + }else{ + Rfits::Rfits_zarr_index(bucket = con$bucket, prefix = con$prefix, + pattern = con$pattern, extname = con$extname, + region = creds$region, endpoint = creds$endpoint, + access_key = creds$access_key, + secret_key = creds$secret_key, + session_token = creds$session_token, + max_dirs = con$max_dirs, verbose = FALSE) + } + }, error = function(e) e) + if(inherits(built, 'error')){ + return(list(error = conditionMessage(built))) + } + if(is.null(built) || nrow(built) == 0){ + return(list(error = 'The index build found no stores to record.')) + } + path = tempfile(fileext = '.parquet') + wrote = tryCatch({ + Rfits:::.zarr_index_write(built, path) + NULL + }, error = function(e) conditionMessage(e)) + if(!is.null(wrote)){ + return(list(error = paste('Could not write the session index:', wrote))) + } + note('Indexed ', nrow(built), ' store row(s) into ', path) + return(list(path = path, shown = path, rows = Rfits:::.zarr_index_light_rows(path), + owned = TRUE, error = NULL, built = TRUE)) +} + +#Positions are typed as free text because that is how they arrive from a finder list or a +#clipboard, one target per line. A line that is not two finite numbers is reported back +#rather than dropped in silence, so a truncated paste cannot quietly search fewer targets +#than the user believes it did. +parse_positions = function(text){ + lines = strsplit(gsub('\\t', ' ', as.character(text)), '[\r\n]+')[[1]] + lines = trimws(lines) + lines = lines[nzchar(lines) & !grepl('^#', lines)] + bad = character(0) + out = matrix(numeric(0), ncol = 2, dimnames = list(NULL, c('RA', 'Dec'))) + for(i in seq_along(lines)){ + tok = trimws(strsplit(lines[i], '[,; ]+')[[1]]) + tok = tok[nzchar(tok)] + val = suppressWarnings(as.numeric(tok)) + if(length(val) == 2 && all(is.finite(val))){ + out = rbind(out, unname(val)) + }else{ + bad = c(bad, paste0('line ', i, ' ("', substr(lines[i], 1, 40), '")')) + } + } + attr(out, 'bad') = bad + return(out) +} + +#Run messages go to the log rather than to the console. Every Rfits call here can emit +#both, and a Shiny user has no console; a warning that is only printed is a warning nobody +#saw. Returning the captured text also lets the store loop report one failure per store +#instead of aborting the whole request on the first. +with_capture = function(expr){ + msgs = character(0) + add = function(kind, txt){ + msgs <<- c(msgs, paste0(kind, ': ', gsub('[\r\n]+$', '', txt))) + } + val = withCallingHandlers( + tryCatch(expr, error = function(e){ + add('ERROR', conditionMessage(e)) + NULL + }), + warning = function(w){ + add('WARNING', conditionMessage(w)) + invokeRestart('muffleWarning') + }, + message = function(m){ + add('INFO', conditionMessage(m)) + invokeRestart('muffleMessage') + }) + return(list(value = val, msgs = msgs)) +} + +#One store's cutout, as a job a worker can run on its own. Everything it needs arrives in +#the job, and every call is namespaced, so nothing has to be attached in the worker and +#nothing has to be found in this file's environment. +# +#The environment is detached on purpose. A closure carries the environment it was created +#in, which for a top level function here is the whole app environment -- the ui tag tree +#included. Shipping that costs megabytes per job, and it is what makes a parallel cutout +#slower than a serial one. With baseenv() behind it the body is all that travels. +cutout_worker = local({ + f = function(job, capture){ + capture({ + if(is.null(job$bucket)){ + Rfits::Rfits_cutout_zarr_dir(dir = job$store, RA = job$RA, Dec = job$Dec, + box = job$box, box.unit = job$box_unit, + buffer = job$buffer, extname = job$extname, + header = TRUE, extract = TRUE, verbose = TRUE) + }else{ + Rfits::Rfits_cutout_zarr_dir(bucket = job$bucket, prefix = job$store, + RA = job$RA, Dec = job$Dec, box = job$box, + box.unit = job$box_unit, buffer = job$buffer, + extname = job$extname, header = TRUE, + extract = TRUE, verbose = TRUE, + region = job$region, endpoint = job$endpoint, + access_key = job$access_key, + secret_key = job$secret_key, + session_token = job$session_token) + } + }) + } + environment(f) = baseenv() + f +}) + +#The same treatment for the capture helper, which a worker needs in order to report a +#store's failure as a line in the log rather than as a promise that rejected. It only calls +#base functions, so detaching it is safe. +with_capture_worker = local({ + f = with_capture + environment(f) = baseenv() + f +}) + +#Whether cutouts are fetched off the session thread. Without both packages the loop runs +#inline, which is slower but identical in what it produces, so nothing downstream branches +#on this. Under testthat it is left alone: a sequential plan resolves a future during the +#flush the tests already do, whereas a worker would not have come back by the time a test +#asserts on state$res, and the plan is global state a test run should not take over. +async_ok = requireNamespace('promises', quietly = TRUE) && + requireNamespace('future', quietly = TRUE) && + !identical(Sys.getenv('TESTTHAT'), 'true') + +#Registered once rather than per request, since a plan is session wide and building the +#workers is the expensive part. A plan the user has already chosen is left alone. One core +#is omitted, because the session thread still has to serve the page while the workers fetch +if(async_ok && future::nbrOfWorkers() <= 1){ + future::plan(future::multisession, + workers = min(8L, future::availableCores(omit = 1L))) +} + +#An inset in the top left of a cutout saying where it was asked for. Drawn after the image +#so it sits on top of it, on a light chip because the pixels underneath are usually dark +#and the chip has to survive both. Coordinates are in user units so the box tracks the +#axes whichever way a projection has turned them. +draw_inset = function(txt){ + if(is.null(txt) || !nzchar(txt)){ + return(invisible(NULL)) + } + u = par('usr') + left = min(u[1], u[2]) + top = max(u[3], u[4]) + cex = 0.75 + w = strwidth(txt, cex = cex, units = 'user') + h = strheight(txt, cex = cex, units = 'user') + rect(left, top - h * 2.2, left + w + h * 1.4, top, + col = rgb(1, 1, 1, 0.72), border = NA) + text(left + h * 0.7, top - h * 1.1, txt, adj = c(0, 0.5), cex = cex) + return(invisible(NULL)) +} + +#A header filter, applied to the candidate stores only. Band and target are usually +#encoded in a header keyword (FILTER, BAND, TARGET) as often as in the store name, and the +#keywords are already in the index, so filtering them costs a decode rather than a read of +#the tiles. Stores whose keywords are not in the index are dropped rather than kept, +#because a filter that could not be evaluated is a filter that was not honoured. +# +#Some things a user reaches for are index columns rather than header keywords. EXTNAME is +#the clearest: a store written by Rfits_dir_to_zarr does not necessarily carry it in its +#header, but the index always records which extension was read, so a filter that looked +#only at keywords would return nothing and look like a release with no such data. +filter_by_keyword = function(rows, index_path, key, value, note = function(...){}){ + if(!nzchar(key) || nrow(rows) == 0){ + return(rows) + } + #The value is a glob, like the store name fields, so *grz* is the way to ask for a band + #that contains grz. Converted once here rather than at each of the two matches below, so + #the index column path and the keyword path cannot read the same text differently. + # + #The text as typed is kept for the notes, which have to quote back what the user asked + #for rather than the regular expression it became, and the conversion is skipped when the + #value is blank: glob_regex drops a blank pattern, and a zero length 'yes match anything' + #flag would break every nzchar() below + typed = value + if(nzchar(value)){ + value = glob_regex(value) + } + #FITs keywords are upper case by convention and the index columns are lower case, so the + #comparison is made case insensitively; otherwise EXTNAME would silently fall through to + #the keyword path and find nothing. Only the scalar columns a user might mean are + #offered: the payload columns (keyvalues, stores, array_dim) are lists, and 'kind' and + #the timestamps mean nothing to someone choosing a band + fallback = c('extname', 'status', 'type', 'label', 'store') + col = fallback[tolower(fallback) == tolower(key)] + if(length(col) == 1){ + note('Filtering on the index column ', col, ' rather than a header keyword.') + val = as.character(rows[[col]]) + keep = if(nzchar(value)){ + grepl(value, val, ignore.case = TRUE) + }else{ + !is.na(val) & nzchar(val) + } + note('Kept ', sum(keep), ' of ', nrow(rows), ' candidate store row(s)') + return(rows[keep, , drop = FALSE]) + } + + pay = Rfits:::.zarr_index_payload_rows(index_path, rows$cache_key) + blobs = stats::setNames(as.list(pay$keyvalues), pay$cache_key) + found = character(0) + keep = vapply(seq_len(nrow(rows)), function(i){ + blob = blobs[[rows$cache_key[i]]] + if(is.null(blob) || length(blob) == 0){ + return(FALSE) + } + kv = tryCatch(unserialize(blob), error = function(e) NULL) + if(is.null(kv)){ + return(FALSE) + } + val = kv[[key]] + if(is.null(val)){ + return(FALSE) + } + found <<- c(found, paste(as.character(val), collapse = '/')) + if(!nzchar(value)){ + return(TRUE) + } + return(any(grepl(value, as.character(val), ignore.case = TRUE))) + }, logical(1)) + note('Header keyword ', key, if(nzchar(typed)) paste0(' matching "', typed, '"') else '', + ': kept ', sum(keep), ' of ', nrow(rows), ' candidate store row(s)') + if(sum(keep) == 0){ + #An empty result here is otherwise indistinguishable from a release that does not + #hold what was asked for, so say which of the two happened + if(length(found) == 0){ + note('No candidate store carries a ', key, ' keyword. Check the spelling against a ', + 'header shown on the Index tab, or narrow by store name pattern instead.') + }else{ + vals = sort(unique(found)) + note('The ', key, ' keyword is present, but no value matched "', typed, '". ', + 'Values seen: ', paste(utils::head(vals, 10), collapse = ', '), + if(length(vals) > 10) paste0(' (+', length(vals) - 10, ' more)') else '') + } + } + rows[keep, , drop = FALSE] +} + +#The footprint of a tile, from the index alone. corners() would be exact (it follows the +#projection and the rotation) but costs a pair of wcslib calls per store, and this plot is +#meant to show thousands of tiles at once. An axis aligned box built from the reference +#position, the shape and the pixel scale is the same quantity the search's own cone filter +#works with, and differs from the truth only by rotation and projection curvature. +index_footprints = function(rows){ + rows = as.data.frame(rows, stringsAsFactors = FALSE) + half_w = rows$naxis1 * rows$pixscale_x / 7200 + half_h = rows$naxis2 * rows$pixscale_y / 7200 + #A degree of RA is shorter than a degree of Dec by cos(Dec), so the box widens towards + #the poles; the floor keeps a tile at the pole from becoming infinitely wide + cosd = pmax(abs(cos(rows$dec * pi/180)), 1e-6) + rows$xmin = rows$ra - half_w/cosd + rows$xmax = rows$ra + half_w/cosd + rows$ymin = rows$dec - half_h + rows$ymax = rows$dec + half_h + rows$name = sub('\\.zarr$', '', basename(rows$store)) + return(rows) +} + +#Columns an index row should be shown with. The keyword blob and the cached store lists +#are the bulk of the file and mean nothing in a table, and created is better as a time. +index_view_columns = function(rows){ + rows = as.data.frame(rows, stringsAsFactors = FALSE) + rows$keyvalues = NULL + rows$stores = NULL + rows$array_dim = NULL + rows$has_keyvalues = NULL + rows$stamp = NULL + if('created' %in% names(rows)){ + rows$created = as.POSIXct(rows$created, origin = '1970-01-01') + } + return(rows) +} + +#Store name patterns are globs, not regular expressions. A path is what a user is looking +#at, so what they will reach for is *.zarr or tile*, and a plain release name like tile2 +#behaves the same either way. glob2rx does the conversion, with two adjustments. +# +#The anchors it adds come straight back off: a pattern is matched against the whole store +#path, and the app wants a name that appears anywhere in it, not a whole-string match, so +#'tile2' has to keep finding releases/dr1/tile2.zarr. glob2rx writes them as ^...$ in that +#order, whatever the pattern ends with, and they are removed by position rather than by +#sub(), which would turn a literal $ in the pattern into a real end-of-string anchor. +# +#glob2rx is built on the opposite assumption: it leaves + ^ $ | and the backslash alone +#because in *its* output those are the metacharacters it needs. Every character it does not +#escape is therefore escaped here first, so that a pattern means only what a glob means. +#Without that, 'a+b' would be handed to grepl as 'one or more a', and a backslash would +#reach it as a bare escape. +glob_regex = function(pattern){ + pattern = as.character(pattern) + pattern = pattern[!is.na(pattern) & nzchar(pattern)] + if(length(pattern) == 0){ + return(character(0)) + } + out = gsub('\\', '\\\\', pattern, fixed = TRUE) + out = gsub('([+^$|)])', '\\\\\\1', out) + out = utils::glob2rx(out, trim.tail = FALSE) + out = substring(out, 2) + return(substr(out, 1, nchar(out) - 1)) +} + +#Narrow index rows to those whose label matches every pattern given. The patterns arrive +#already converted by glob_regex, which is why this only grepl()s, and all of them have to +#match, so a comma separated field is an AND. +# +#The same narrowing is applied in two places: where the rows are read, so the Index, Frames +#and Store tabs show the stores this session is working with, and where a request picks its +#candidates. One function rather than a loop written out twice, because a published index +#describes a whole release and a session filtered to one band must not be told two different +#things about what is in it. +pattern_rows = function(rows, patterns){ + if(is.null(rows) || length(patterns) == 0 || nrow(rows) == 0){ + return(rows) + } + keep = rep(TRUE, nrow(rows)) + for(p in patterns){ + keep = keep & grepl(p, rows$label) + } + return(rows[keep, , drop = FALSE]) +} + +#The arguments of the restyle call that redraws the picked positions on the Frames plot. +# +#The vectors are wrapped in I() so that Shiny's JSON keeps them as arrays. plotly's +#restyle takes a list of per-trace values, so the payload wants to be a list holding one +#array, {x: [[...]]}. Built from a bare list() jsonlite unboxes the inner vector when it +#has length one, and a single pick goes over the wire as {x: [53.1234]}, which restyle +#reads as a scalar: the marker is silently not drawn. The next click makes the vector +#length two, no unboxing happens, and both picks appear at once -- the first click +#appearing to do nothing and the second drawing two marks. I() marks the vector as +#already a JSON array, so the shape holds for any number of picks, one included +pick_restyle_args = function(ra, dec){ + return(list(x = list(I(ra)), y = list(I(dec)))) +} + +safe_filename = function(x){ + x = gsub('[^A-Za-z0-9._-]+', '_', as.character(x)) + x = substr(x, 1, 90) + if(!nzchar(x)){ + x = 'cutout' + } + return(x) +} + +#magimage's locut/hicut mean different things depending on type, which is worth surfacing +#because the default is a quantile and a user who types 3 for a sigma clip gets +#"'probs' outside [0,1]" from stats::quantile instead of a plot. +magmap_units = c('quan (quantile 0-1)' = 'quan', 'sig (sigma)' = 'sig', + 'num (data value)' = 'num', 'rank (0-1)' = 'rank') + +#The results table is drawn by DT with server = FALSE, so one column of plain checkboxes +#can stand in for DT's own row selection, which is only a highlight and reports under a name +#of its own. Shiny cannot see a click inside a widget, so a change is sent back as an event, +#and the state is pushed back as a custom message rather than by redrawing the table, which +#would cost the user their search, their sort and their page. +# +#Two details are worth the trouble. The box carries its index in the result list as a data +#attribute because the rows get sorted, paged and filtered while the index does not move. +#And ticks are mirrored in ticks rather than read off the DOM, because DataTables takes rows +#off the page entirely and puts them back from the original HTML: without a mirror, the +#boxes on a page the user has walked away from and come back to would revert to whatever +#they were drawn as. ticks stays null until the server says otherwise, so the state the +#table was first rendered with is left alone rather than being cleared +table_tick_callback = " + var ticks = null; + function sync(){ + if(ticks === null){ return; } + table.column(0).nodes().each(function(cell){ + var box = cell.querySelector('input.rf-tick'); + if(box){ box.checked = ticks[box.getAttribute('data-rf-i')] === true; } + }); + } + //a delegated binding, so it survives the rows DataTables takes off the page and puts + //back. The box is read off the event target rather than this, which is the safe form + //whether or not the delegation sets it + table.on('change', 'input.rf-tick', function(e){ + if(!window.Shiny){ return; } + var box = e.target; + Shiny.onInputChange('match_tick', {i: Number(box.getAttribute('data-rf-i')), + on: box.checked}); + }); + table.on('draw.dt', sync); + //This callback is re-run every time the widget renders, so the handler is installed + //once and pointed at whichever closure is current. addCustomMessageHandler refuses a + //second registration of the same name, and a handler left bound to the first render's + //closure would drive a table that no longer exists. + window.__rfTicksSet = function(next){ ticks = next; }; + window.__rfTicksSync = sync; + if(window.Shiny && !window.__rfTicksBound){ + window.__rfTicksBound = true; + Shiny.addCustomMessageHandler('rf_set_ticks', function(msg){ + var on = [].concat(msg.i || []), next = {}, k; + for(k = 0; k < on.length; k++){ next[on[k]] = true; } + if(window.__rfTicksSet){ window.__rfTicksSet(next); } + if(window.__rfTicksSync){ window.__rfTicksSync(); } + }); + } +" + +ui = page_navbar( + title = 'Rfits Cutout Explorer', + id = 'nav', + #window_title is renamed windowTitle in bslib 1.0, and either way the browser tab gets + #the title above, so it is left to the default rather than branching on version. + #fillable = FALSE matters more than it looks. With the default TRUE every tab is + #stretched to exactly the viewport height and each card's body scrolls inside its own + #slice of it, which for a column of tall square cutouts becomes a short letter box with + #a scrollbar of its own. Flowing the page instead lets the cutout column run as long as + #it needs to and the window scroll do the work + fillable = FALSE, + header = tags$style(HTML(" + .rf-name { font-weight: 600; margin-bottom: 0.15rem; margin-top: 0.8rem; } + .rf-meta { color: var(--bs-secondary-color, #6c757d); font-size: 0.8rem; } + pre.rf-log { max-height: 18rem; overflow-y: auto; } + .rf-head-row { display: flex; justify-content: space-between; align-items: center; } + /* One square drawing area per cutout. The wrapper carries the aspect ratio and the + plot inside it is told to fill that wrapper, so a column that is wider than the + cell can only ever add space beside it, never a band above and below it. Setting a + pixel height on the plot instead is what produced the letter box: the drawing area + was as wide as the column, so a square image had to be padded to fit */ + .rf-cut { aspect-ratio: 1 / 1; width: 100%; max-width: 100%; flex: 0 0 auto; + margin-inline: auto; } + .rf-cut .shiny-plot-output { width: 100% !important; height: 100% !important; + flex: 1 1 auto; min-height: 0; } + .rf-cut img { width: 100% !important; height: 100% !important; + /* contain, not fill: if the browser and the plot ever disagree about + the size of the cell, shrinking the image is the graceful answer and + stretching it is not */ + object-fit: contain; } + .rf-cut-cell { min-width: 0; } + /* The include tick shares the name row of a cell, so it must not carry the bottom + margin Bootstrap gives a form check, and must not be wrapped away by the label */ + .rf-cut-cell .form-check { margin-bottom: 0; flex: 0 0 auto; padding-left: 1.4em; } + .rf-cut-cell .form-check-label { font-size: 0.8rem; + color: var(--bs-secondary-color, #6c757d); } + .rf-sel-row { display: flex; flex-wrap: wrap; gap: 0.4rem; align-items: center; } + .rf-sel-row .rf-name { flex: 1 1 auto; min-width: 0; } + /* A CSS grid item defaults to min-width: auto, which means it refuses to shrink below + the intrinsic width of its content. A wide index table is such content: it pushes + the column open until the whole grid scrolls, so the scrollbar that appears belongs + to the page rather than to the table and the filter card is shoved off screen. This + is the reason the Index tab could not be scrolled to the right. Letting the item + shrink hands the overflow back to the table's own scrollX */ + .bslib-grid-item { min-width: 0; } + .rf-cut-grid { display: grid; gap: 0.8rem; align-items: start; justify-content: start; } + /* A group heading spans the whole grid row, so the cutouts of one target start on a + fresh line under it rather than beside it */ + .rf-group-head { grid-column: 1 / -1; font-size: 0.95rem; + border-bottom: 1px solid var(--bs-border-color, #dee2e6); + padding-bottom: 0.25rem; margin-top: 0.4rem; } + .rf-group-n { color: var(--bs-secondary-color, #6c757d); font-weight: 400; + font-size: 0.85rem; } + /* A DataTable asks to be as wide as its content, so it must be kept inside the width + its column actually has: see the note on .bslib-grid-item above, which is the fix. + The wrapper is then allowed to scroll, so the scrollbar belongs to the table rather + than to the page */ + .dataTables_wrapper { overflow-x: auto; width: 100%; } + table.dataTable { margin-bottom: 0.6rem !important; } + ")), + + tab_panel( + title = 'Store', icon = icon('hdd'), value = 'store', + layout_column_wrap(width = 1/3, + card( + card_header(icon('key'), ' S3 credentials'), + card_body( + textInput('bucket', 'Bucket', placeholder = 'my-survey-data'), + textInput('prefix', 'Prefix of the store directory', value = '', + placeholder = 'releases/dr1'), + textInput('index_name', 'Index', value = 'index.parquet'), + helpText('Read from the bucket root, so this defaults to ', + 's3:///index.parquet. Type a path (e.g. ', + 'releases/dr1/index.parquet) to look beside the tiles instead. With no ', + 'bucket it is a local file.'), + textInput('region', 'Region', placeholder = 'us-west-2'), + textInput('endpoint', 'Custom endpoint URL', + placeholder = 'https://s3.us-east-1.wasabisys.com'), + textInput('access_key', 'Access key', + placeholder = 'blank uses RFITS_S3_ACCESS_KEY'), + passwordInput('secret_key', 'Secret key', + placeholder = 'blank uses RFITS_S3_SECRET_KEY'), + passwordInput('session_token', 'Session token', + placeholder = 'blank uses RFITS_S3_SESSION_TOKEN'), + helpText('Secrets stay in this session. They are never rendered back to the ', + 'page and never written to the log.') + ) + ), + card( + card_header(icon('folder'), ' Or a local directory'), + card_body( + textInput('dir', 'Directory of .zarr stores', + placeholder = '/data/releases/dr1 (blank to use S3)'), + helpText('Give a bucket above, or a directory here, not both. A directory whose ', + 'own name ends in .zarr is treated as a single store. With a local ', + 'directory a bare Index name is taken as a file inside it.'), + hr(), + textInput('extname', 'Extension name(s)', value = 'data1'), + helpText('Comma separated candidates, tried in order per store.'), + textInput('pattern', 'Store name pattern(s)', value = '', + placeholder = 'e.g. *grdz*, *tile?, or one per line'), + helpText('Glob(s) matched against the store path, so * and ? are wildcards and ', + 'a name on its own matches anywhere in the path. Comma or newline ', + 'separated, and all of them must match. They narrow what the Index, ', + 'Frames and Store summary tabs list, as well as what a request will ', + 'cut, so leave them blank to work with the whole index.'), + numericInput('max_dirs', 'Max directories to walk', value = 1000, min = 1, + step = 100), + checkboxInput('rebuild', 'Rebuild the index from the tiles', FALSE), + actionButton('load', 'Load index', class = 'btn-primary w-100', + icon = icon('play')) + ) + ), + card( + card_header(icon('circle-info'), ' Session'), + card_body( + uiOutput('store_status'), + accordion( + accordion_panel('Run log', icon = icon('list-check'), + verbatimTextOutput('log', placeholder = TRUE)) + ) + ) + ) + ), + card( + card_header(icon('database'), ' What is in the store'), + card_body(uiOutput('store_summary')) + ) + ), + + tab_panel( + title = 'Cutouts', icon = icon('crop'), value = 'cutouts', + #The controls are stacked down a narrow left column and the answers get the wide right + #one, because a cutout is square and a row of full width panels wastes most of the + #screen on either side of it + layout_columns(col_widths = c(4, 8), fill = FALSE, + div( + card( + #The button belongs with the header rather than at the bottom of a tall column of + #options, so that the action is visible while the positions are being typed + card_header(div(class = 'rf-head-row', + span(icon('crosshairs'), ' Request'), + actionButton('run', 'Get cutouts', icon = icon('search'), + class = 'btn-primary btn-sm'))), + card_body( + textAreaInput('positions', 'RA, Dec (degrees)', rows = 8, + placeholder = 'One target per line:\n53.1234 -27.8123\n10.5 -45.2'), + helpText('Separate the two numbers with a space or a comma. Lines starting ', + 'with # are ignored, and anything that is not two finite numbers is ', + 'reported rather than quietly dropped.'), + actionButton('clear_pos', 'Clear list', icon = icon('eraser'), + class = 'btn-outline-secondary btn-sm'), + hr(), + fluidRow( + column(6, numericInput('box', 'Box size', value = 101, min = 1, step = 10)), + column(6, selectInput('box_unit', 'Box unit', choices = c('pix', 'arcsec'), + selected = 'pix')) + ), + numericInput('buffer', 'Overlap buffer (arcsec)', value = 0, min = 0, step = 5), + textInput('kw_key', 'Header keyword filter', placeholder = 'e.g. FILTER'), + helpText('Only cut from stores whose recorded header carries this keyword. ', + 'Costs an index decode, not a pixel read.'), + textInput('kw_value', 'Keyword value (glob)', placeholder = 'e.g. *grz*'), + helpText('Matched case insensitively against the keyword, * and ? being ', + 'wildcards. Blank accepts any value the keyword takes.'), + numericInput('max_stores', 'Max stores to cut per position', value = 25, + min = 1, step = 1), + helpText('Caps how many stores are opened, and so how many pixel reads a ', + 'request makes. How many could overlap is reported before the cap.') + ) + ), + card( + card_header(icon('sliders'), ' Display'), + card_body( + helpText('Covers both the on screen plots and the downloaded JPEGs. The raw ', + 'FITS download always carries the extracted pixels unchanged.'), + fluidRow( + column(4, checkboxInput('qdiff', 'qdiff', TRUE)), + column(8, selectInput('type', 'Clipping type', choices = magmap_units, + selected = 'quan'), + helpText('Ignored when qdiff is on, which clips at the symmetric ', + 'maximum instead.')) + ), + fluidRow( + column(4, numericInput('locut', 'locut', value = NA, step = 0.1)), + column(4, numericInput('hicut', 'hicut', value = NA, step = 0.1)), + column(4, selectInput('stretch', 'stretch', + choices = c('lin', 'asinh', 'atan', 'log', 'sqrt', 'cdf'), + selected = 'asinh')) + ), + fluidRow( + column(6, numericInput('slice', 'Slice', value = 1, min = 1, step = 1), + div(class = 'rf-meta', 'Plane of a cube or array cutout.')), + column(6, numericInput('cut_width', 'Cutout width (px)', value = 720, + min = 160, step = 20), + div(class = 'rf-meta', 'Side of each square panel, and the pixel ', + 'size of a downloaded JPEG.')) + ), + fluidRow( + column(6, checkboxInput('useraster', 'useRaster', TRUE)), + column(6, numericInput('max_show', 'Max cutouts to plot', value = 24, + min = 1, step = 1), + div(class = 'rf-meta', 'Results beyond this are still listed and ', + 'downloadable, just not drawn.')) + ) + ) + ), + card( + card_header(icon('file-zipper'), ' Download'), + card_body( + helpText('Only the included cutouts are bundled, and nothing is re-cut: the ', + 'pixels are those already in memory, however they were chosen. Raw ', + 'FITS is the extracted data as it stands; tile compressed may drop ', + 'precision unless the quantization level is 0.'), + radioButtons('fits_format', 'FITS files', + choices = c('Raw (uncompressed)' = 'raw', + 'Tile compressed' = 'compress'), + selected = 'raw'), + #Rendered rather than merely shown or hidden. cfitsio only reads the options + #after [compress when it is asked to compress at all, so controls that can be + #silently ignored are worse than controls that are not there + uiOutput('comp_opts_ui'), + hr(), + numericInput('jpeg_quality', 'JPEG quality', value = 75, min = 1, max = 100, + step = 5), + div(class = 'rf-meta', 'Given to grDevices::jpeg, so it affects the downloaded ', + 'JPEGs only, not the plots on screen. The R default is 75; 90 and above is ', + 'close to lossless for these images.') + ) + ) + ), + div( + card( + card_header(icon('table'), ' Results', uiOutput('result_counts')), + card_body( + uiOutput('index_note'), + #One selection for the whole tab: the buttons below, the tick beside each + #plotted cutout, and the results table's row checkboxes all read and write the + #same logical vector + uiOutput('select_bar'), + div(class = 'd-flex gap-2 mb-2', + downloadButton('dl_fits', 'Download selected as FITS (zip)', + icon = icon('file-zipper'), class = 'btn-outline-primary'), + downloadButton('dl_jpeg', 'Download selected as JPEG (zip)', + icon = icon('file-zipper'), class = 'btn-outline-success')), + helpText('FITS files are written from the extracted pixels and header with ', + 'Rfits_write_image, so each keeps the WCS of the tile it came from. ', + 'JPEGs are re-rendered with the options above.'), + if(has_dt){ + DT::dataTableOutput('match_table') + }else{ + tableOutput('match_table') + } + ) + ), + card( + card_header(icon('images'), ' Cutouts'), + card_body(uiOutput('gallery')) + ) + ) + ) + ), + + tab_panel( + title = 'Index', icon = icon('table-list'), value = 'index', + layout_columns(col_widths = c(3, 9), fill = FALSE, + card( + card_header(icon('magnifying-glass'), ' Filter'), + card_body( + textInput('idx_filter', 'Store name glob', value = ''), + selectInput('idx_status', 'Status', choices = 'all'), + actionButton('idx_refresh', 'Reload rows', class = 'btn-outline-primary', + icon = icon('arrows-rotate')), + hr(), + verbatimTextOutput('idx_info', placeholder = TRUE) + ) + ), + card( + card_header(' index rows'), + card_body( + helpText('What the search reads: one row per store per extension, holding the ', + 'reference position, shape and pixel scale the overlap test works from. ', + 'Keyword blobs are hidden here but are what the header filter uses.'), + #Height is given in pixels rather than left to 'auto'. A DataTable inside a + #bslib card has no intrinsic height of its own, and with auto it collapses to + #the size of the page, which is what makes the horizontal scrollbar unreachable + if(has_dt){ + DT::dataTableOutput('index_table', height = '620px') + }else{ + tableOutput('index_table') + } + ) + ) + ) + ), + + tab_panel( + title = 'Frames', icon = icon('map'), value = 'frames', + layout_columns(col_widths = c(9, 3), fill = FALSE, + card( + card_header(icon('vector-square'), ' Available frames'), + card_body( + #Interactive rather than a static plot because the whole point of this panel is + #finding a position inside a crowded release: you zoom on the tiles that matter + #and click the one you want, which is not something a dragged box can do. + #Drawn from the index, so no pixel is read to place a box + helpText('Click anywhere to pick that exact RA/Dec, as often as you like and at ', + 'any zoom; the view does not move while you do it. To take whole tiles, ', + 'use the Select box or lasso tool in the mode bar, which highlights the ', + 'frames caught and sends their centres. Scroll to zoom or use the zoom ', + 'tool; double click resets. Hovering a frame gives its store, extension ', + 'and shape. Boxes are footprints worked out from the index, so they are ', + 'axis aligned and ignore rotation. Filters on the Index tab apply here ', + 'too.'), + plotly::plotlyOutput('frames', height = '620px'), + verbatimTextOutput('frames_info', placeholder = TRUE) + ) + ), + card( + card_header(' Selection'), + card_body( + actionButton('send_pos', 'Send clicked positions', class = 'btn-primary w-100', + icon = icon('crop')), + div(style = 'height: 0.4rem;'), + actionButton('send_sel', 'Send selected frames', class = 'btn-outline-primary w-100', + icon = icon('object-group')), + div(style = 'height: 0.4rem;'), + actionButton('clear_picks', 'Clear clicked', class = 'btn-outline-secondary w-100', + icon = icon('eraser')), + div(style = 'height: 0.8rem;'), + if(has_dt){ + DT::dataTableOutput('frames_table', height = '420px') + }else{ + tableOutput('frames_table') + } + ) + ) + ) + ) +) + +server = function(input, output, session){ + + #pos_idx is the position each result came from, parallel to res, and pos_lab is the + #caption of each position. Both are written before res is assigned, so an observer that + #fires on res always finds the metadata that belongs to it rather than the last run's + #pos_idx is the position each result came from, parallel to res, and pos_lab is the + #caption of each position. Both are written before res is assigned, so an observer that + #fires on res always finds the metadata that belongs to it rather than the last run's + state = reactiveValues(con = NULL, idx = NULL, rows = NULL, log = character(0), + res = NULL, matches = NULL, sel = NULL, run = 0L, + pos_idx = NULL, pos_lab = NULL) + + #The progress bar of the run in flight. An environment rather than a slot on state + #because nothing renders it, and a reactive value that holds an R6 object is a + #dependency every reader of state would invalidate on + bar = new.env(parent = emptyenv()) + bar$prog = NULL + + note = function(...){ + txt = paste0(..., collapse = '') + if(!nzchar(txt)){ + return(invisible(NULL)) + } + state$log = c(state$log, paste0(format(Sys.time(), '%H:%M:%S'), ' ', txt)) + #Keep the tail only. A rebuild of a large release can emit a line per store, and the + #oldest of those is the least useful thing in the box + if(length(state$log) > 500){ + state$log = tail(state$log, 500) + } + invisible(NULL) + } + + blank = function(v) if(is.null(v) || !nzchar(trimws(v))) NULL else trimws(v) + + #An input that has not arrived yet is NULL rather than '', and NULL then breaks the + #checks it is used in: nzchar(NULL) and is.na(NULL) are logical(0), which makes if() and + #|| fail with 'argument is of length zero', and an empty string reaching checkmate as + #character(0) fails assertString. This happens in practice as well as in tests, since a + #handler can run before every control has reported. Reading a control through in_() + #gives the empty value its type would have, so a missing value means the same as a + #blank one and no handler has to remember the difference + in_ = function(id, default = ''){ + v = input[[id]] + if(is.null(v)){ + return(default) + } + return(v) + } + + #Numeric controls, whose empty value is NA rather than ''. A control the user cleared + #arrives as NA on its own, so the two cases are the same to the caller + num_ = function(id, default = NA_real_){ + v = suppressWarnings(as.numeric(in_(id, default)))[1] + if(is.null(v)){ + return(default) + } + return(v) + } + + #A checkbox, whose absent value is FALSE + flag_ = function(id){ + return(isTRUE(in_(id, FALSE))) + } + + #Secrets are read from the environment when the field is left blank, which is how a + #scripted run and this app come by the same credentials without them being typed into a + #form. They are kept in a plain list in a reactiveValues: never rendered, never logged, + #and a reactiveValue invalidates nothing that does not read it, so typing a key does not + #re-run the observers that walk the inputs + collect_creds = function(){ + one = function(field, name){ + v = blank(in_(field)) + if(!is.null(v)){ + return(v) + } + v = Sys.getenv(name, '') + if(nzchar(v)) v else NULL + } + return(list(region = one('region', 'RFITS_S3_REGION'), + endpoint = one('endpoint', 'RFITS_S3_ENDPOINT'), + access_key = one('access_key', 'RFITS_S3_ACCESS_KEY'), + secret_key = one('secret_key', 'RFITS_S3_SECRET_KEY'), + session_token = one('session_token', 'RFITS_S3_SESSION_TOKEN'))) + } + + collect_con = function(){ + #Store name patterns are globs rather than regular expressions: the field holds a name + #or a path, and *.zarr or tile* is what someone looking at a release will type. They + #are converted once, here, into the regular expressions that the index builder and the + #re-filter in do_run both match with, so the two cannot disagree about what a pattern + #means. It also means the walk key of a built index is the conversion, not the typing + patterns = trimws(unlist(strsplit(gsub('\\t', ' ', in_('pattern')), '[\r\n,]+'))) + patterns = patterns[nzchar(patterns)] + patterns = glob_regex(patterns) + ext = trimws(unlist(strsplit(in_('extname', 'data1'), '[,\r\n ]+'))) + ext = ext[nzchar(ext)] + dir = blank(in_('dir')) + bucket = blank(in_('bucket')) + if(!is.null(bucket) && !is.null(dir)){ + stop('Give a bucket or a local directory, not both.', call. = FALSE) + } + if(is.null(bucket) && is.null(dir)){ + stop('Give a bucket (with credentials) or a local directory of stores.', + call. = FALSE) + } + index_name = in_('index_name', 'index.parquet') + if(!nzchar(index_name)){ + index_name = 'index.parquet' + } + #The remote and local defaults differ for a reason. Over S3 a bare name goes to the + #bucket root, which is the published location this app assumes, and a name carrying a + #separator is the key itself. Locally, any relative name is resolved inside the store + #directory: a relative path would otherwise be read against whatever working directory + #the app happened to be started from, which is neither of the two places a user could + #mean by it + index_prefix = NULL + if(is.null(bucket)){ + if(!grepl('^(/|~|[A-Za-z]:)', index_name)){ + index_name = file.path(dir, index_name) + } + } + max_dirs = num_('max_dirs', 1000) + if(!is.finite(max_dirs) || max_dirs < 1){ + max_dirs = 1000 + } + #Clamped before the cast. A numericInput takes 1e10 and as.integer() turns that into + #NA, which then fails an assertion inside Rfits_zarr_index with a message that says + #nothing about this field + max_dirs = as.integer(min(max_dirs, 1e6)) + return(list(bucket = bucket, dir = dir, prefix = trimws(in_('prefix')), + index_name = index_name, index_prefix = index_prefix, + pattern = if(length(patterns) > 0) patterns else NULL, + extname = if(length(ext) > 0) ext else 'data1', + max_dirs = max_dirs, + creds = collect_creds())) + } + + output$log = renderText(paste(state$log, collapse = '\n')) + + output$store_status = renderUI({ + idx = state$idx + if(is.null(idx)){ + return(em('No index loaded yet. Describe a store and press Load index.')) + } + con = state$con + tags$ul( + tags$li(strong('Stores: '), if(is.null(con$bucket)){ + paste0('local ', con$dir) + }else{ + paste0('s3://', con$bucket, '/', con$prefix) + }), + tags$li(strong('Index: '), idx$shown, + if(isTRUE(idx$built)) ' (built for this session)' else ''), + tags$li(strong('Rows: '), nrow(idx$rows), + if(length(con$pattern) > 0) ' (store name pattern applied)') + ) + }) + + output$store_summary = renderUI({ + rows = state$rows + req(rows) + #An index whose every row the name pattern excluded is an ordinary state, and range() on + #no rows warns rather than answering, so it is said in words instead + if(nrow(rows) == 0){ + return(em('No store in the index matches the store name pattern.')) + } + ok = rows$status == 'ok' + exts = sort(unique(rows$extname[!is.na(rows$extname)])) + typ = table(rows$type[ok]) + st = table(rows$status) + tagList( + fluidRow( + column(3, value_box(title = 'Stores', value = length(unique(rows$label)), + subtitle = 'unique paths')), + column(3, value_box(title = 'Searchable rows', value = sum(ok), + subtitle = paste0('of ', nrow(rows)))), + column(3, value_box(title = 'RA span (deg)', + value = paste(round(range(rows$ra[ok], na.rm = TRUE), 3), + collapse = '\n to '))), + column(3, value_box(title = 'Dec span (deg)', + value = paste(round(range(rows$dec[ok], na.rm = TRUE), 3), + collapse = '\n to '))) + ), + strong('Extensions: '), paste(exts, collapse = ', '), br(), + strong('Array types: '), if(length(typ) > 0) + paste(names(typ), typ, sep = ' = ', collapse = ', ') else 'none', br(), + strong('Statuses: '), paste(names(st), st, sep = ' = ', collapse = ', '), + if(any(!ok)){ + tagList(br(), tags$small('Rows that are not searchable are kept in the index so ', + 'the next run does not re-read them. The error column on ', + 'the Index tab says why.')) + }else{ + NULL + } + ) + }) + + #An index the app downloaded or built lives in the temporary directory and goes with the + #session, rather than accumulating one parquet file per page reload + session$onSessionEnded(function(){ + idx = isolate(state$idx) + if(!is.null(idx) && isTRUE(idx$owned) && !is.null(idx$path)){ + unlink(idx$path) + } + #A cutout still in flight when the page closes leaves its bar behind, and closing one + #that has already been closed is the thing tryCatch is here for + p = bar$prog + bar$prog = NULL + if(!is.null(p)){ + tryCatch(p$close(), error = function(e) NULL) + } + }) + + adopt_index = function(got){ + if(!is.null(state$idx) && isTRUE(state$idx$owned) && !is.null(state$idx$path)){ + unlink(state$idx$path) + } + #Every one of these rows is shown somewhere: the Index and Frames tabs and the Store + #summary all read state$rows, and the whole point of the name pattern is to say which + #stores a session is working with. A published index is the whole release, so a pattern + #that is not applied here would leave every tab listing stores a cutout would refuse to + #touch -- the search narrowing correctly while the tabs contradicted it. The narrowing is + #display only: the index file is queried whole, and do_run applies the same helper to the + #candidates it finds there + full = as.data.frame(got$rows, stringsAsFactors = FALSE) + rows = pattern_rows(full, state$con$pattern) + got$rows = rows + state$idx = got + state$rows = rows + updateSelectInput(session, 'idx_status', choices = c('all', sort(unique(rows$status)))) + note('Index ready: ', nrow(rows), ' row(s), ', length(unique(rows$label)), + ' store(s), extname(s) ', + paste(sort(unique(rows$extname)), collapse = ', ')) + if(length(state$con$pattern) > 0){ + note('Name pattern kept ', nrow(rows), ' of ', nrow(full), ' index row(s)') + } + invisible(NULL) + } + + observeEvent(input$load, { + con = tryCatch(collect_con(), error = function(e) e) + if(inherits(con, 'error')){ + note('ERROR: ', conditionMessage(con)) + return(NULL) + } + if(!is.null(con$bucket) && is.null(con$creds$access_key)){ + #Without a key paws falls back to anonymous credentials, which can read a public + #bucket but reports AccessDenied for most, and the failure then looks as though the + #bucket name is wrong rather than the credentials being absent + note('WARNING: no access key given and RFITS_S3_ACCESS_KEY is unset, so the ', + 'request will be made anonymously.') + } + state$con = con + #Progress takes no message in its constructor; the text is carried by every set() call + prog = Progress$new(session, min = 0, max = 1) + on.exit(prog$close(), add = TRUE) + prog$set(0.1, message = if(flag_('rebuild')) 'Building index' else 'Reading index', + detail = 'contacting store') + got = load_index(con, rebuild = flag_('rebuild'), note = note) + if(!is.null(got$error)){ + note('ERROR: ', got$error) + showNotification(got$error, type = 'error') + return(NULL) + } + prog$set(1) + adopt_index(got) + bslib::nav_select('nav', 'cutouts') + }) + + observeEvent(input$clear_pos, { + updateTextAreaInput(session, 'positions', value = '') + }) + + #The display controls as one snapshot. Reactive rather than captured with each request + #so that changing a stretch redraws the plots from the pixels already in memory, which + #costs nothing, rather than implying the cutouts have to be fetched again + display_opts = reactive({ + list(qdiff = flag_('qdiff'), type = in_('type', 'quan'), + stretch = in_('stretch', 'asinh'), locut = num_('locut'), hicut = num_('hicut'), + useraster = flag_('useraster'), slice = num_('slice', 1), + width = cut_width(), max_show = max_show()) + }) + + #Side of a square cutout panel, in pixels. Used for both the on screen cell and the + #downloaded JPEG so what a user sees is what they get + cut_width = reactive({ + w = num_('cut_width', 720) + if(is.na(w) || w < 160) 720 else min(w, 1200) + }) + + #Only this many of the results are drawn. A request that overlaps a thousand tiles would + #otherwise bind a thousand plot outputs, each of which the browser has to fetch and + #decode, and the page becomes unusable rather than merely slow. Everything is still + #listed in the match table and still goes into the downloads + max_show = reactive({ + n = num_('max_show', 24) + if(is.na(n) || n < 1) 24 else as.integer(min(n, 500)) + }) + + draw_cutout = function(item, opts, inset = NULL){ + if(is.null(item) || is.null(item$imDat)){ + plot.new() + text(0.5, 0.5, 'No pixel data was extracted for this cutout.', xpd = NA) + draw_inset(inset) + return(invisible(NULL)) + } + extra = list(qdiff = opts$qdiff, useRaster = opts$useraster, main = '') + #With qdiff on, magimage sets type = 'num' itself and derives locut from hicut, so + #passing a quantile through would either error or fight the diverging scale + if(!opts$qdiff){ + extra$type = opts$type + extra$stretch = opts$stretch + } + if(is.finite(opts$locut)){ + extra$locut = opts$locut + } + if(is.finite(opts$hicut)){ + extra$hicut = opts$hicut + } + ndim = length(dim(item$imDat)) + if(ndim >= 3){ + nmax = dim(item$imDat)[3] + sl = max(1L, min(as.integer(if(is.na(opts$slice)) 1 else opts$slice), nmax)) + extra$slice = if(ndim == 3) sl else c(sl, sl) + } + #tryCatch because a bad stretch is a complaint from magmap rather than a broken cutout, + #and one red box per cell in a gallery of twelve is worse than the message it carries + drew = tryCatch({ + do.call(plot, c(list(x = item), extra)) + TRUE + }, error = function(e){ + plot.new() + text(0.5, 0.5, conditionMessage(e), xpd = NA, cex = 0.8) + FALSE + }) + #Drawn last so it is on top of the image whether the plot succeeded or not + draw_inset(inset) + invisible(drew) + } + + #Compression keys a tile-compressed store carries in its header. A cutout inherits them + #from the tile it came from, but only the compressed download is allowed to keep them: + #written raw, a plain image that says ZIMAGE = TRUE in its primary header is a file that + #tells a reader to expect a binary table it does not contain, so they are removed. + #ZNAXIS is built out rather than listed because it comes with one key per axis, and a + #header from a cube store carries ZNAXIS1 through ZNAXIS3 + cfitsio_comp_keys = c('ZIMAGE', 'ZBITPIX', 'ZQUANTIZ', 'ZNBDTP', 'ZDITHER0', 'ZTILELEN', + 'ZNAXIS', paste0('ZNAXIS', 1:6), 'ZEXPSC', 'ZEXPZERO', 'ZNOFFSC', + 'ZNOFFZERO', 'ZBLANKFIX', 'ZVAL1', 'ZVAL2', 'ZSCALE', 'ZZERO') + + #The pixels of a cutout are the pixels of its header, and the header may not have been + #the source of either. .zarr_cutout_box_keyvalues rewrites NAXIS to the box size, which + #for a cube or array is the size of one plane rather than of the data in hand, and a raw + #write of a tile-compressed cutout has had its ZNAXIS keys dropped above. Both are + #restored here from the data, which is the only thing that can be authoritative. + fix_shape_keys = function(item){ + dm = dim(item$imDat) + if(is.null(dm) || length(dm) == 0){ + return(item) + } + if(is.null(item$keyvalues)){ + return(item) + } + kv = item$keyvalues + kv$NAXIS = length(dm) + for(i in seq_along(dm)){ + kv[[paste0('NAXIS', i)]] = dm[i] + } + item$keyvalues = kv + return(item) + } + + #Download options, read outside a reactive context by the handlers below. Kept as one + #function so the FITS and JPEG paths agree on what 'selected' and 'compressed' mean, and + #so a control that has not reported yet falls back to the value the UI shipped with + dl_opts = function(){ + q = suppressWarnings(as.numeric(in_('jpeg_quality', 75)))[1] + if(is.na(q)){ + q = 75 + } + q = max(1, min(100, round(q))) + #The algorithm is matched against the list the selectInput offers rather than taken + #as typed. It ends up inside the '[compress ...]' directive cfitsio parses out of the + #output filename, and the tile sizes beside it are cleaned for the same reason; a + #request posted by hand is not bound by what the widget rendered. + alg = in_('fits_alg', 'RICE') + if(!(alg %in% c('RICE', 'GZIP', 'HCOMPRESS', 'PLIO'))){ + alg = 'RICE' + } + return(list(fits_format = in_('fits_format', 'raw'), alg = alg, + tile = in_('fits_tile', ''), quant = num_('fits_quant'), + jpeg_quality = q)) + } + + #The cfitsio compression spec, as the text between '[compress ' and ']'. The parser in + #cfileio.c reads the algorithm from its first letter, then the tile dimensions, then + #parameters after a semicolon, so the pieces are joined in that order. + # + #The tile sizes are tidied here rather than where they are typed because this is the + #only place that knows they are going into a string cfitsio parses: the box happily + #takes '64, 64' or '64 64' from a user, and either would have to arrive as '64,64' + comp_spec = function(o){ + tile = gsub('[ ,]+', ',', gsub('[^0-9, ]', '', trimws(o$tile))) + tile = gsub('^,+|,+$', '', tile) + spec = o$alg + if(nzchar(tile)){ + spec = paste0(spec, ' ', tile) + } + if(is.finite(o$quant)){ + spec = paste0(spec, '; q ', format(o$quant, scientific = FALSE, trim = TRUE)) + } + return(spec) + } + + #Which results go in a bundle. Everything by default, since the common case is 'I want + #this whole request', and the point of the controls below is that taking a subset is + #easier than naming one. A selection of the wrong length is treated as no selection at + #all rather than truncated, because a run that changed the number of results has to + #re-start from 'everything' for the count on screen to mean anything + sel_of = function(res, sel){ + if(is.null(res) || length(res) == 0){ + return(logical(0)) + } + if(is.null(sel) || length(sel) != length(res)){ + return(rep(TRUE, length(res))) + } + as.logical(sel) + } + + #The count beside the buttons, as a reactive of its own. selected_idx() isolates because + #the download handlers call it from a non-reactive context, and an isolating reader is + #exactly the wrong thing to depend on for a number that has to move when the user ticks + #a box + n_selected = reactive({ + sum(sel_of(state$res, state$sel)) + }) + + selected_idx = function(){ + which(sel_of(isolate(state$res), isolate(state$sel))) + } + + #The cells that have a tick box beside them, which is the plotted prefix of the results + #rather than all of them. Everything that reads or writes the per cutout inputs goes + #through here so that the gallery and the observers cannot disagree about how many boxes + #are on the page + sel_ids = function(){ + res = isolate(state$res) + if(is.null(res)){ + return(integer(0)) + } + seq_len(min(length(res), max_show())) + } + + #Input ids carry the request that made them. A box is only ever read once every box of + #the current run has reported, and numbering them per run is what makes that wait mean + #the current run rather than a leftover from the last one: results shrink between + #requests as often as they grow, and a stale sel_17 reporting TRUE after a request that + #returned five cutouts would otherwise be read as a tick on the wrong cutout + cell_id = function(i){ + paste0('sel_', isolate(state$run), '_', i) + } + + #The same list, cut to the selection. Everything downstream writes in terms of a result + #list, so subsetting once here keeps the gallery, the count and the two bundles from each + #having to work out the selection their own way + selected_res = function(){ + res = state$res + idx = selected_idx() + if(is.null(res) || length(idx) == 0){ + return(NULL) + } + res[idx] + } + + #A new result list always arrives with everything included, which is what the previous + #request's tick marks would otherwise silently contradict + observeEvent(state$res, { + res = state$res + state$sel = if(is.null(res) || length(res) == 0){ + NULL + }else{ + rep(TRUE, length(res)) + } + }) + + #Both buttons go through the same three lines, so 'none' and 'invert' cannot disagree + #about what a selection of the wrong length means + set_sel = function(fn){ + sel = sel_of(state$res, state$sel) + if(length(sel) == 0){ + return(invisible(NULL)) + } + state$sel = fn(sel) + } + + observeEvent(input$sel_all, { + set_sel(function(sel) rep(TRUE, length(sel))) + }) + + observeEvent(input$sel_none, { + set_sel(function(sel) rep(FALSE, length(sel))) + }) + + observeEvent(input$sel_invert, { + set_sel(function(sel) !sel) + }) + + #One change of one tick in the results table, which is all the page can report: with + #paging, the rows on the other pages are not in the document, so a tick cannot arrive as + #the full set of what is included. The index is the position in the result list rather + #than in the table, so the sort and the search cannot move it + observeEvent(input$match_tick, { + ev = input$match_tick + res = state$res + if(is.null(res) || is.null(ev) || is.null(ev$i)){ + return(invisible(NULL)) + } + i = as.integer(ev$i) + if(length(i) != 1 || is.na(i) || i < 1 || i > length(res)){ + return(invisible(NULL)) + } + sel = sel_of(res, state$sel) + on = isTRUE(ev$on) + if(isTRUE(sel[i] == on)){ + return(invisible(NULL)) + } + sel[i] = on + state$sel = sel + }) + + #The boxes as the page reports them, or NULL while any of them is missing. A cell that + #has not been drawn yet arrives as NULL, and reading a partial set would clear the + #results that are included but not currently on screen; the cells render together, so + #the wait is a frame rather than anything the user can see. + # + #Deliberately a reactive of its own rather than an observer that reads the selection as + #well as the inputs: such an observer is re-run by its own write, and would put the + #stale ticks back over it, so clicking Include none would immediately undo itself + cell_ticks = reactive({ + res = state$res + req(res) + n = length(sel_ids()) + if(n == 0){ + return(NULL) + } + got = lapply(seq_len(n), function(i) input[[cell_id(i)]]) + if(any(vapply(got, is.null, logical(1)))){ + return(NULL) + } + vapply(got, isTRUE, logical(1)) + }) + + observeEvent(cell_ticks(), { + res = state$res + req(res) + ticked = cell_ticks() + n = length(ticked) + sel = sel_of(res, state$sel) + if(identical(sel[seq_len(n)], ticked)){ + return(invisible(NULL)) + } + sel[seq_len(n)] = ticked + state$sel = sel + }) + + #Pushed back to the page so that the buttons, the table and the ticks cannot disagree + #about what is included: the state is the only truth, and the boxes follow it. Only the + #plotted cells have a box to update; a cutout that is included but not drawn stays + #included, which is what the count beside the buttons says. + # + #req() takes the length check rather than the vector because it treats an all FALSE + #selection as falsy, which is precisely the state 'Include none' produces: the push was + #aborted, the boxes on the page kept their old ticks, and they then reported those ticks + #back as the user's choice and undid it + observeEvent(state$sel, { + res = state$res + req(res) + sel = state$sel + if(is.null(sel) || length(sel) != length(res)){ + return(invisible(NULL)) + } + for(i in sel_ids()){ + updateCheckboxInput(session, cell_id(i), value = isTRUE(sel[i])) + } + if(has_dt){ + #The table's boxes are drawn from data and cannot be updated by Shiny, so they are + #ticked in place. Redrawing the table instead would throw away the search, the sort + #and the page the user is on, which is the only reason the table has a search box + session$sendCustomMessage('rf_set_ticks', list(i = which(sel))) + } + }) + + output$select_bar = renderUI({ + res = state$res + if(is.null(res) || length(res) == 0){ + return(helpText('Run a request to choose which cutouts to download.')) + } + div(class = 'rf-sel-row mb-2', + actionButton('sel_all', 'Include all', icon = icon('check'), + class = 'btn-outline-primary btn-sm'), + actionButton('sel_none', 'Include none', icon = icon('xmark'), + class = 'btn-outline-secondary btn-sm'), + actionButton('sel_invert', 'Invert', icon = icon('arrows-rotate'), + class = 'btn-outline-secondary btn-sm'), + uiOutput('sel_count')) + }) + + output$sel_count = renderUI({ + res = state$res + req(res) + helpText(class = 'ms-auto', n_selected(), ' of ', length(res), + ' included in the download.') + }) + + #The compression controls only exist while something is being compressed. They are drawn + #in place rather than greyed out because cfitsio reads the options after [compress only + #when it is asked to compress, so visible-but-ignored controls would promise a quantizer + #that a raw download quietly drops + output$comp_opts_ui = renderUI({ + if(!identical(in_('fits_format', 'raw'), 'compress')){ + return(NULL) + } + tagList( + fluidRow( + column(6, selectInput('fits_alg', 'Algorithm', + choices = c('RICE' = 'RICE', 'GZIP' = 'GZIP', + 'HCOMPRESS' = 'HCOMPRESS', 'PLIO' = 'PLIO'), + selected = 'RICE')), + column(6, textInput('fits_tile', 'Tile size (px)', value = '', + placeholder = 'e.g. 64,64')) + ), + div(class = 'rf-meta', 'Blank tile size leaves cfitsio on its default, which is one ', + 'row per tile. PLIO is integer only and will fail on a floating point cutout.'), + numericInput('fits_quant', 'Quantization level', value = NA, step = 1), + #Blank is not the same as zero, and the difference is whether the pixels come back + #unchanged: cfitsio quantizes by default, so a plain RICE download is a lossy one + helpText('How much precision the compression is allowed to drop. A positive value ', + 'gives the number of quantization bins per pixel of noise, and cfitsio ', + 'defaults to 4; a negative value is an absolute bin size in data units ', + '(e.g. -0.0002); 0 is lossless, and GZIP at 0 gives the pixels back to ', + 'single precision. Blank leaves cfitsio on its own lossy default.'), + helpText('A compressed file is a tile-compressed image held in a binary table, so ', + 'read it back with ext = 2.') + ) + }) + + #Returns the list of written files, or NULL. The directory is removed by the caller + #after zipping, not here: bundling and archiving are two steps and the files have to + #survive the gap between them + write_all = function(ext, fun){ + #The selection is read through a reactive so that this stays the only place the two + #download paths decide what is in a bundle + res = selected_res() + if(is.null(res) || length(res) == 0){ + #Logged as well as flashed, because the notification is gone in a few seconds and a + #user who has clicked Include none and then the download button needs to be able to + #see that those are two separate facts rather than a lost result + showNotification('No cutouts are selected for download.', type = 'warning') + note('No cutouts are selected for download.') + return(NULL) + } + if(!requireNamespace('zip', quietly = TRUE)){ + showNotification('The zip package is needed to bundle downloads.', type = 'error') + note('ERROR: the zip package is needed to bundle downloads.') + return(NULL) + } + dir = tempfile('rfits_dl_') + dir.create(dir, recursive = TRUE, showWarnings = FALSE) + wrote = character(0) + prog = Progress$new(session, min = 0, max = length(res)) + on.exit(prog$close(), add = TRUE) + for(i in seq_along(res)){ + prog$set(i, message = 'Bundling', detail = paste0(names(res)[i], '.', ext)) + out = file.path(dir, paste0(safe_filename(names(res)[i]), '.', ext)) + one = with_capture(tryCatch({ + fun(res[[i]], out) + TRUE + }, error = function(e) e)) + for(m in one$msgs) note(m) + if(isTRUE(one$value) && file.exists(out)){ + wrote = c(wrote, out) + }else{ + note('WARNING: could not write ', basename(out)) + } + } + if(length(wrote) == 0){ + showNotification('Nothing could be written.', type = 'error') + unlink(dir, recursive = TRUE) + return(NULL) + } + note('Wrote ', length(wrote), ' ', ext, ' file(s).') + return(list(dir = dir, files = basename(wrote))) + } + + #A downloaded FITS must say what it is. The header a cutout carries is the header of the + #store it came from, and a tile-compressed store records its shape in ZNAXIS rather than + #NAXIS and sets ZIMAGE; Rfits_write_image honours that flag and writes the keys rather + #than the pixels they describe, which gives a raw file no one can open. Stripping them is + #what makes 'download as raw' mean the same thing for either kind of source. Compressed + #downloads keep them, since cfitsio rewrites the Z* keys for the tiles it actually makes + #and a stale ZNAXIS1 in a file it is being asked to compress is not a description of the + #file it will end up with either + prepare_fits_item = function(item, o){ + item = fix_shape_keys(item) + if(identical(o$fits_format, 'compress')){ + return(item) + } + drop = intersect(cfitsio_comp_keys, names(item$keyvalues)) + if(length(drop) > 0){ + item$keyvalues[drop] = NULL + item$keycomments[drop] = NULL + item$keynames = names(item$keyvalues) + #The card image is rebuilt from the keywords when present, and a stale copy would + #carry the removed keys straight back into the file + item$header = NULL + item$hdr = NULL + item$raw = NULL + } + return(item) + } + + output$dl_fits = downloadHandler( + #The name says what is in the zip, since a compressed download is not interchangeable + #with a raw one and a user with two of these in their downloads folder needs to know + filename = function(){ + o = isolate(dl_opts()) + if(identical(o$fits_format, 'compress')){ + return('rfits-cutouts-fits-compressed.zip') + } + return('rfits-cutouts-fits.zip') + }, + content = function(file){ + #Rfits_write_image takes the object, so keyvalues and history come along with the + #pixels and the written file is re-openable with the WCS intact + o = isolate(dl_opts()) + compress = if(identical(o$fits_format, 'compress')) comp_spec(o) else FALSE + got = write_all('fits', function(item, out){ + Rfits::Rfits_write_image(prepare_fits_item(item, o), filename = out, + compress = compress) + }) + if(is.null(got)){ + return(invisible(NULL)) + } + on.exit(unlink(got$dir, recursive = TRUE), add = TRUE) + zip::zip(zipfile = file, files = got$files, root = normalizePath(got$dir)) + }, + contentType = 'application/zip' + ) + + #The arguments that open a JPEG device. cairo is the implementation that obeys a + #quality setting: the macOS quartz device, which is this platform's default, takes the + #argument and ignores it, so a quality of 20 would quietly produce the same file as 95. + #With no cairo at all the argument is left off rather than passed as NULL, which + #grDevices::jpeg hands to match.arg, and the log says so instead of the page pretending + #the control did something + jpeg_args = function(quality){ + if(!isTRUE(capabilities('cairo'))){ + note('WARNING: no cairo device, so the JPEG quality setting is ignored.') + return(list()) + } + return(list(quality = quality, type = 'cairo')) + } + + output$dl_jpeg = downloadHandler( + filename = function() 'rfits-cutouts-jpeg.zip', + content = function(file){ + #The on screen plots are drawn into the browser's device, so they are re-rendered + #here with the same arguments rather than captured from the page. A reactive cannot + #be read outside a reactive context, and downloadHandler$content is not one, so the + #options are isolated once here rather than inside the per file loop. + # + #The one argument not carried across is the gallery's position inset. That is a + #navigation aid for a page of similar cutouts, and burning text into the pixels + #would make a JPEG differ from the FITS beside it in the same bundle, which is data + #with no overlay on it. The file name carries the position instead + opts = isolate(display_opts()) + o = isolate(dl_opts()) + jpeg_args = isolate(jpeg_args(o$jpeg_quality)) + got = write_all('jpg', function(item, out){ + #Square, like the panel on screen. magimage draws into whatever device it is + #given, so a wide device would buy a wider image rather than a bigger source + #region, and the two would no longer look like each other + w = as.integer(opts$width) + #Quality is what the Download card asks for, and grDevices::jpeg takes it on the + #open call rather than on close. + # + #res is derived from the side rather than fixed at 120 because jpeg() works out + #its figure size in inches from the two, and magimage needs room for its axes: at + #120 dpi a 200 px cutout is 1.7 inches square and the plot dies with 'figure + #margins too large'. Six inches keeps the physical size the old constant gave at + #the default width, and makes every requested width drawable. + # + #cairo is asked for by name because it is the implementation that honours the + #quality argument. The macOS device takes it and ignores it, which would make the + #control look like it works while every download came out the same size + do.call(jpeg, c(list(filename = out, width = w, height = w, res = w/6), + jpeg_args)) + on.exit(tryCatch(dev.off(), error = function(e) NULL), add = TRUE) + draw_cutout(item, opts) + }) + if(is.null(got)){ + return(invisible(NULL)) + } + on.exit(unlink(got$dir, recursive = TRUE), add = TRUE) + zip::zip(zipfile = file, files = got$files, root = normalizePath(got$dir)) + }, + contentType = 'application/zip' + ) + + do_run = function(){ + req(state$idx) + #Bumped first, so that the tick boxes of the run that is about to be drawn cannot be + #confused with the ones still on the page + state$run = state$run + 1L + #Cleared before anything is asked for, so that what is on screen is always the answer + #to the request that is in the boxes. A run that fails part way through used to leave + #the previous results plotted under the new positions, which reads as an answer about + #targets that were never searched + state$res = NULL + state$matches = NULL + state$pos_idx = NULL + state$pos_lab = NULL + pos = parse_positions(in_('positions')) + bad = attr(pos, 'bad') + if(length(bad) > 0){ + note('WARNING: ', length(bad), ' line(s) ignored as positions: ', + paste(bad, collapse = '; ')) + } + if(nrow(pos) == 0){ + note('ERROR: no valid RA, Dec positions given.') + showNotification('No valid RA, Dec positions to search.', type = 'warning') + return(NULL) + } + con = state$con + box_unit = in_('box_unit', 'pix') + box = num_('box') + if(!is.finite(box) || box < 1){ + note('ERROR: box size must be a number of at least 1.') + return(NULL) + } + box = as.numeric(box) + buffer = num_('buffer', 0) + buffer = if(is.finite(buffer)) max(0, buffer) else 0 + max_stores = num_('max_stores', 25) + if(!is.finite(max_stores) || max_stores < 1){ + max_stores = 25 + } + #Same clamp as max_dirs: past the integer range as.integer() gives NA, and the cap on + #candidates then dies on 'missing value where TRUE/FALSE needed' + max_stores = as.integer(min(max_stores, 1e5)) + kw_key = trimws(in_('kw_key')) + note('Searching ', nrow(pos), ' position(s), box ', box, ' ', box_unit, + if(buffer > 0) paste0(', buffer ', buffer, ' arcsec') else '') + + #One arrow query per position, then the candidate sets are unioned. The query is the + #cheap stage, a scan of a few hundred kB, and it has to be per position because the + #radius within which a store can match depends on where the request is. + cand = NULL + for(k in seq_len(nrow(pos))){ + #keywords = FALSE always. The query returns the light rows, and a header filter that + #is asked for later fetches the keyword blobs of the candidates only, which is a + #much smaller set than the union of every position's candidates + q = with_capture(Rfits::Rfits_zarr_index_query( + index = state$idx$path, RA = pos[k, 1], Dec = pos[k, 2], box = box, + box.unit = box_unit, buffer = buffer, keywords = FALSE, + verbose = TRUE, data.table = FALSE)) + for(m in q$msgs) note(m) + hit = q$value + if(is.null(hit)){ + note('ERROR: the index query failed for position ', k, '.') + return(NULL) + } + if(nrow(hit) > 0){ + cand = rbind(cand, as.data.frame(hit, stringsAsFactors = FALSE)) + } + } + if(is.null(cand)){ + note('No store in the index could overlap the requested position(s).') + state$res = NULL + state$matches = NULL + state$pos_idx = NULL + state$pos_lab = NULL + return(NULL) + } + cand = cand[order(cand$label), , drop = FALSE] + cand = cand[!duplicated(cand$cache_key), , drop = FALSE] + note('Candidate store rows: ', nrow(cand)) + if(nzchar(kw_key)){ + cand = filter_by_keyword(cand, state$idx$path, kw_key, trimws(in_('kw_value')), + note = note) + if(nrow(cand) == 0){ + note('ERROR: the keyword filter removed every candidate.') + return(NULL) + } + } + #The name pattern already narrowed the index rows that were read, but the file that was + #queried is the whole published index, so it has to be applied to the candidates too. + #Through the same helper as adopt_index, so what is cut and what the tabs show cannot + #drift apart + if(length(con$pattern) > 0){ + n_cand = nrow(cand) + cand = pattern_rows(cand, con$pattern) + note('Name pattern kept ', nrow(cand), ' of ', n_cand, ' candidate row(s)') + } + if(nrow(cand) == 0){ + note('ERROR: no candidate store survived the filters.') + return(NULL) + } + cand$name = sub('\\.zarr$', '', basename(cand$store)) + if(nrow(cand) > max_stores){ + note('WARNING: ', nrow(cand), ' stores could overlap, but only the first ', + max_stores, ' were cut; raise Max stores to cut the rest.') + cand = cand[seq_len(max_stores), , drop = FALSE] + } + + run_cutouts(cand = cand, pos = pos, con = con, box = box, box_unit = box_unit, + buffer = buffer) + invisible(NULL) + } + + #Fetch the cutouts of every candidate store and assemble the result. Split out of + #do_run so that the fetching can be asynchronous while everything that reads the + #controls stays where it was: the controls are read once, synchronously, and what the + #workers are handed is a list of plain values. + # + #Per store, rather than one call for the whole prefix. Over S3 a single call that + #searched the prefix would re-read every tile's metadata, which is the cost the index + #exists to remove, and giving it cache = would write what it learned back to the + #bucket. The candidate list already is the answer, so each store is opened directly. + run_cutouts = function(cand, pos, con, box, box_unit, buffer){ + n = nrow(cand) + #Which run this call belongs to. Captured here rather than read back later, because by + #the time the workers report the user may have pressed Run again: a stale run must not + #be allowed to write its results over the one that replaced it, and without this the + #page would end up showing cutouts of positions that are no longer in the box + gen = isolate(state$run) + jobs = lapply(seq_len(n), function(i){ + list(store = cand$store[i], + name = cand$name[i], + label = if(is.null(cand$label)) cand$store[i] else cand$label[i], + #The extension the index found this candidate under goes first. A release + #indexed under 'sci' is otherwise asked for the default 'data1', and the + #failure reads as a tile that does not overlap rather than as a wrong extension + extname = unique(c(cand$extname[i], con$extname)), + RA = pos[, 1], Dec = pos[, 2], box = box, box_unit = box_unit, + buffer = buffer, bucket = con$bucket, + region = con$creds$region, endpoint = con$creds$endpoint, + access_key = con$creds$access_key, secret_key = con$creds$secret_key, + session_token = con$creds$session_token) + }) + + #The caption of each requested position, in the order the positions were given. The + #gallery groups by this and every cutout is stamped with the one it belongs to, which + #is what makes a page of twenty similar tiles navigable + pos_lab = vapply(seq_len(nrow(pos)), function(k){ + sprintf('RA %.4f Dec %+.4f', pos[k, 1], pos[k, 2]) + }, character(1)) + + #Filled by index rather than appended, so that results arriving out of order land + #where they belong and the assembly can read them positionally + results = vector(mode = 'list', length = n) + prog = Progress$new(session, min = 0, max = n) + + #The running tally, in environments rather than as a set of <<- assignments: the per + #store collectors run inside their own local() frames, and a super-assignment from + #there would land in whichever frame it happened to be called from + counts_env = new.env(parent = emptyenv()) + counts_env$done = 0L + counts_env$no_overlap = character(0) + counts_env$errored = character(0) + counts_env$stale = FALSE + scans_env = new.env(parent = emptyenv()) + scans_env$scans = NULL + + #Runs once the last store has come back, whichever order they came back in. Everything + #it reads is the collected results, so the assembly cannot see a half filled list + finish = function(){ + prog$close() + bar$prog = NULL + assemble(results, jobs, pos_lab, scans_env, counts_env) + } + + collect = function(i, one){ + #A run the user has already replaced is dropped rather than collected. Its workers + #are still running and cannot be recalled, so this is the only place the result can + #be stopped from landing. Only this run's own bar is closed, and only once: bar$prog + #belongs to whichever run is current, so it must not be cleared from here + if(!identical(isolate(state$run), gen)){ + if(!isTRUE(counts_env$stale)){ + counts_env$stale = TRUE + tryCatch(prog$close(), error = function(e) NULL) + } + return(invisible(NULL)) + } + results[[i]] <<- one + for(m in one$msgs) note(m) + counts_env$done = counts_env$done + 1L + r = one$value + if(is.null(r)){ + counts_env$errored = c(counts_env$errored, cand$name[i]) + }else if(length(r) == 0){ + counts_env$no_overlap = c(counts_env$no_overlap, cand$name[i]) + } + #Progress moves as stores land rather than as they are asked for, which is the only + #reading that means anything once they are in flight at the same time + prog$set(counts_env$done, message = 'Getting cutouts', + detail = paste0(counts_env$done, '/', n, ' ', cand$name[i])) + if(counts_env$done >= n){ + finish() + } + } + + #Held where the session cleanup can find it, so a run that never finished -- a worker + #that died, or the page closed mid request -- cannot leave a bar sitting at the top of + #the next one. The handler itself is registered once at server level rather than here, + #since one added per run would accumulate + bar$prog = prog + + for(i in seq_len(n)){ + local({ + ii = i + job = jobs[[ii]] + if(async_ok){ + #globals is listed rather than left to be detected. Detection walks the closure + #and would ship this file's whole environment, including the ui tag tree, with + #every single job + # + #seed = NULL because the read path below touches the RNG somewhere in zarr or + #the WCS code, and future warns about a worker doing that unless it is told + #whether the answer depends on it. It does not: a cutout of the same tile at the + #same position gives byte identical pixels whether it is fetched here or in this + #process, so the parallel safe seed future would otherwise set up per job buys + #nothing, and saying so is better than leaving the warning to be read as a + #result that might be wrong + promises::future_promise( + cutout_worker(job, with_capture_worker), + globals = list(job = job, cutout_worker = cutout_worker, + with_capture_worker = with_capture_worker), + seed = NULL + )$then(function(v) collect(ii, v), + #A rejected promise is a store that failed, not a run that failed: the + #others are still worth showing, and the reason goes in the log where a + #user can read it + function(e) collect(ii, list(value = NULL, msgs = paste0( + 'ERROR: ', job$name, ': ', conditionMessage(e))))) + }else{ + collect(ii, cutout_worker(job, with_capture)) + } + }) + } + invisible(NULL) + } + + #Turn the collected per store results into one result list. Ordered by the position each + #cutout belongs to rather than by the store it came from, so that the tiles covering one + #target sit together on the page instead of being interleaved by directory name + assemble = function(results, jobs, pos_lab, scans_env, counts_env){ + out = list() + names_out = character(0) + shown = character(0) + pos_idx = integer(0) + matches = NULL + scans = scans_env$scans + no_overlap = counts_env$no_overlap + errored = counts_env$errored + + #One record per cutout rather than one per store, since the ordering key (the position + #it answers) is a property of the cutout and a store can answer several + rec = list() + for(i in seq_along(results)){ + one = results[[i]] + if(is.null(one)){ + next + } + r = one$value + if(is.null(r) || length(r) == 0){ + next + } + nm = names(r) + if(is.null(nm)){ + nm = paste0(jobs[[i]]$name, '_', seq_along(r)) + } + s = attr(r, 'scan') + if(!is.null(s)){ + scans = rbind(scans, s) + } + mm = attr(r, 'matches') + mm = if(is.null(mm)) NULL else as.data.frame(mm, stringsAsFactors = FALSE) + #The match row of each cutout is found by name, since that is the one thing the + #table and the result list share. A store whose table does not line up with its + #results is reported rather than allowed to abort the run: the cutouts already + #gathered are worth more than the one row that cannot be labelled + if(!is.null(mm) && nrow(mm) != length(nm)){ + note('WARNING: ', jobs[[i]]$name, ' reported ', nrow(mm), ' match row(s) for ', + length(nm), ' cutout(s); its matches are not tabulated.') + mm = NULL + } + if(!is.null(mm)){ + mm$store = jobs[[i]]$store + mm$name = nm + } + #Which position each element of r answers, taken from its own match row. Without a + #table the group is unknown and the cutout sorts last rather than being dropped + which_pos = if(is.null(mm)) rep(NA_integer_, length(nm)) else as.integer(mm$position) + for(j in seq_along(nm)){ + rec[[length(rec) + 1L]] = list(item = r[[j]], name = nm[j], + label = jobs[[i]]$label, + store = jobs[[i]]$store, pos = which_pos[j], + mm = if(is.null(mm)) NULL else mm[j, , drop = FALSE]) + } + } + + #Position first so a group is contiguous, then store so the order within a group does + #not depend on which worker came back first. An ungroupable cutout gets an infinite + #key and so sorts last, rather than landing in the middle of a group it is not part of + if(length(rec) == 0){ + ord = integer(0) + }else{ + key_pos = vapply(rec, function(x) if(is.na(x$pos)) Inf else as.numeric(x$pos), + numeric(1)) + ord = order(key_pos, vapply(rec, function(x) x$label, character(1))) + } + for(j in ord){ + x = rec[[j]] + out[length(out) + 1L] = list(x$item) + names_out = c(names_out, x$name) + shown = c(shown, x$label) + pos_idx = c(pos_idx, if(is.na(x$pos)) NA_integer_ else as.integer(x$pos)) + if(!is.null(x$mm)){ + matches = rbind(matches, x$mm) + } + } + if(length(out) == 0){ + note('No cutout could be extracted from the candidate stores.') + if(length(no_overlap) > 0){ + note('Scanned without finding an overlap at the requested position(s): ', + paste(utils::head(no_overlap, 10), collapse = ', '), + if(length(no_overlap) > 10) paste0(' (+', length(no_overlap) - 10, ' more)') + else '') + note('An overlap is judged on the tile footprint recorded in the index, so a store ', + 'whose centre is more than about half a tile away from a position will not ', + 'appear even when the two look close on the sky. Increase the box or the ', + 'overlap buffer to reach the next tile in.') + } + state$res = NULL + state$matches = NULL + state$pos_idx = NULL + state$pos_lab = NULL + return(NULL) + } + names(out) = make.unique(names_out, sep = '_') + class(out) = 'Rfits_list' + #The label is what identifies a store to a user (s3://bucket/prefix remotely, the + #directory locally), while cand$store is the bare prefix the API wants back + attr(out, 'filename') = shown + attr(out, 'scan') = scans + if(!is.null(matches)){ + #make.unique can rename a result when two stores share a stub, so the final names + #are copied across while the rows are still in the order the results were + #appended (one match row per result), and only then is the table sorted for display + if(nrow(matches) == length(out)){ + matches$name = names(out) + } + matches = matches[order(matches$position, matches$store), + c('name', 'position', 'store', 'extname', 'RA', 'Dec', 'box_x', + 'box_y', 'dim'), drop = FALSE] + } + #Written before res, so the gallery that re-renders on res always finds the position + #metadata that belongs to this run rather than the one it is replacing + state$pos_idx = pos_idx + state$pos_lab = pos_lab + state$res = out + state$matches = matches + note('Got ', length(out), ' cutout(s) from ', + if(is.null(matches)) 0 else length(unique(matches$store)), ' store(s).') + if(length(no_overlap) > 0){ + #Named explicitly, because "found two, showed one" is otherwise indistinguishable + #from a bug in the app rather than a property of where the position fell + note('Scanned ', length(no_overlap), ' candidate store(s) with no overlap at the ', + 'requested position(s): ', + paste(utils::head(no_overlap, 10), collapse = ', '), + if(length(no_overlap) > 10) paste0(' (+', length(no_overlap) - 10, ' more)') + else '') + } + if(length(errored) > 0){ + note('Could not scan ', length(errored), ' candidate store(s): ', + paste(utils::head(errored, 10), collapse = ', ')) + } + invisible(NULL) + } + + observeEvent(input$run, { + do_run() + }) + + #The caption of the position the i'th result answers, for the inset in its corner. The + #two vectors are read together and their lengths compared, because a gallery drawn from + #one run must not be captioned from the next one: res is cleared and rewritten by a run, + #and pos_idx with it, but not in the same instant + inset_of = function(i){ + p = isolate(state$pos_idx) + lab = isolate(state$pos_lab) + if(is.null(p) || is.null(lab) || length(p) != length(isolate(state$res))){ + return(NULL) + } + at = p[i] + if(is.na(at) || at < 1 || at > length(lab)){ + return(NULL) + } + return(lab[at]) + } + + #One plot output per result, ids made from the names of the Rfits_list. Registering + #them inside an observer means they appear and disappear with the request that made + #them, rather than leaving outputs pointed at cutouts that no longer exist + observe({ + res = state$res + req(res) + n = min(length(res), max_show()) + lapply(seq_len(n), function(i){ + local({ + ii = i + output[[paste0('cutplot_', ii)]] = renderPlot({ + draw_cutout(state$res[[ii]], display_opts(), inset = inset_of(ii)) + }) + }) + }) + }) + + output$gallery = renderUI({ + res = state$res + if(is.null(res) || length(res) == 0){ + return(em('Run a request to see the cutouts here.')) + } + n_tot = length(res) + n = min(n_tot, max_show()) + w = cut_width() + #The positions this page is grouped by, and the label of each group. A header is + #emitted ahead of the first cutout of a group only, so twenty tiles of one target read + #as one heading and twenty cells rather than twenty headings. Nothing is grouped when + #the run left no position metadata behind, which is also the case for a single position + p_idx = state$pos_idx + p_lab = state$pos_lab + grouped = !is.null(p_idx) && !is.null(p_lab) && length(p_idx) == n_tot + #Heights are read from the inputs rather than through display_opts(), which would + #rebuild every plotOutput whenever any display option changed and throw away the + #plots that were just drawn + cells = lapply(seq_len(n), function(i){ + item = res[[i]] + kv = item$keyvalues + #Only the keywords a browse actually wants to see, and only where the tile carries + #them; a release written without FILTER simply does not show it. Character and + #numeric keywords are formatted differently, so both are checked for usability + bits = c(names(res)[i], paste(dim(item$imDat), collapse = ' x ')) + for(key in c('FILTER', 'TARGET', 'EXPTIME', 'PIXSCALE')){ + val = kv[[key]] + if(is.null(val) || length(val) < 1 || all(is.na(val))){ + next + } + if(key %in% c('EXPTIME', 'PIXSCALE')){ + num = suppressWarnings(as.numeric(val)[1]) + if(!is.finite(num)){ + next + } + val = if(key == 'EXPTIME') paste0(round(num, 1), 's') + else paste0(round(num, 4), '"/pix') + }else{ + val = as.character(val)[1] + } + bits = c(bits, val) + } + cell = div( + class = 'rf-cut-cell', + div(class = 'rf-sel-row', + #The initial value is read from the selection rather than hard wired to TRUE, + #so a gallery redrawn because the stretch changed cannot quietly reset which + #cutouts are included. Isolated because the selection must not invalidate the + #gallery that reports it. A selection of the wrong length means nothing has + #been chosen yet, which is the same as everything being chosen + { + selected = isolate({ + s = state$sel + if(is.null(s) || length(s) != n_tot) TRUE else isTRUE(s[i]) + }) + #No width argument: that appeared in shiny 1.6 and the app has to start + #on whatever version the user has + checkboxInput(cell_id(i), 'include', value = selected) + }, + div(class = 'rf-name', paste(bits, collapse = ' | '))), + div(class = 'rf-meta', paste0(attr(res, 'filename')[i], + if(!is.null(kv$EXTNAME)) + paste0(' :: ', kv$EXTNAME) else '')), + #The square is fixed by the wrapper's aspect-ratio and the plot is asked to fill + #it, rather than by giving the plot a pixel height. A pixel height would make + #the drawing area as wide as the column, so a square image inside it is padded + #top and bottom, which is the letter boxed look this is meant to remove + div(class = 'rf-cut', style = paste0('max-width: ', w, 'px;'), + plotOutput(paste0('cutplot_', i), height = '100%')) + ) + + #The heading of the group this cell opens. Emitted ahead of the first cell of a + #group only, and only when the run recorded which position each cutout answers; a + #single position needs no heading because the inset on every cutout already says it. + #grid-column: 1 / -1 so the heading takes a whole row rather than one column of the + #grid, which is what keeps the cells after it starting on a fresh line + if(!grouped || length(p_lab) < 2){ + return(cell) + } + at = p_idx[i] + first = i == 1 || is.na(at) || at != p_idx[i - 1] + if(!first || is.na(at) || at > length(p_lab)){ + return(cell) + } + n_in = sum(!is.na(p_idx) & p_idx == at) + tagList( + div(class = 'rf-group-head', + strong('Position ', at, ': '), p_lab[at], + span(class = 'rf-group-n', ' (', n_in, ' cutout', + if(n_in != 1) 's', ')')), + cell) + }) + tagList( + #repeat(auto-fill, minmax(min(100%, w), 1fr)) so the column count follows the width + #of the right hand panel: on a wide screen several cutouts sit side by side, and on a + #narrow one the same page falls back to a single column with no per-breakpoint rules. + #The min(100%, ...) stops a large requested side from overflowing a small panel + div(class = 'rf-cut-grid', + style = paste0('grid-template-columns: repeat(auto-fill, minmax(min(100%, ', + w, 'px), 1fr));'), + !!!cells), + if(n < n_tot) helpText('Showing ', n, ' of ', n_tot, ' cutout(s). Raise "Max ', + 'cutouts to plot" to draw more and give them a tick box; the ', + n_tot - n, ' not drawn here are listed in the table above ', + 'and stay included unless you clear them with "Include ', + 'none" first.') + ) + }) + + output$result_counts = renderUI({ + pos = parse_positions(in_('positions')) + bad = attr(pos, 'bad') + n = if(is.null(state$res)) 0 else length(state$res) + tagList( + if(length(bad) > 0) helpText('Unread as positions: ', paste(bad, collapse = ' | ')), + if(n > 0) helpText(n, ' cutout(s) in this result, named _ when ', + 'more than one position was asked for.') + ) + }) + + output$index_note = renderUI({ + if(is.null(state$idx)){ + return(helpText('Load an index on the Store tab before searching.')) + } + NULL + }) + + #A bare data.frame reaching renderDataTable would have the ... options applied by the + #renderer, but building the datatable explicitly here means those options are the ones + #that ship with the widget, which is also where scrollX has to live for the wide index + #table to be scrollable at all. pageLength is kept small because the outputs carry a + #fixed pixel height and twenty five rows do not fit in it, which would push the last + #rows and the pager out of the box rather than giving the table more room + #escape and callback are arguments of datatable rather than of the JS options, so they + #are named separately from the ... that go to options + #selection stays a named argument because the default turns rows into something a click + #highlights, which reads like a control when the tick column is the one that counts + dt_table = function(df, pageLength = 10, escape = TRUE, callback = NULL, + selection = 'none', ...){ + if(!has_dt){ + return(head(df, 200)) + } + #callback is dropped from the call rather than passed as NULL. DT checks the argument + #against its own default and stops with "The 'callback' argument only accept a value + #returned from JS()" for anything else, NULL included, so naming it unconditionally + #errored every table that has no callback of its own. Omitting it leaves DT's default + #in place, which is what those tables want + args = list(data = df, options = list(pageLength = pageLength, scrollX = TRUE, ...), + rownames = FALSE, fillContainer = FALSE, escape = escape, + selection = selection) + if(!is.null(callback)){ + args$callback = callback + } + do.call(DT::datatable, args) + } + + #A column of real checkboxes, because this is the one view that lists every result, + #including the cutouts the gallery is not drawing, and because DT's own row selection is + #only a highlight: it shows no mark to read the current state off, and reports it under + #an input name of its own. The tick is written as HTML, which is why the column is left + #out of the escape set, and a change is sent back as an event by the table's callback + output$match_table = if(has_dt){ + DT::renderDataTable({ + mm = state$matches + req(mm) + mm = mm[mm$name %in% names(state$res), , drop = FALSE] + #Position in the result list rather than row number, because the rows get sorted, + #paged and filtered and the position does not move + idx = match(mm$name, names(state$res)) + #Isolated: the boxes follow the selection through the message handler, and reading + #it reactively here would redraw the table on every tick and throw away whatever + #the user had searched for. It is only the initial state that matters, and that is + #whatever the selection says at the moment the table is drawn + sel = isolate(sel_of(state$res, state$sel)) + mm = cbind(data.frame(tick = sprintf( + '', + idx, ifelse(sel[idx], ' checked', '')), + stringsAsFactors = FALSE), mm) + escape = setdiff(seq_len(ncol(mm)), 1L) + dt_table(mm, pageLength = 10, escape = escape, + columnDefs = list(list(targets = 0, orderable = FALSE, + searchable = FALSE, width = '2.6rem')), + callback = htmlwidgets::JS(table_tick_callback)) + }, server = FALSE) + }else{ + renderTable({ + mm = state$matches + req(mm) + dt_table(mm) + }) + } + + index_shown = reactive({ + rows = state$rows + req(rows) + out = index_view_columns(rows) + #The filter is a glob, like the store name pattern on the Store tab (see glob_regex), + #so *.zarr and tile* mean what they look like rather than being handed to grepl as a + #regular expression + if(nzchar(in_('idx_filter'))){ + out = out[grepl(glob_regex(in_('idx_filter')), out$label), , drop = FALSE] + } + status = in_('idx_status', 'all') + if(status != 'all'){ + out = out[out$status == status, , drop = FALSE] + } + out + }) +#The full column set is wide enough that nothing works without a horizontal scroll, and + #the reason it did not appear was that scrollX alone leaves DataTables sizing the + #wrapper to the table; the CSS on .dataTables_wrapper in the header forces the scroll + #onto the container the card actually gives it + output$index_table = if(has_dt){ + DT::renderDataTable(dt_table(index_shown()), server = FALSE) + }else{ + renderTable(head(index_shown(), 200)) + } + + output$idx_info = renderText({ + rows = state$rows + req(rows) + if(nrow(rows) == 0){ + return('index rows: 0 -- the store name pattern excluded every row.') + } + paste0('index rows: ', nrow(rows), '\n', + 'stores: ', length(unique(rows$label)), '\n', + 'extnames: ', paste(sort(unique(rows$extname)), collapse = ', '), '\n', + 'statuses: ', paste(names(table(rows$status)), table(rows$status), + sep = ' = ', collapse = ', '), '\n', + 'RA span: ', paste(round(range(rows$ra, na.rm = TRUE), 4), + collapse = ' to '), '\n', + 'Dec span: ', paste(round(range(rows$dec, na.rm = TRUE), 4), + collapse = ' to '), '\n', + 'pixscale ("): ', paste(round(range(rows$pixscale_x, na.rm = TRUE), 4), + collapse = ' to ')) + }) + + #Re-reading the file rather than reusing the rows in memory: the point of the button is + #to pick up an index that changed underneath us, which the cached copy cannot show + observeEvent(input$idx_refresh, { + req(state$con) + got = with_capture(load_index(state$con, rebuild = flag_('rebuild'), note = note)) + for(m in got$msgs) note(m) + val = got$value + if(is.null(val) || !is.null(val$error)){ + note('ERROR: reload failed: ', if(is.null(val)) 'no result' else val$error) + return(NULL) + } + adopt_index(val) + }) + + #The id plotly hands back on a click or a box drag. Numbers rather than the store name + #or the index cache key, because every vertex of every footprint carries one and a ring + #is six vertices: on a release of three thousand tiles a 120 character path would put + #more than two megabytes of label into the page before any of it was read, and the + #browser would pay that on every redraw. Numbering the rows of the unfiltered set is + #what makes a number stable while the index is loaded, because filtering only takes rows + #away and never renumbers the rest. Only the box and lasso tools resolve to a number; + #clicked picks are held as coordinates, so they mean the same thing across a reload + frame_rows = reactive({ + rows = state$rows + #No index yet is an ordinary state of this tab rather than an error to interrupt on, so + #that the panel can say so in words. The callers that genuinely need frames req() on + #the NULL + if(is.null(rows)){ + return(NULL) + } + fr = index_footprints(rows[rows$status == 'ok', , drop = FALSE]) + fr$frame_id = seq_len(nrow(fr)) + return(fr) + }) + + #The frames this tab is showing: every searchable footprint the Index tab's filters + #leave. One function rather than the filtering in four places, so the plot, the table, + #the count and the two Send buttons can never disagree about what is on screen. Empty is + #returned as a zero row data frame rather than as a req() failure, because a renderer that + #can see 'nothing' says so and one that only gets an interrupting condition leaves a + #blank box where the answer should be + frames_subset = function(){ + fr = frame_rows() + if(is.null(fr)){ + return(NULL) + } + #The same glob as the Index tab's table, so the two views cannot disagree about + #what is on screen + if(nzchar(in_('idx_filter'))){ + fr = fr[grepl(glob_regex(in_('idx_filter')), fr$label), , drop = FALSE] + } + status = in_('idx_status', 'all') + if(status != 'all'){ + fr = fr[fr$status == status, , drop = FALSE] + } + return(fr) + } + + frames_view = reactive({ + fr = frames_subset() + req(!is.null(fr), nrow(fr) > 0) + return(fr) + }) + + #What a hover shows. The store the tile came from is the thing a user wants at this + #moment -- it is what a result is named after on the Cutouts tab -- and the shape and + #scale say whether this is the tile they meant. Kept to the columns the index always + #has, since a release written without a field would otherwise print NA beside every tile + frame_hover = function(fr){ + bits = paste0('', fr$name, '', + if('extname' %in% names(fr)) paste0('
extname: ', fr$extname) else '', + if('type' %in% names(fr)) paste0('
type: ', fr$type) else '', + '
RA, Dec: ', signif(fr$ra, 8), ', ', signif(fr$dec, 8)) + if(all(c('naxis1', 'naxis2') %in% names(fr))){ + bits = paste0(bits, '
shape: ', fr$naxis1, ' x ', fr$naxis2) + } + if('pixscale_x' %in% names(fr)){ + bits = paste0(bits, '
pixscale: ', signif(fr$pixscale_x, 4), '"/pix') + } + if('label' %in% names(fr)){ + bits = paste0(bits, '
', fr$label) + } + return(bits) + } + + #The payload of one of the Frames plot's plotly events, parsed the way + #plotly::event_data() parses it. Reading the widget's own input id rather than calling + #event_data() is deliberate: event_data() registers an onFlushed callback that warns + #whenever the event has not been registered by a plot that has already rendered, and this + #panel sits in a tab that Shiny keeps suspended until the user opens it. At startup, and + #under testServer, which never renders an output unless asked, nothing has rendered, so + #the observer below would emit a warning no user can either see or act on. The widget + #posts 'plotly_-', with the source set on the plot itself, and the value + #is the JSON text of an array of points. jsonlite is not in the checks at the top of the + #file because plotly imports it, so a session that can draw the plot can parse this + plotly_event = function(event){ + txt = input[[paste0('plotly_', event, '-frames')]] + if(is.null(txt) || !is.character(txt) || !nzchar(txt)){ + return(NULL) + } + val = tryCatch(jsonlite::parse_json(txt, simplifyVector = TRUE), error = function(e) NULL) + return(val) + } + + #plotly sends each event as JSON text, which arrives as a data frame with one row per + #point and the columns the widget attaches (curveNumber, pointNumber, x, y, customdata). + #Everything here resolves back through customdata rather than pointNumber: that would + #work for the centre markers, but the footprints are drawn as one NaN separated polyline, + #so their point numbers index into a list of vertices, not into frames. A vertex with no + #id (the separators) is dropped rather than guessed at + event_ids = function(ev){ + if(is.null(ev) || NROW(ev) == 0 || is.null(ev$customdata)){ + return(character(0)) + } + id = suppressWarnings(as.character(unlist(ev$customdata, use.names = FALSE))) + return(id[!is.na(id) & nzchar(id)]) + } + + #Positions the user clicked, as free RA/Dec rather than as frame ids. A click means "I + #want a cutout here", and here is wherever the cursor was, not the centre of the nearest + #tile; the rectangle and lasso tools are the way to ask for whole tiles. Held as a small + #data frame so the list survives redraws and index reloads, since a coordinate is a + #coordinate whatever the index says + picks = reactiveVal(data.frame(ra = numeric(0), dec = numeric(0))) + + #The frames a box or lasso drag caught, in the order they appear in the view rather than + #the order plotly reported them. plotly selects points, and both traces carry one point + #per frame, so the ids arrive twice over; unique() through the %in% below already folds + #that back to one row per frame + selected_frames = function(fr = frames_subset()){ + id = event_ids(plotly_event('selected')) + if(length(id) == 0 || is.null(fr)){ + return(NULL) + } + out = fr[fr$frame_id %in% id, , drop = FALSE] + if(nrow(out) == 0){ + return(NULL) + } + return(out) + } + + #The rectangle a selection was made inside, which is the one thing plotly's selected + #event does not report as a range: plotly_selected carries points, and only the lasso + #tool's brushing event carries a point cloud of its own. So the extremes of the selected + #points are used, which is the box the user drew for every purpose this serves -- a + #single frame selected reports the bounds of that frame + selected_box = function(fr = frames_subset()){ + sel = selected_frames(fr) + if(is.null(sel)){ + return(NULL) + } + list(x = range(c(sel$xmin, sel$xmax), na.rm = TRUE), + y = range(c(sel$ymin, sel$ymax), na.rm = TRUE)) + } + + #The centres of a set of frames as the Cutouts tab reads them. The tile's reference + #position is the coordinate, not the middle of the box that drew it, which is the whole + #reason the frames are clickable rather than just brushable + pos_lines = function(fr){ + return(paste(signif(fr$ra, 9), signif(fr$dec, 9))) + } + + #What a send put in the log: which frames went in, and the coordinates themselves. A + #pick is otherwise invisible once it leaves the tab, and the log is the only record of + #what reached the position list. Only the frames whose lines were really added are + #named, so a send that found them already in the list cannot claim credit for them + log_send = function(kind, fr, new){ + fr = fr[pos_lines(fr) %in% new, , drop = FALSE] + if(nrow(fr) == 0){ + return(invisible(NULL)) + } + note('Sent ', nrow(fr), ' ', kind, ' frame centre(s) to the Cutouts tab: ', + paste(utils::head(fr$name, 8), collapse = ', '), + if(nrow(fr) > 8) paste0(' (+', nrow(fr) - 8, ' more)') else '', '. Positions: ', + paste(utils::head(new, 4), collapse = '; '), + if(length(new) > 4) paste0(' (+', length(new) - 4, ' more)') else '') + invisible(NULL) + } + + #Append to the position list rather than replacing it, and skip lines that are already + #there, so picking a tile twice cannot fill the request with duplicates. Returns the + #lines actually added, or NULL when there was nothing new to add + add_positions = function(lines){ + cur = trimws(unlist(strsplit(as.character(isolate(input$positions)), '[\r\n]+'))) + cur = cur[nzchar(cur)] + new = unique(lines) + new = new[!(new %in% cur)] + if(length(new) == 0){ + return(NULL) + } + updateTextAreaInput(session, 'positions', value = paste(c(cur, new), collapse = '\n')) + return(new) + } + + #A click anywhere in the panel is a position, in any number and at any zoom. The + #coordinate is worked out in the browser (see the onRender handler below) because plotly's + #own click event reports the coordinates of the point that was hit, which would snap every + #pick to the nearest tile centre or marker. Picks are held as coordinates rather than + #resolved to frames for the same reason: where you clicked is the answer, not which tile + #happens to own that spot + observeEvent(input$frames_click, { + pt = input$frames_click + ra = suppressWarnings(as.numeric(pt$ra)[1]) + dec = suppressWarnings(as.numeric(pt$dec)[1]) + if(!is.finite(ra) || !is.finite(dec)){ + return(NULL) + } + old = picks() + both = rbind(old, data.frame(ra = ra, dec = dec)) + #The same pixel clicked twice must not fill the list with duplicates + picks(both[!duplicated(paste(both$ra, both$dec)), , drop = FALSE]) + return(NULL) + }) + + #The cursor's position in degrees, which is what a pick must be. This is done in the + #browser off a plain listener on the plot surface rather than from plotly's click event + #for two reasons. plotly only emits plotly_click when the pointer lands on a mark, so a + #click on empty sky between tiles - the common case, and exactly the case where you want + #to choose a position - would report nothing. And that event carries the coordinates of + #the mark that was hit rather than of the cursor, which would snap every pick to the + #nearest tile centre. So the mouse position is read against the drag layer, which is + #positioned at the origin of the plot area and therefore already in the pixel space the + #axes measure from, and turned into degrees with the axis' own p2d. d3 is taken from the + #plotly bundle rather than assumed to be global. p2d is an internal, so the same linear + #map is worked out from the range and length when it is not there. If neither can be read + #the click is dropped rather than answered with a mark's coordinates, because the click + #may well have been on empty sky where there is no mark to report + frames_click_js = paste( + 'function(el, x){', + ' var gd = el;', + ' var d3 = (window.Plotly && window.Plotly.d3) || window.d3;', + ' function to_deg(ev){', + ' var dl = gd.querySelector(".nsewdrag");', + ' var fl = gd._fullLayout;', + ' if(!dl || !fl || !fl.xaxis || !fl.yaxis) return null;', + ' var pts = null;', + ' if(d3 && d3.mouse){ try{ pts = d3.mouse(dl); }catch(e){ pts = null; } }', + ' if(!pts){', + ' var bb = dl.getBoundingClientRect();', + ' pts = [ev.clientX - bb.left, ev.clientY - bb.top];', + ' }', + ' function inv(ax, p){', + ' if(ax.p2d) return ax.p2d(p);', + ' if(!ax._length || !ax.range) return null;', + ' return ax.range[0] + (p / ax._length) * (ax.range[1] - ax.range[0]);', + ' }', + ' var ra = inv(fl.xaxis, pts[0]), dec = inv(fl.yaxis, pts[1]);', + ' if(ra === null || dec === null) return null;', + ' if(!isFinite(ra) || !isFinite(dec)) return null;', + ' return {ra: ra, dec: dec};', + ' }', + #Three things have to be filtered out before a press and release counts as a pick. A + #drag that ends on the surface fires a click too, so a box select or a rubber band zoom + #would add a position nobody meant to pick. The mode bar and the legend live inside the + #graph div, so their buttons arrive here as well and would be converted from a pixel + #somewhere over the toolbar. And double click is bound to reset the view, which would + #otherwise register two picks on the way to doing that + ' var down = null, timer = null;', + ' function in_chrome(node){', + ' while(node && node !== gd){', + ' if(node.classList && (node.classList.contains("modebar") ||', + ' node.classList.contains("legend") ||', + ' node.classList.contains("select-outline"))) return true;', + ' node = node.parentNode;', + ' }', + ' return false;', + ' }', + ' gd.addEventListener("mousedown", function(ev){', + ' down = {x: ev.clientX, y: ev.clientY, t: Date.now()};', + ' });', + ' gd.addEventListener("click", function(ev){', + ' if(!down || in_chrome(ev.target)){ down = null; return; }', + ' var moved = Math.abs(ev.clientX - down.x) + Math.abs(ev.clientY - down.y);', + #down.t is when the press happened, so this is how long the button was held. ev.timeStamp + #would answer a different question entirely, which is when the click fired + ' var quick = (Date.now() - down.t) < 700;', + ' down = null;', + ' if(moved > 4 || !quick){ return; }', + ' var at = to_deg(ev);', + ' if(!at){ return; }', + #Held briefly so a second click, which is a reset rather than a pick, can cancel it + ' if(timer) clearTimeout(timer);', + ' timer = setTimeout(function(){', + ' timer = null;', + ' Shiny.setInputValue("frames_click", {ra: at.ra, dec: at.dec,', + ' t: Date.now()}, {priority: "event"});', + ' }, 260);', + ' });', + ' gd.addEventListener("dblclick", function(){', + ' if(timer){ clearTimeout(timer); timer = null; }', + ' down = null;', + ' });', + '}') + + #Clearing the clicked list is a deliberate action. A legend toggle, or a stray click on + #empty space, is not, and neither should throw away a list the user built + observeEvent(input$clear_picks, { + picks(data.frame(ra = numeric(0), dec = numeric(0))) + showNotification('Picked positions cleared.', type = 'message') + }) + + output$frames = plotly::renderPlotly({ + fr = frames_view() + #Read with isolate, so that the trace carries the picks made so far without a pick + #invalidating this renderer. A re-render reconciles a whole new specification against + #the panel on screen, and that is how the zoom gets thrown away even with uirevision + #set; a pick reaches the browser through the proxy below instead + pk = isolate(picks()) + #One NaN separated polyline carrying every footprint, rather than one trace per tile. + #A release of a few thousand tiles would otherwise build a few thousand plotly traces, + #and the browser feels that as a stall long before it feels it as a map + idv = fr$frame_id + hv = frame_hover(fr) + #Each ring is five vertices plus a separator, and every vertex of a ring carries that + #ring's id so a box or lasso drag that catches an edge resolves to the right frame. + #The separator has to be NA_character_ rather than NA_real_: cbind() with a character + #column coerces the whole row to character, so a numeric NA would arrive as the string + #'NA' and read back as the id of a frame called NA + ring = function(v) as.vector(t(cbind(v, v, v, v, v, NA_character_))) + xs = as.vector(t(cbind(fr$xmin, fr$xmax, fr$xmax, fr$xmin, fr$xmin, NA_real_))) + ys = as.vector(t(cbind(fr$ymin, fr$ymin, fr$ymax, fr$ymax, fr$ymin, NA_real_))) + p = plotly::plot_ly(source = 'frames') |> + plotly::add_trace(x = xs, y = ys, customdata = ring(idv), + text = ring(hv), type = 'scatter', mode = 'lines', + name = 'frames', showlegend = FALSE, + hovertemplate = '%{text}', + line = list(color = '#4c78a8', width = 0.8), opacity = 0.65) |> + plotly::add_trace(x = fr$ra, y = fr$dec, customdata = as.character(idv), + text = hv, type = 'scatter', mode = 'markers', + name = 'frame centres', showlegend = TRUE, + hovertemplate = '%{text}', + marker = list(color = '#4c78a8', size = 3.5, opacity = 0.85)) |> + #The picks live in a third trace that is always there, drawn from the list read with + #isolate() above so that a pick does not invalidate this renderer. Both halves matter: + #a re-render reconciles a whole new specification against the panel on screen, which is + #how the zoom gets thrown away even with uirevision set, and a trace appearing or + #disappearing changes how many axes have to be worked out again. So the trace count is + #fixed and a pick reaches the browser through the proxy below. With nothing picked the + #arrays are empty, which plotly renders as a trace with no data at all + plotly::add_trace(x = pk$ra, y = pk$dec, type = 'scatter', mode = 'markers', + name = 'picked', showlegend = TRUE, + hovertemplate = 'clicked
RA, Dec: %{x}, %{y}', + marker = list(color = '#e45756', size = 9, symbol = 'cross', + line = list(width = 2))) + xr = range(c(fr$xmin, fr$xmax), na.rm = TRUE) + yr = range(c(fr$ymin, fr$ymax), na.rm = TRUE) + #A little air at the edges so a tile on the boundary is not drawn under an axis + ax = diff(xr) * 0.03 + 1e-6 + ay = diff(yr) * 0.03 + 1e-6 + p = plotly::layout(p, + #The RA axis is reversed the way a sky map is read, and passing the + #range with the larger bound first is what does it here. That is + #also the order plotly reports a range back in, so nothing + #downstream has to care which way the drag went + xaxis = list(title = 'RA (deg)', range = c(xr[2] + ax, xr[1] - ax), + zeroline = FALSE, ticks = 'outside', + #Equal degrees per pixel on both axes, so a square tile + #draws square. Without the anchor the two axes scale + #independently to the panel, and a long thin release + #comes out as a row of tall rectangles + scaleanchor = 'y', scaleratio = 1, + constrain = 'domain'), + yaxis = list(title = 'Dec (deg)', + range = c(yr[1] - ay, yr[2] + ay), + zeroline = FALSE, ticks = 'outside', + constrain = 'domain'), + dragmode = 'zoom', hovermode = 'closest', + selectdirection = 'any', + #A click fires an event but does not become a one-point selection. + #The drag tools are the way to catch whole tiles, and a click that + #quietly replaced the box selection would have the two routes fight + #over the same state + clickmode = 'event', + title = list(text = paste(nrow(fr), 'searchable frame(s)'), + font = list(size = 13)), + legend = list(orientation = 'h', x = 0, y = 1.04, + font = list(size = 10)), + margin = list(l = 58, r = 14, t = 46, b = 42), + #A zoom is a state the user set, so a redraw must not throw it + #away. The revision is keyed to the filters rather than fixed: + #narrowing the view is the one moment an old zoom genuinely is the + #wrong window, and holding it would leave an empty panel + uirevision = paste(in_('idx_filter'), '|', + in_('idx_status', 'all'))) + p = plotly::config(p, displaylogo = FALSE, scrollZoom = TRUE, doubleClick = 'reset', + modeBarButtonsToRemove = c('toImage', 'sendDataToCloud', + 'toggleSpikelines', + 'hoverCompareCartesian', + 'hoverClosestCartesian')) + p = htmlwidgets::onRender(p, frames_click_js) + return(p) + }) + + #The picked positions, drawn in the browser by restyling that third trace. Re-rendering + #the panel to add a marker is what used to throw the zoom away, since a fresh + #specification is reconciled against the panel on screen even with uirevision set, while + #restyling one trace touches nothing the user is looking at. ignoreInit matters: a proxy + #call is a message to the page, and the browser throws when the graph div it names is not + #there yet, so nothing is sent until a pick has actually been made. Every pick is made by + #clicking the rendered panel and every clear is a button in the card beside it, so when + #this runs the panel exists + observeEvent(picks(), { + pk = picks() + plotly::plotlyProxyInvoke(plotly::plotlyProxy('frames'), 'restyle', + pick_restyle_args(pk$ra, pk$dec), 2) + }, ignoreInit = TRUE) + + output$frames_info = renderText({ + #Read through frames_subset rather than frames_view, so that a session with no index + #yet is told so in words rather than leaving a blank box where the answer should be + fr = frames_subset() + if(is.null(fr) || nrow(fr) == 0){ + return(paste0('No frames to show. Load an index on the Store tab first, or widen ', + 'the store name pattern and the Index tab filters.')) + } + sel = selected_frames() + box = selected_box() + pk = picks() + npick = nrow(pk) + bits = paste0('Picked by click: ', npick, + if(npick > 0) + paste0(' (', paste(utils::head(signif(pk$ra, 6), 3), collapse = ', '), + if(npick > 3) ' ...' else '', ')') else '', + '\nSelected by box: ', if(is.null(sel)) 0 else nrow(sel)) + if(!is.null(box)){ + bits = paste0(bits, '\nSelection box: ', paste(round(box$x, 4), collapse = ' to '), + ' RA, ', paste(round(box$y, 4), collapse = ' to '), ' Dec') + } + if(!is.null(sel) && nrow(sel) > 0){ + bits = paste0(bits, '\nSelected: ', paste(utils::head(sel$name, 8), + collapse = ', '), + if(nrow(sel) > 8) paste0(' (+', nrow(sel) - 8, ' more)') else '') + } + bits = paste0(bits, '\nFrames in view: ', nrow(fr)) + return(bits) + }) + + #What the table shows. A box selection is listed when there is one, since those rows are + #the tiles whose centres are about to be sent. Clicked picks are not in it, because a pick + #is a coordinate rather than a tile; with neither, the frames in view are listed so the + #tab has something to read before anything is chosen + frames_shown = reactive({ + fr = frames_subset() + req(!is.null(fr), nrow(fr) > 0) + sel = selected_frames(fr) + return(if(is.null(sel)) fr else sel) + }) + + output$frames_table = if(has_dt){ + DT::renderDataTable({ + sel = frames_shown() + req(nrow(sel) > 0) + cols = c('name', 'extname', 'type', 'ra', 'dec', 'naxis1', 'naxis2', 'pixscale_x') + dt_table(as.data.frame(sel)[, cols, drop = FALSE], pageLength = 10) + }, server = FALSE) + }else{ + renderTable({ + sel = frames_shown() + req(sel) + head(as.data.frame(sel)[, c('name', 'extname', 'type', 'ra', 'dec')], 50) + }) + } + + #The positions the user clicked, sent as typed. This is the main route from this tab to a + #request, and the coordinate is exactly where the cursor was: to cut at tile centres, + #select the tiles with the box or lasso tool and use Send selected frames + observeEvent(input$send_pos, { + pk = picks() + if(nrow(pk) == 0){ + showNotification('Click a position on the map first, at any zoom.', type = 'warning') + return(NULL) + } + line = paste(signif(pk$ra, 9), signif(pk$dec, 9)) + new = add_positions(line) + if(is.null(new)){ + showNotification('Those positions are already in the list.', type = 'message') + return(NULL) + } + note('Sent ', length(new), ' clicked position(s) to the Cutouts tab: ', + paste(utils::head(new, 4), collapse = '; '), + if(length(new) > 4) paste0(' (+', length(new) - 4, ' more)') else '') + bslib::nav_select('nav', 'cutouts') + }) + + #The box selection route, kept because a box is the fast way to take in a neighbourhood. + #What is sent is still the centres of the frames the box caught, not the centre of the + #box, which is the answer the old brush gave and the reason it was not very useful + observeEvent(input$send_sel, { + sel = selected_frames() + if(is.null(sel)){ + showNotification('Drag a selection box over the frames first.', type = 'warning') + return(NULL) + } + new = add_positions(pos_lines(sel)) + if(is.null(new)){ + showNotification('Those positions are already in the list.', type = 'message') + return(NULL) + } + box = selected_box() + note('Selection box: ', paste(round(box$x, 4), collapse = ' to '), ' RA, ', + paste(round(box$y, 4), collapse = ' to '), ' Dec.') + log_send('selected', sel, new) + bslib::nav_select('nav', 'cutouts') + }) +} + +shinyApp(ui = ui, server = server) diff --git a/man/Rfits_cutout_app.Rd b/man/Rfits_cutout_app.Rd new file mode 100644 index 0000000..39e52e6 --- /dev/null +++ b/man/Rfits_cutout_app.Rd @@ -0,0 +1,196 @@ +\name{Rfits_cutout_app} +\alias{Rfits_cutout_app} +\title{ +A Shiny App for Browsing and Cutting Out a Directory of Zarr Stores +} +\description{ +Launches the Shiny application bundled with the package, which gives a graphical +front end to \code{\link{Rfits_cutout_zarr_dir}} and \code{\link{Rfits_zarr_index}}. A +directory of Zarr stores, or an S3 prefix holding one, is described once; the app then +takes RA/Dec positions, shows the cutout of every overlapping store, and offers any chosen +subset of the result as a zip of FITS files or a zip of JPEGs, written raw or tile +compressed. + +The application is a single file, installed under \file{inst/shiny/Rfits_cutout_app}, and +can equally be run directly with \code{shiny::runApp(system.file('shiny', +'Rfits_cutout_app', package = 'Rfits'))}. This wrapper exists so that the dependency +checks happen in R, where they can name the missing package. +} +\usage{ +Rfits_cutout_app(launch.browser = getOption('shiny.launch.browser', interactive()), + display.mode = c('normal', 'static'), port = NULL, ...) +} +\arguments{ + \item{launch.browser}{ +Logical, or a function taking a URL; passed straight to \code{shiny::runApp}. The default +follows the usual Shiny option, so the app opens a browser when the session is +interactive. +} + \item{display.mode}{ +Character scalar, one of \code{'normal'} or \code{'static'}, passed to +\code{shiny::runApp}. +} + \item{port}{ +Integer port to serve on, or \code{NULL} to let Shiny choose. +} + \item{...}{ +Further arguments passed to \code{shiny::runApp}, such as \code{host} or +\code{quiet}. +} +} +\details{ +The app has four tabs. + +\strong{Store} collects the credentials and location. Give either a bucket with an access +key and secret, or a local directory of \code{*.zarr} stores, and press Load index. The +index is read from \code{s3:///index.parquet} by default, which can be retyped as +a path to look beside the tiles instead. When no index is found, one is built from the +tiles with \code{\link{Rfits_zarr_index}} and kept in the session's own temporary file; +nothing is ever written back to the store, because a shared release is not the place for +a private cache. Whoever publishes the tiles should decide whether an index ships with +them. This is also why the search is issued per store rather than with the \code{cache} +argument of \code{\link{Rfits_cutout_zarr_dir}}, which would write what it learns back to +the bucket. Credentials fall back to the environment variables +\env{RFITS_S3_REGION}, \env{RFITS_S3_ENDPOINT}, \env{RFITS_S3_ACCESS_KEY}, +\env{RFITS_S3_SECRET_KEY} and \env{RFITS_S3_SESSION_TOKEN} when the fields are left +blank, as they do for \code{\link{Rfits_cutout_zarr_dir}}. + +\strong{Store name patterns are globs}, not regular expressions, because the field takes a +name or a path rather than a pattern: \code{*} matches any run of characters and \code{?} +any single one, so \code{*.zarr} and \code{tile*} mean what they look like. The conversion +is \code{\link[utils]{glob2rx}}, with its anchors removed, so a pattern is matched against +the whole store path rather than the whole string, and \code{tile2} finds +\file{releases/dr1/tile2.zarr}. Patterns are comma or newline separated, and all of them +must match. The store name filters on the Cutouts and Index tabs and the keyword value +field take the same globs, so the same text means the same thing in each. + +A store name pattern is a filter on the session rather than only on a request, so it also +narrows what the \strong{Index}, \strong{Frames} and Store summary tabs list: a published +index describes a whole release, and a session filtered to one band has no business being +shown every band's tiles while the search quietly refuses to cut them. The pattern is +matched against the whole store path, so \code{*g*.zarr} is the way to keep the g-band +tiles of a release whose other bands share the naming. Narrowing the view this way does not +rewrite the index: the file is read whole, and \code{refresh = TRUE} rebuilds it whole. + +\strong{Cutouts} takes positions one per line, as \code{RA Dec} in degrees (separated by a +space or a comma, and either is accepted from a pasted list), and a box in pixels or +arcsec. Each position is narrowed to the stores that could overlap it by +\code{\link{Rfits_zarr_index_query}}, and only those stores are opened, so the number of +pixel reads a request makes is bounded by the number of tiles that matter rather than by +the size of the release. Stores may be narrowed further by a glob on the store name (see +the Store tab), and by a header keyword and value; the keyword is read out of the index, so +filtering by band or target costs a decode rather than a pixel read. Some common filters +are index columns rather than header keywords \emph{(EXTNAME, STATUS, TYPE, LABEL, +STORE)} and are recognised as such. The request, display and download controls are stacked +down the left of the tab and the answers fill the wider panel on the right, where each +cutout is drawn as a square of the chosen side rather than across the full width of the +page. Only \code{Max cutouts to plot} of them are drawn, since a request that overlaps a +thousand tiles would otherwise bind a thousand plots; all of them are still listed, +selectable and downloadable. +Each cutout is plotted with the WCS aware \code{\link{plot}} method, with \code{qdiff} and +the \code{magimage} clipping controls exposed. The display options are live: changing a +stretch redraws the plots from the pixels already in memory rather than re-cutting them. +A store that was opened cleanly but holds no overlap at the position asked for is named in +the run log, since that is otherwise indistinguishable from a lost result. + +\strong{Index} shows the rows of the index the search reads, one per store per extension, +with the reference position, shape and pixel scale each overlap test works from, plus the +reason any store was found not searchable. The table is wide and scrolls horizontally +inside its own card. A store name pattern set on the Store tab has already been applied, so +what is listed is what a request can reach; the tab's own filter narrows it further. + +\strong{Frames} plots the footprint of every store in the index, from the same numbers and +without reading a pixel, as an interactive plotly panel: scroll to zoom (or use the zoom +tool in the mode bar), double click to reset, and the RA axis is reversed the way a sky map +is read. Hovering a footprint or its centre gives the store name, extension, type, +reference position, shape and pixel scale. \emph{Clicking anywhere} in the panel adds that +exact RA/Dec to the list of clicked positions, as often as you like and at any zoom, and +\strong{Send clicked positions} appends them to the position list on the Cutouts tab and +switches to it. A click leaves the view exactly where it is: the markers are drawn by +restyling one trace through \code{plotlyProxy} rather than by redrawing the panel, since a +redraw reconciles a new specification against the plot on screen and is what would reset +the zoom. To take whole tiles rather than a position, use the Select box or lasso tool in +the mode bar, which highlights the frames caught and lists them in the table beside the +plot; \strong{Send selected frames} then appends the centre of every frame in that +selection, never the centre of the box itself, which generally falls between tiles. The +boxes are axis aligned and ignore rotation, which is the same approximation the search's +own coarse filter makes. Filters set on the Index tab apply here too. + +FITS files are written from the extracted pixels and header with +\code{\link{Rfits_write_image}}, so each one keeps the WCS of the tile it came from. The +JPEGs are re-rendered square, at the side given for the on screen panels, with the current +display options, since the on screen plots are drawn into the browser's device and there +is nothing on the server to copy. + +\strong{Which cutouts are downloaded.} Everything in a result is included by default, and +a new request starts from everything included again. Three controls change that, and all +three read and write one selection, so they cannot disagree: \emph{Include all}, +\emph{Include none} and \emph{Invert} above the results table, a tick beside the name of +each plotted cutout, and a column of checkboxes in the results table itself. That table is +the one view which lists every result, including the cutouts the gallery is not drawing, so +its ticks are the only way to narrow a set larger than \code{Max cutouts to plot}. The tick +is the table's first column, and each box carries the position of its cutout in the result +list rather than its row number, so the table can be sorted, searched and paged without a +tick ever landing on the wrong picture. Clicking one reports only that row, which +is what lets the table keep its own search, sort and page while the selection changes +underneath it. That column needs the DT package installed; without it the table is drawn +plainly and the other two controls are what remains. The count beside the buttons says +how many of how many are included, and the download buttons act on that set and nothing +else. + +\strong{Download formats.} The Download card chooses how the two bundles are written, and +nothing is re-cut to do it: the pixels are the ones already in memory. FITS files are +written raw by default, which is the extracted data as it stands, and the shape keywords +are taken from those pixels rather than from the header that came with them. A store +written with tile compression records its shape in \code{ZNAXIS} and sets \code{ZIMAGE}, +and \code{Rfits_write_image} honours that flag, so those keys are removed from a raw +download; a plain image that declared itself compressed would otherwise tell a reader to +expect a binary table it does not hold. + +The alternative is tile compressed, which writes through cfitsio by way of the +\code{compress} argument of \code{\link{Rfits_write_image}}, and offers the algorithm +(\code{RICE}, \code{GZIP}, \code{HCOMPRESS} or \code{PLIO}), the compression tile size, and +a quantization level. These controls appear only while compressing, because cfitsio reads +the options after \code{[compress} only when it is asked to compress, and a control that +is quietly ignored is worse than one that is absent. The quantization level is the one +setting that decides whether the download is lossless, and blank is not the same as zero: +cfitsio quantizes by default, at about four bins per pixel of noise, so a plain \code{RICE} +file does not give the pixels back exactly. Zero is lossless, and \code{GZIP} at zero +returns them to single precision; a negative value gives an absolute bin size in data units +rather than one scaled by the noise. A compressed file is a binary table, so it reads back +from extension 2, and its zip is named with \code{-compressed} so the two kinds are +distinguishable in a downloads folder. + +JPEG quality is passed to \code{\link[grDevices]{jpeg}}, so it affects the downloaded files +and not the plots on screen. It is written with the cairo device where one is available, +because that is the implementation which obeys the setting; where it is not, the quality is +left to the platform default and the run log says so rather than the page implying the +control did something. +} +\value{ +Called for its side effect of serving the application. The value of +\code{shiny::runApp} is returned, which is \code{NULL} unless the app is run +asynchronously. +} +\references{ +\code{\link{Rfits_cutout_zarr_dir}}, \code{\link{Rfits_zarr_index}}, +\code{\link{Rfits_dir_to_zarr}}. +} +\seealso{ +\code{\link{Rfits_image_zarr}} for the Zarr readers and writers, and +\code{\link{Rfits_s3_store_new}} for creating a store over S3. +} +\examples{ +\dontrun{ +#A local directory of stores, with no index yet +Rfits_cutout_app() + +#Or an S3 prefix, with credentials in the environment +Sys.setenv(RFITS_S3_ACCESS_KEY='...', RFITS_S3_SECRET_KEY='...') +Rfits_cutout_app(port=8123) + +#The same app, run without the wrapper +shiny::runApp(system.file('shiny', 'Rfits_cutout_app', package = 'Rfits')) +} +} +\keyword{utilities} diff --git a/man/Rfits_cutout_zarr_dir.Rd b/man/Rfits_cutout_zarr_dir.Rd index e5b2a0a..6fed3e6 100644 --- a/man/Rfits_cutout_zarr_dir.Rd +++ b/man/Rfits_cutout_zarr_dir.Rd @@ -117,10 +117,12 @@ alone unless stores that clearly overlap are being missed, in which case raising makes that stage less strict at the cost of more work in the second. } \item{cache}{ -Character scalar; a path to an \code{.rds} file holding the header information of the -stores, and (for a remote search) the list of stores found under the prefix, so that a -directory searched repeatedly is not read over the network each time. Local stores are -checked against their metadata files and so cannot go stale quietly; remote ones are +Character scalar; a path to a \code{Rfits_zarr_index} parquet file holding the header +information of the stores, and (for a remote search) the list of stores found under the +prefix, so that a directory searched repeatedly is not read over the network each time. +The \code{.parquet} extension may be left off, and a path ending in \code{.rds} keeps +its stem, which is where an older cache left the index. Local stores are checked +against their metadata files and so cannot go stale quietly; remote ones are trusted, which is what \option{refresh} is for. } \item{refresh}{ @@ -178,10 +180,11 @@ for it a second time. \subsection{Caching}{ A \option{cache} file makes a repeated search over the network cost about the same as -reading a local directory. It holds two kinds of entry: the search metadata of every -store, which is what removes a small read per store, and the list of stores found -under a remote prefix, which is what removes the walk that finds them. Both are -written in one \code{.rds} file. +reading a local directory. It is a \code{\link{Rfits_zarr_index}}, and holds two kinds +of entry: the search metadata of every store, which is what removes a small read per +store, and the list of stores found under a remote prefix, which is what removes the +walk that finds them. Both are held in one parquet file, which may be built ahead of +the search and published beside the tiles it describes. Remote entries cannot be checked for staleness without making the request they exist to avoid, so they are trusted, and \option{refresh} = \code{TRUE} is how a bucket @@ -191,7 +194,7 @@ size and modification time of each store's metadata document, which costs a when the walk that produced it reached the end of the directory; one that stopped at \option{max_dirs} holds a partial answer and is not kept. -An entry written by an earlier version of the package, which recorded only the two +A row written by an earlier version of the package, which recorded only the two celestial axes, is re-read rather than used, since a pointer needs the whole header: a cube or 4D array would otherwise come back having lost the keywords for its third and fourth axes. @@ -254,7 +257,7 @@ names(corner) #Several positions at once, and the store list narrowed before any of them is searched many = Rfits_cutout_zarr_dir(dir = 'path/to/tiles', loc = targets$loc, box = 101, - pattern = 'field-07', cache = 'tiles.rds') + pattern = 'field-07', cache = 'tiles_index') #The same over S3, where the headers are the only thing transferred until a box is #actually matched. extract = FALSE answers the question for the price of the scan @@ -271,6 +274,7 @@ plot(seen[[1]][box = 101]) \seealso{ \code{\link{Rfits_dir_to_zarr}}, \code{\link{Rfits_point_zarr}}, \code{\link{Rfits_image_zarr}}, \code{\link{Rfits_methods}}, -\code{\link{Rfits_read_all}}, \code{\link[Rwcs]{Rwcs_overlap}} +\code{\link{Rfits_read_all}}, \code{\link[Rwcs]{Rwcs_overlap}}, +\code{\link{Rfits_zarr_index}} } \concept{ Zarr } diff --git a/man/Rfits_dir_to_zarr.Rd b/man/Rfits_dir_to_zarr.Rd index c0190d0..a8189df 100644 --- a/man/Rfits_dir_to_zarr.Rd +++ b/man/Rfits_dir_to_zarr.Rd @@ -15,7 +15,7 @@ Rfits_dir_to_zarr(dir = NULL, filelist = NULL, pattern = NULL, recursive = TRUE, target = NULL, bucket = NULL, prefix = '', region = NULL, endpoint = NULL, access_key = NULL, secret_key = NULL, session_token = NULL, - ext = 1L, extname = 'data1', verbose = TRUE, ...) + ext = 1L, extname = 'data1', cores = NULL, verbose = TRUE, ...) } \arguments{ \item{dir}{ @@ -74,6 +74,19 @@ Integer scalar; the FITS extension to read from each file. \item{extname}{ Character scalar; the name given to the array inside every store. Since each file gets a store of its own, the same name can be used for all of them. +} + \item{cores}{ +Integer scalar, or \code{NULL} for the default; the number of files to convert at +once. Each file is read, compressed, and written entirely by one worker, and no +worker opens a store another worker has touched, so the split is clean. The workers +are a cluster belonging to this call alone, which is stopped when it returns, so a +backend registered by the caller is neither used nor disturbed. Leave it as +\code{NULL} for the existing file-at-a-time behaviour. + +This splits the batch by file, which is the better way to parallelise a batch, and it +means \option{cores} cannot be used to ask for the chunk level parallelism of +\code{\link{Rfits_write_image_zarr}} across the batch. That argument is only reached by +calling the writer directly, for one array at a time. } \item{verbose}{ Logical scalar; whether to report each file as it is converted, and to warn about @@ -91,6 +104,23 @@ image rather than the whole directory. One file failing does not stop the rest; failure is recorded in the returned table, and reported as a warning when \option{verbose} is set. +Setting \option{cores} converts several files at once instead. The cost of a +conversion is dominated by compressing the pixels, which is single threaded work +however large the machine, so this is close to a linear gain: measured on 14000 by +14000 float images, six files at \code{clevel} = 9 take 178 s with \option{cores} = 6 +against roughly 870 s one at a time. Files are handed out in order and a worker takes +the next one as it finishes, so a batch of \code{n} files with \code{cores} = \code{n} +costs about as much as the single largest file. + +The price is memory, since every worker holds a whole image at once. A 14000 by 14000 +float image needs roughly 2 GB in a worker, so the number of workers is bounded by how +much is free rather than by how many cores there are, and a batch of large images wants +rather fewer workers than the machine can keep busy. \option{cores} does not change the +order of the returned table, which stays in the order of the files given even though +the workers finish in whatever order they can, and the same goes for the per-file +messages of \option{verbose}, which are the one part of the output that does arrive out +of order. Each worker also announces itself once as it starts. + Because a store is named after the file it came from, two files with the same base name in different sub directories would claim the same store. That is refused before anything is written, rather than discovered half way through when the second file @@ -145,9 +175,13 @@ out = Rfits_dir_to_zarr( session_token = '', chunk_shape = c(256, 256)) +#The same batch again, with the conversions spread over eight files at a time. A +#few large images are worth more workers than many small ones, where the cost of +#starting each worker is more than the work it is given +out = Rfits_dir_to_zarr(dir = 'path/to/images', target = 'path/to/zarr', cores = 8) + #Any one store can then be read as usual, or cut out remotely without transferring -#the whole image -library(zarr) +#the whole imagelibrary(zarr) store = zarr_s3store$new(bucket = 'my-bucket', prefix = paste0('survey/release-1/', basename(out$store[1])), region = 'auto', diff --git a/man/Rfits_image_zarr.Rd b/man/Rfits_image_zarr.Rd index ee85926..e90ae16 100644 --- a/man/Rfits_image_zarr.Rd +++ b/man/Rfits_image_zarr.Rd @@ -40,22 +40,22 @@ Rfits_read_array_zarr(filename = "temp.zarr", extname = "data1", ext = NULL,head Rfits_write_image_zarr(data, filename = 'temp.zarr', extname = 'data1', create_ext =TRUE, overwrite_file = FALSE, data_type = NULL, chunk_shape = NULL, clevel = 6L, compressor = 'blosc', shuffle = NULL, append = FALSE, update_root = TRUE, - keyvalues, keycomments, keynames, comment, history) + cores = NULL, keyvalues, keycomments, keynames, comment, history) Rfits_write_vector_zarr(data, filename = 'temp.zarr', extname = 'data1', create_ext=TRUE, overwrite_file = FALSE, data_type = NULL, chunk_shape = NULL, clevel = 6L, compressor = 'blosc', shuffle = NULL, append = FALSE, update_root = TRUE, - keyvalues, keycomments, keynames, comment, history) + cores = NULL, keyvalues, keycomments, keynames, comment, history) Rfits_write_cube_zarr(data, filename = 'temp.zarr', extname = 'data1', create_ext = TRUE, overwrite_file = FALSE, data_type = NULL, chunk_shape = NULL, clevel = 6L, compressor = 'blosc', shuffle = NULL, append = FALSE, update_root = TRUE, - keyvalues, keycomments, keynames, comment, history) + cores = NULL, keyvalues, keycomments, keynames, comment, history) Rfits_write_array_zarr(data, filename = 'temp.zarr', extname = 'data1', create_ext =TRUE, overwrite_file = FALSE, data_type = NULL, chunk_shape = NULL, clevel = 6L, compressor = 'blosc', shuffle = NULL, append = FALSE, update_root = TRUE, - keyvalues, keycomments, keynames, comment, history) + cores = NULL, keyvalues, keycomments, keynames, comment, history) Rfits_append_image_zarr(data, filename = 'temp.zarr', extname = 'data1', ...) @@ -143,6 +143,9 @@ Logical scalar; if TRUE the data is appended along dimension 1 of an existing ar } \item{update_root}{ Logical scalar; if TRUE (default) the store level description is rebuilt after a successful write. Set FALSE when writing many arrays in a loop, and then do at least one final write with it left at TRUE, since the refresh reads the metadata of every array in the store. Note that \code{\link{Rfits_inspect_zarr}} only reports what is there, it never repairs it. +} + \item{cores}{ +Integer scalar, or \code{NULL} for the default; the number of processes used to compress and write one array. See Details. } \item{keyvalues}{ Named list; keyword values to store, as produced by \code{\link{Rfits_read_header}}. Only needed for data which is not already an \option{Rfits_image} style object. @@ -185,6 +188,16 @@ With \option{append} = TRUE the data is the increment, not the complete final ar The stored data type is never widened or narrowed: an unrequested type difference is coerced to the existing array's type with a message, while an explicit \option{data_type} that disagrees is an error. The compressor of an existing array cannot be changed, which is reported rather than ignored. \option{NAXIS1} (or \option{ZNAXIS1} for a compressed image) is updated to follow the array, and a HISTORY line records the event on the array and in the root's \code{append_history}. Keywords already in the header win over any supplied with the append, since the alternative would be silently rewriting the WCS of a whole extension. Appending to an array with no FITS metadata leaves nothing invented behind: the array grows, and a message says no keys were updated. +\strong{Writing one array in parallel} + +Compressing an array is single threaded work, so a large image can take minutes no matter how many cores the machine has. Setting \option{cores} spreads that work over several processes, which is worth doing for one array of its own and is how \code{\link{Rfits_dir_to_zarr}} converts a whole directory. The array is cut into bands of whole chunks along its last dimension that is split into more than one chunk, and each worker is given one band. Bands never share a chunk, so no worker has to read what another has written, and the bytes on disk are identical to a single write. A band smaller than a chunk would break that, which is why \option{cores} does nothing when no dimension reaches two chunks, and why the chunk shape caps the useful number of workers. + +The workers receive their band as data, which costs a copy of the whole array and a trip through the serialiser on top of starting the cluster. On a 14000 by 14000 float array that is about a second to start and five more to slice and ship, so \option{cores} only pays when compression is what the time is going on: at \code{clevel} = 9 the same array takes 102 s in one process and 24 s with \code{cores} = 8, but at \code{clevel} = 3 it takes 9.3 s and 8.1 s, which is barely worth the process management. A 2000 by 2000 array at \code{clevel} = 9 is a wash at about 2 s either way, and smaller arrays are slower in parallel. + +Memory goes up rather than down, since the parent holds the whole array while each worker holds its own band: the same array peaks near 4.6 GB written in one process and 10.6 GB with 8 workers. That, not the core count, is what bounds a large \option{cores}. + +\option{cores} needs a local store path, since each worker opens the store for itself and a store object cannot be carried across to another process. Given a store object it is reported and ignored, and the array is written in one. The same happens with \option{append} = TRUE, where the increment has to be resized before it can be written at all. + \strong{Remote stores} Wherever \option{filename} is expected, a store object created by \code{\link[zarr]{zarr_s3store}} (or \code{zarr_localstore}, \code{zarr_memorystore}, \code{zarr_httpstore}) may be given instead of a path. This is the only way to reach a store that needs credentials, because \code{\link[zarr]{open_zarr}} builds the store itself and cannot be passed one, so it has no way to accept a key or a non-AWS endpoint. The store must already be configured and authenticated; Rfits never sees a secret key. An open \code{zarr} object may also be given, so the result of \code{zarr::zarr$new(store)} can be reused across calls. diff --git a/man/Rfits_zarr_index.Rd b/man/Rfits_zarr_index.Rd new file mode 100644 index 0000000..24a9181 --- /dev/null +++ b/man/Rfits_zarr_index.Rd @@ -0,0 +1,246 @@ +\name{Rfits_zarr_index} +\alias{Rfits_zarr_index} +\alias{Rfits_zarr_index_query} +\alias{Rfits_zarr_index_info} +\alias{print.Rfits_zarr_index_info} +\title{ +A Parquet Index of the Search Metadata of a Directory of Zarr Stores +} +\description{ +Builds, queries and summarises an index of the header metadata of a directory (or S3 +prefix) of Zarr stores, held in a single parquet file. \code{\link{Rfits_cutout_zarr_dir}} +decides which stores are worth opening from their headers alone, which costs one small +read per store; the index holds that answer once, so a release can publish one file +beside its tiles and every user's first query costs that file instead of thousands of +requests. + +\code{Rfits_zarr_index} extracts the metadata of every store and writes the index. +\code{Rfits_zarr_index_query} answers which stores could overlap a position, without +reading pixel data. \code{Rfits_zarr_index_info} reports what an index holds. +} +\usage{ +Rfits_zarr_index(dir = NULL, filelist = NULL, pattern = NULL, recursive = TRUE, + bucket = NULL, prefix = '', region = NULL, endpoint = NULL, access_key = NULL, + secret_key = NULL, session_token = NULL, extname = 'data1', index = NULL, + refresh = FALSE, data.table = TRUE, verbose = TRUE, ...) + +Rfits_zarr_index_query(index, RA = NULL, Dec = NULL, loc = NULL, box = 101, + box.unit = c('pix', 'arcsec'), bucket = NULL, prefix = NULL, region = NULL, + endpoint = NULL, access_key = NULL, secret_key = NULL, session_token = NULL, + buffer = 0, safety = 0.1, keywords = FALSE, data.table = TRUE, verbose = TRUE) + +Rfits_zarr_index_info(index, bucket = NULL, prefix = NULL, region = NULL, + endpoint = NULL, access_key = NULL, secret_key = NULL, session_token = NULL) + +\method{print}{Rfits_zarr_index_info}(x, ...) +} +\arguments{ + \item{dir}{ +Character scalar; the directory to index, holding \code{*.zarr} stores at any depth +when \option{recursive} is set. A directory that is itself named \code{*.zarr} is +indexed as that one store. Give one of \option{dir}, \option{filelist}, \option{bucket} +or an existing \option{index}. +} + \item{filelist}{ +Character vector; explicit store paths to index instead of \option{dir}. +} + \item{pattern}{ +Character vector; regular expressions used to narrow the stores, applied in turn as +\code{\link{grep}} would apply them. Matching is against the whole path. Narrowing an +index run does not narrow the index: rows written by a broader run are kept. +} + \item{recursive}{ +Logical scalar; whether to search below \option{dir}, or below the S3 prefix. +} + \item{bucket}{ +Character scalar; the S3 bucket holding the stores, which makes the run remote. A bare +\option{index} name is then read and written within that bucket. +} + \item{prefix}{ +Character scalar; a path within \option{bucket}, either a directory of stores or a +single store. When \option{index} is a bare name, this is where the index file is +looked for and written, which is how an index comes to sit beside the tiles it +describes and be reachable with the same credentials. +} + \item{region}{ +Character scalar; the S3 region, \code{'auto'} for Cloudflare R2. Defaults to +\code{RFITS_S3_REGION} when that is set. +} + \item{endpoint}{ +Character scalar; the S3 endpoint, needed by any service that is not AWS. Defaults to +\code{RFITS_S3_ENDPOINT} when that is set. +} + \item{access_key}{ +Character scalar; the access key. Defaults to \code{RFITS_S3_ACCESS_KEY}. Required for +a remote run. +} + \item{secret_key}{ +Character scalar; the secret key. Defaults to \code{RFITS_S3_SECRET_KEY}. +} + \item{session_token}{ +Character scalar; the session token, or \code{''} when there is none. Defaults to +\code{RFITS_S3_SESSION_TOKEN}. +} + \item{extname}{ +Character vector; the name(s) of the array within each store to record, as written by +\code{\link{Rfits_dir_to_zarr}}. The first that exists in a given store is the one +kept, and each store is held as its own row. +} + \item{index}{ +Character scalar; where the index is. A local path, a bare name (which, with +\option{bucket}, addresses an object under \option{prefix}), or a full \code{s3://} +URI. The extension may be left off, since the file is always named +\code{.parquet}; a path ending in \code{.rds} keeps its stem, which is where the +older cache format left it. +} + \item{refresh}{ +Logical scalar; whether to rebuild from the stores even when \option{index} already +exists. Without it, an existing index is returned unread and the stores are never +opened, which is the point of having built one. When writing, existing rows are merged +rather than replaced. +} + \item{data.table}{ +Logical scalar; whether to return a \code{data.table} rather than a plain +\code{data.frame}. +} + \item{verbose}{ +Logical scalar; whether to report what was read, recorded and written. +} + \item{\dots}{ +Passed to the store search, so that \option{max_dirs} can be raised for a deep prefix. +} + \item{RA}{ +Numeric vector; right ascension(s), in degrees, to search for. Give \option{RA} and +\option{Dec}, or \option{loc}. +} + \item{Dec}{ +Numeric vector; declination(s), in degrees. +} + \item{loc}{ +Numeric matrix with two columns; positions as RA/Dec, one row each, given instead of +\option{RA} and \option{Dec} rather than as well. +} + \item{box}{ +Numeric scalar or vector of length two; the size of the requested cutout, which sets +how far a store's reference position may be from the requested one and still be +returned. Same as the argument of +\code{\link{Rfits_cutout_zarr_dir}}, and deliberately generous in the same way. +} + \item{box.unit}{ +Character scalar; whether \option{box} is in pixels or arcsec. In arcsec the box is +converted per store, using that store's own pixel scale. +} + \item{buffer}{ +Numeric scalar; extra reach in arcsec, applied on every side of the box. Use it to +catch a store that lies just outside the request. +} + \item{safety}{ +Numeric scalar; a relative margin on the candidate radius. Raising it makes the test +less strict, at the cost of returning more stores. +} + \item{keywords}{ +Logical scalar; whether to fetch the serialised header of each surviving store into a +\code{keyvalues} column. Those bytes are the bulk of the file, so the default keeps a +query to the columns a search filters with. +} + \item{x}{ +An object of class \code{Rfits_zarr_index_info}, as returned by +\code{Rfits_zarr_index_info}. +} +} +\details{ +The index holds three kinds of row, named by the \code{kind} column. Store rows carry +the search metadata of one array of one store. Walk rows carry the list of stores found +under a remote prefix, kept because finding them costs a request per directory. Meta +rows are scalars about the file itself, of which the format version is the only one +anyone else reads. + +Every column a search filters with is scalar, so a query is answered with an arrow scan +that projects them alone and never decodes the keyword blob of the thousands of stores +nowhere near the position. The keywords of the survivors are then fetched by store key, +from a file written in sorted store order so that whole row groups can be skipped. + +The candidate test is the same generous one the search uses, and is shared with it, so +a store this reports cannot be one the search would have rejected. That includes the +offset between a store's reference point and its centre, which a stricter version of +the test would have missed. A position that is nearer than a store's half diagonal plus +the box plus \option{buffer} and \option{safety} is returned; anything whose radius +could not be worked out is returned too, since a pre-filter that quietly dropped a +match would look exactly like a directory of tiles that did not overlap. + +An index written by a later version of the package is refused rather than half read. +One with no version is treated the same way, and says to rebuild with +\option{refresh} = \code{TRUE}. +} +\value{ +\code{Rfits_zarr_index} and \code{Rfits_zarr_index_query} return, invisibly, one row +per store: the \code{kind}, \code{cache_key}, \code{store}, \code{label}, +\code{extname}, \code{status} and \code{error} columns, the scalar WCS and shape +columns the filter reads (\code{ra}, \code{dec}, \code{crpix1}, \code{crpix2}, +\code{naxis1}, \code{naxis2}, \code{pixscale_x}, \code{pixscale_y}), \code{array_dim}, +a \code{stamp} of the metadata document the row was read from, and +\code{has_keyvalues}. A query with \option{keywords} = \code{TRUE} adds the +\code{keyvalues} column, holding each store's serialised header as a raw vector. + +\code{Rfits_zarr_index_info} returns, invisibly, a list of class +\code{Rfits_zarr_index_info} with the index \option{path}, format \option{version}, +number of store \option{n_rows}, the \option{extnames} and \option{stores} it holds, a +\code{status} table of how many rows are \code{'ok'} and how many are not, the number +of cached \option{n_walks} store lists, and the time the index was last written +(\option{created}). +} +\author{ +Aaron Robotham +} +\note{ +Requires the suggested \code{arrow} package, which is the reader that can push both a +row filter and a column projection into the scan. Remote runs also need +\code{paws.storage}. +} +\examples{ +\dontrun{ +#A release of tiles, each its own store, indexed once beside them +ix = Rfits_zarr_index(dir = 'path/to/tiles', index = 'path/to/tiles/index') +nrow(ix) +table(ix$status) + +#What a search would look at, for one position, without reading a pixel +hit = Rfits_zarr_index_query('path/to/tiles/index', RA = 53.1628, Dec = -27.7444, + box = 5, box.unit = 'arcsec') +hit$label + +#Build it beside the tiles in a bucket. A bare index name resolves under the prefix +#being indexed, so the index is published next to the data it describes +Rfits_zarr_index(bucket = 'my-bucket', prefix = 'survey/release-1/', + index = 'index', region = 'auto', + endpoint = 'https://account.r2.cloudflarestorage.com', + access_key = Sys.getenv('R2_KEY'), + secret_key = Sys.getenv('R2_SECRET'), session_token = '') + +#Someone else, handed the URI of the published index, needs only the credentials +seen = Rfits_zarr_index_query( + 's3://my-bucket/survey/release-1/index.parquet', + loc = targets$loc, box = 101, + region = 'auto', endpoint = 'https://account.r2.cloudflarestorage.com', + access_key = Sys.getenv('R2_KEY'), secret_key = Sys.getenv('R2_SECRET'), + session_token = '') +#The headers of the survivors, to build pointers from without opening any store +head = Rfits_zarr_index_query('s3://my-bucket/survey/release-1/index.parquet', + RA = 53.1628, Dec = -27.7444, keywords = TRUE, + region = 'auto', endpoint = '...', access_key = '...', + secret_key = '...', session_token = '') + +#Is the index current, and what does it hold? +Rfits_zarr_index_info('path/to/tiles/index') + +#Hand the same file to the search, which then costs one read rather than one per store +cut = Rfits_cutout_zarr_dir(dir = 'path/to/tiles', RA = 53.1628, Dec = -27.7444, + box = 101, cache = 'path/to/tiles/index') +} +} +\seealso{ +\code{\link{Rfits_cutout_zarr_dir}}, \code{\link{Rfits_dir_to_zarr}}, +\code{\link{Rfits_point_zarr}}, \code{\link{Rfits_image_zarr}}, +\code{\link{Rfits_inspect_zarr}} +} +\concept{ Zarr } diff --git a/tests/testthat/test_Rfits_cutout_app.R b/tests/testthat/test_Rfits_cutout_app.R new file mode 100644 index 0000000..71faeed --- /dev/null +++ b/tests/testthat/test_Rfits_cutout_app.R @@ -0,0 +1,1291 @@ +#The bundled Shiny app. What is checked here is the half that can be checked without a +#browser: that the file is installed and parses, that the helpers the server is built from +#behave, and that the observers wire inputs to results when driven against a mock session. +# +#The app is sourced into its own environment rather than started, because the file ends in +#shinyApp(), which builds an app object without serving it. That does attach shiny, bslib +#and DT to the search path for the rest of the run, which is the price of testing a file +#that loads its own dependencies. + +app_dir = system.file('shiny', 'Rfits_cutout_app', package = 'Rfits') + +#ex 1 the app is installed where the launcher says it is +expect_true(nzchar(app_dir)) +expect_true(file.exists(file.path(app_dir, 'app.R'))) +expect_true(is.function(Rfits_cutout_app)) + +app_text = paste(readLines(file.path(app_dir, 'app.R'), warn = FALSE), collapse = '\n') + +#ex 2 the file must parse on its own. R CMD check looks at no file under inst/, so a +#syntax error here would only be found by someone trying to start the app +expect_silent(parse(text = app_text)) + +#ex 3 every icon the UI asks for must be one fontawesome knows. An unknown name is only a +#warning and a missing glyph at run time, which is exactly the kind of thing that ships by +#accident; two of them did, first time +icon_calls = unique(gsub("^icon\\('|'\\)$", '', + unlist(regmatches(app_text, gregexpr("icon\\('[a-z0-9-]+'\\)", + app_text))))) +expect_gt(length(icon_calls), 0) +if(requireNamespace('fontawesome', quietly = TRUE)){ + known = unique(c(fontawesome::fa_metadata()$icon_names, fontawesome:::alias_tbl$alias)) + expect_equal(icon_calls[!icon_calls %in% known], character(0)) +} + +#ex 4 the internal helpers the server reaches for must still exist. They are not public +#API, so nothing else in the suite would notice one being renamed +internals = unique(gsub('^Rfits:::', '', unlist(regmatches(app_text, gregexpr( + 'Rfits:::[.A-Za-z0-9_]+', app_text))))) +expect_gt(length(internals), 0) +for(name in internals){ + expect_true(exists(name, envir = asNamespace('Rfits'), inherits = FALSE), + info = paste(name, 'is used by the app but is not in the namespace')) +} + +app_env = new.env(parent = globalenv()) +sourced = tryCatch({ + suppressMessages(sys.source(file.path(app_dir, 'app.R'), envir = app_env, + keep.source = FALSE)) + TRUE +}, error = function(e) e) +#A machine without the suggested packages cannot source the app at all, and that is a skip +#rather than a failure +if(!isTRUE(sourced)){ + skip(paste('the app could not be sourced:', conditionMessage(sourced))) +} +expect_true(is.function(app_env$server)) +expect_false(is.null(app_env$ui)) + +#ex 5 position parsing. Free text is what gets pasted, so a line that is not two finite +#numbers has to be reported rather than dropped, or a truncated paste silently searches +#fewer targets than the user thinks it did +pos = app_env$parse_positions('53.1 -27.8\n10.5, -45.2') +expect_identical(dim(pos), c(2L, 2L)) +expect_identical(colnames(pos), c('RA', 'Dec')) +expect_length(attr(pos, 'bad'), 0) +#separators a spreadsheet or a finder list may produce +expect_identical(nrow(app_env$parse_positions('53.1\t-27.8')), 1L) +expect_identical(nrow(app_env$parse_positions('53.1;-27.8')), 1L) +expect_identical(nrow(app_env$parse_positions('53.1 -27.8')), 1L) +expect_identical(nrow(app_env$parse_positions('53.1 -27.8\r\n10 -40')), 2L) +#comments and blanks are not errors +expect_identical(nrow(app_env$parse_positions('# a comment\n\n53.1 -27.8')), 1L) +#but anything that is not a pair of finite numbers is +expect_length(attr(app_env$parse_positions('nonsense'), 'bad'), 1L) +#one number is half a position, not a position +expect_length(attr(app_env$parse_positions('53.1'), 'bad'), 1L) +expect_length(attr(app_env$parse_positions('53.1 abc'), 'bad'), 1L) +#NA and Inf would each fail somewhere far less legible than here +expect_length(attr(app_env$parse_positions('NA 1'), 'bad'), 1L) +expect_length(attr(app_env$parse_positions('Inf 1'), 'bad'), 1L) +expect_identical(nrow(app_env$parse_positions('')), 0L) +#rows come back in the order they were typed, which is what the per position loop assumes +pos = app_env$parse_positions('1 2\n3 4\n5 6') +expect_identical(pos[, 1], c(1, 3, 5)) +expect_identical(pos[, 2], c(2, 4, 6)) + +#ex 6 file names built from store names have to survive being written and zipped +expect_identical(app_env$safe_filename('tile1'), 'tile1') +expect_identical(app_env$safe_filename('a b/c'), 'a_b_c') +#an empty name would otherwise produce a file called '.fits' +expect_identical(app_env$safe_filename(''), 'cutout') +#unsafe runs collapse to a single underscore, so the name stays short and is never empty +expect_identical(app_env$safe_filename('***'), '_') +expect_identical(app_env$safe_filename('a//b'), 'a_b') +#only truncated, never lengthened, so a long store name still gets an extension +expect_lte(nchar(app_env$safe_filename(strrep('x', 300))), 90) +#dots and dashes are kept, since they carry the tile identity +expect_identical(app_env$safe_filename('tile-01_a.fits'), 'tile-01_a.fits') + +#ex 7 run messages must be captured rather than printed. A Shiny user has no console, and +#the store loop has to report one failure per store without abandoning the request +cap = app_env$with_capture({ + warning('a warning') + message('a message') + 42 +}) +expect_identical(cap$value, 42) +expect_identical(sum(grepl('^WARNING: a warning$', cap$msgs)), 1L) +expect_identical(sum(grepl('^INFO: a message$', cap$msgs)), 1L) +#an error becomes text and a NULL value, which is how the caller knows to carry on +cap = app_env$with_capture(stop('boom')) +expect_null(cap$value) +expect_identical(cap$msgs, 'ERROR: boom') +#and a quiet block stays quiet +expect_length(app_env$with_capture(1 + 1)$msgs, 0) + +#ex 8 footprints, drawn from index numbers alone. The box has to be the tile in degrees, +#widened in RA by cos(Dec) the way an angular size on the sky has to be +rows = data.frame(store = c('/a/tile1.zarr', '/b/tile2.zarr'), ra = c(10, 10), + dec = c(0, 60), naxis1 = c(1000, 1000), naxis2 = c(1000, 1000), + pixscale_x = c(1, 1), pixscale_y = c(1, 1), status = 'ok', + extname = 'data1', type = 'image', + label = c('/a/tile1.zarr', '/b/tile2.zarr'), stringsAsFactors = FALSE) +fr = app_env$index_footprints(rows) +#1000 pixels of 1 arcsec is 1000/3600 degrees across +expect_equal(fr$xmax[1] - fr$xmin[1], 1000/3600, tolerance = 1e-9) +expect_equal(fr$ymax[1] - fr$ymin[1], 1000/3600, tolerance = 1e-9) +#at 60 degrees a degree of RA covers half the sky of a degree of Dec, so the same tile is +#drawn twice as wide in RA +expect_equal((fr$xmax[2] - fr$xmin[2])/(fr$xmax[1] - fr$xmin[1]), 2, tolerance = 1e-6) +#centred on the reference position +expect_equal((fr$xmin + fr$xmax)/2, rows$ra) +expect_equal((fr$ymin + fr$ymax)/2, rows$dec) +#named for the store rather than for the path it sits on +expect_identical(fr$name, c('tile1', 'tile2')) +#an empty index gives an empty answer rather than an error +expect_identical(nrow(app_env$index_footprints(rows[0, , drop = FALSE])), 0L) +#and the cos(Dec) widening must not blow up at the pole, where it is unbounded +polar = app_env$index_footprints(transform(rows, dec = c(89.99, 89.99))) +expect_true(all(is.finite(unlist(polar[, c('xmin', 'xmax', 'ymin', 'ymax')])))) + +#ex 9 the table view drops the columns that are bulk and mean nothing to a reader +view = app_env$index_view_columns(cbind( + rows, + data.frame(cache_key = c('k1', 'k2'), kind = 'store', error = NA_character_, + stamp = 's', created = as.numeric(Sys.time()), has_keyvalues = TRUE, + crpix1 = 1, crpix2 = 1, text_value = NA_character_, + stringsAsFactors = FALSE), + I(data.frame(array_dim = I(list(1:2, 1:2)), stores = I(list('a', 'b')), + keyvalues = I(list(raw(0), raw(0))), stringsAsFactors = FALSE)))) +expect_false(any(c('keyvalues', 'stores', 'array_dim', 'has_keyvalues', 'stamp') %in% + names(view))) +expect_true(all(c('label', 'ra', 'dec', 'status') %in% names(view))) +expect_s3_class(view$created, 'POSIXct') + +#ex 10 the header filter, which is checked directly because it is the one piece of the app +#that has to reach into the index for the keyword blobs. Values live in the index rather +#than in the pixels, so this is the filter that can narrow a release without reading it +skip_if_not_installed('zarr') +skip_if_not_installed('arrow') +skip_if_not_installed('Rwcs') +skip_if_not_installed('shiny') + +src_image = Rfits_read_image(system.file('extdata', 'image.fits', package = 'Rfits')) +img_kv = src_image$keyvalues +app_tiles = file.path(tempdir(), 'app_tiles') +dir.create(app_tiles, showWarnings = FALSE) +for(i in 1:2){ + #two tiles offset in RA, so that a search has something to reject as well as something + #to match, which is the only way to tell a search apart from a read of everything + kv = img_kv + kv$CRVAL1 = kv$CRVAL1 + (i - 1) * 0.05 + suppressWarnings(Rfits_write_image_zarr(src_image$imDat, + filename = file.path(app_tiles, + paste0('tile', i, '.zarr')), + extname = 'data1', keyvalues = kv, + overwrite_file = TRUE)) +} +app_index = file.path(app_tiles, 'index.parquet') +unlink(app_index) +suppressWarnings(suppressMessages(Rfits_zarr_index(dir = app_tiles, index = app_index, + verbose = FALSE))) +expect_true(file.exists(app_index)) +index_rows = as.data.frame(Rfits:::.zarr_index_light_rows(app_index), + stringsAsFactors = FALSE) +expect_identical(nrow(index_rows), 2L) + +notes = character(0) +add_note = function(...) notes <<- c(notes, paste0(...)) +#an index column, matched case insensitively. EXTNAME is a column of the index and not +#necessarily a keyword in the header, and a filter that looked only at keywords would +#return nothing for it and look like an empty release +keep = app_env$filter_by_keyword(index_rows, app_index, 'EXTNAME', 'data1', note = add_note) +expect_identical(nrow(keep), 2L) +expect_match(paste(notes, collapse = ' '), 'index column') +#and the same word as a header keyword that no candidate carries must be reported as +#absent rather than as a filtering decision +notes = character(0) +keep = app_env$filter_by_keyword(index_rows, app_index, 'NOSUCHKEYWORD', '', note = add_note) +expect_identical(nrow(keep), 0L) +expect_match(paste(notes, collapse = ' '), 'No candidate store carries a NOSUCHKEYWORD') +#a keyword that is present but whose values do not match says what the values were, which +#is how a user tells a wrong pattern apart from a release with no such data. The value is +#a glob, so '999*' is the way to ask for a value beginning 999 +notes = character(0) +keep = app_env$filter_by_keyword(index_rows, app_index, 'CRVAL1', '999*', note = add_note) +expect_identical(nrow(keep), 0L) +expect_match(paste(notes, collapse = ' '), 'Values seen') +#the note quotes back what was typed rather than the regular expression it became, since a +#user who typed a glob and was shown '^999' would be reading the conversion, not their own +expect_match(paste(notes, collapse = ' '), '"999\\*"') +#present and matching keeps the store it belongs to, and only that one. The glob is +#anchored at the front with the coordinate exactly as it appears in the index, and the +#trailing * is what lets the stored value's full precision through +notes = character(0) +keep = app_env$filter_by_keyword(index_rows, app_index, 'CRVAL1', + paste0(round(img_kv$CRVAL1, 4), '*'), note = add_note) +expect_identical(nrow(keep), 1L) +expect_match(keep$label[1], 'tile1') +#a blank key is no filter at all +expect_identical(nrow(app_env$filter_by_keyword(index_rows, app_index, '', 'x')), 2L) + +run_inputs = list(dir = app_tiles, bucket = '', prefix = '', pattern = '', + extname = 'data1', index_name = 'index.parquet', region = '', + endpoint = '', access_key = '', secret_key = '', session_token = '', + max_dirs = 1000, rebuild = FALSE, box = 51, box_unit = 'pix', + buffer = 0, kw_key = '', kw_value = '', max_stores = 25, qdiff = TRUE, + type = 'quan', stretch = 'asinh', locut = NA, hicut = NA, + useraster = TRUE, slice = 1, cut_width = 300, max_show = 24, + idx_filter = '', idx_status = 'all', positions = '') + +#setInputs takes named arguments, so they have to be splatted; handing it a list +#directly is rejected with an error about an empty key. An unnamed list argument is +#spliced here so a block of defaults can be passed as one object, and load and run are +#always flushed separately because an observer that needs the index must not fire in the +#same flush as the one that builds it +put_inputs = function(session, ...){ + args = list(...) + nms = names(args) + if(is.null(nms)){ + nms = rep('', length(args)) + } + flat = list() + for(i in seq_along(args)){ + if(!nzchar(nms[i]) && is.list(args[[i]])){ + flat = c(flat, args[[i]]) + }else{ + flat[[nms[i]]] = args[[i]] + } + } + do.call(session$setInputs, flat) + session$flushReact() + invisible(NULL) +} + +#ex 11 a bare index name is resolved inside the store directory locally, so a session does +#not have to know the absolute path of the file it is about to read. Over S3 the same bare +#name goes to the bucket root instead, which is the published location +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, index_name = 'index.parquet', load = 1) + session$flushReact() + con = reactiveValuesToList(state)$con + expect_identical(con$index_name, file.path(app_tiles, 'index.parquet')) + #but a name that already carries a separator is left alone + put_inputs(session, index_name = 'sub/index.parquet', load = 2) + session$flushReact() + expect_identical(reactiveValuesToList(state)$con$index_name, + file.path(app_tiles, 'sub/index.parquet')) +}, session = shiny::MockShinySession$new()) + +#ex 12 the whole request path: load, query the index, cut, and put the result somewhere a +#user can see it. This is the wiring between the tabs rather than the arithmetic, which is +#checked above, and it is where a renamed input id or a dropped argument would show up +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1 + 0.02, img_kv$CRVAL2), load = 1) + session$flushReact() + s = reactiveValuesToList(state) + expect_false(is.null(s$idx)) + expect_equal(nrow(s$rows), 2L) + #the copy of the index has to survive for as long as the session queries it, which is + #the one thing a remote search would break on + expect_true(file.exists(s$idx$path)) + + put_inputs(session, run = 1) + session$flushReact() + s = reactiveValuesToList(state) + expect_length(s$res, 1L) + expect_named(s$res, 'tile1') + expect_false(is.null(s$res[[1]]$imDat)) + expect_identical(dim(s$res[[1]]$imDat), c(51L, 51L)) + #the WCS of the tile is carried through to the cutout, so the box is somewhere knowable + expect_equal(s$res[[1]]$keyvalues$CRVAL1, img_kv$CRVAL1, tolerance = 1e-6) + expect_false(is.null(s$matches)) + expect_true(all(c('name', 'position', 'store', 'RA', 'Dec', 'dim') %in% + names(s$matches))) + #and the index file is still there after a search has used it + expect_true(file.exists(s$idx$path)) + + #a position nowhere near any tile must give no results rather than an error + put_inputs(session, positions = '0 0', run = 2) + session$flushReact() + expect_length(reactiveValuesToList(state)$res, 0L) + + #the outputs the tabs render, including with nothing in them + for(id in c('store_status', 'store_summary', 'log', 'gallery', 'idx_info')){ + expect_no_error(session$getOutput(id)) + } +}, session = shiny::MockShinySession$new()) + +#ex 13 several positions in one request. Names have to tell the positions apart, and the +#match table has to stay aligned with the results it labels +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.02, ' ', img_kv$CRVAL2, '\n', + img_kv$CRVAL1, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + s = reactiveValuesToList(state) + expect_length(s$res, 2L) + expect_equal(anyDuplicated(names(s$res)), 0L) + expect_equal(sort(unique(s$matches$position)), c(1L, 2L)) + #one row of the table per result, and every row names a result that exists + expect_equal(nrow(s$matches), length(s$res)) + expect_true(all(s$matches$name %in% names(s$res))) + #the table rows are labelled with the names of the results they came from, which is the + #alignment that a sort after naming would silently break + expect_identical(s$matches$name[order(s$matches$position)], names(s$res)) +}, session = shiny::MockShinySession$new()) + +#ex 14 a request that fails part way through must not leave the previous answer on screen. +#Results are cleared before anything is asked for, so what is plotted always belongs to +#the positions in the box +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1 + 0.02, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + expect_length(reactiveValuesToList(state)$res, 1L) + #now a run whose keyword filter removes every candidate + put_inputs(session, kw_key = 'NOSUCHKEYWORD', run = 2) + session$flushReact() + expect_length(reactiveValuesToList(state)$res, 0L) + expect_null(reactiveValuesToList(state)$matches) +}, session = shiny::MockShinySession$new()) + +#ex 15 the name pattern, applied on top of an index that may be broader than this session +#asked for +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1 + 0.02, img_kv$CRVAL2), + pattern = 'tile2', load = 1, run = 1) + session$flushReact() + s = reactiveValuesToList(state) + #tile2 is all the pattern leaves, and the requested position is not inside it + expect_length(s$res, 0L) + expect_match(paste(s$log, collapse = '\n'), 'Name pattern kept 1') +}, session = shiny::MockShinySession$new()) + +#ex 15a the same pattern has to narrow what the tabs list, not only what a request cuts. +#A published index is the whole release, so a session filtered to one tile must not be shown +#the other one on the Index, Frames or Store tabs while the search refuses to cut it +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + #with no pattern the whole index is in view + expect_equal(nrow(reactiveValuesToList(state)$rows), 2L) + expect_match(session$getOutput('frames_info'), 'Frames in view: 2') + + #a pattern narrowing the session to one tile narrows every view at once + put_inputs(session, pattern = 'tile1', load = 2) + session$flushReact() + s = reactiveValuesToList(state) + expect_equal(nrow(s$rows), 1L) + expect_true(all(grepl('tile1', s$rows$label))) + #the index object the queries are made against carries the narrowed rows too, so the + #status panel and the search cannot be reading two different sets + expect_equal(nrow(s$idx$rows), 1L) + #and the tabs, which is what the pattern was not reaching before + html = paste(as.character(session$getOutput('index_table')), collapse = '') + expect_true(grepl('tile1', html)) + expect_false(grepl('tile2', html)) + expect_match(session$getOutput('frames_info'), 'Frames in view: 1') + expect_match(session$getOutput('idx_info'), 'index rows: 1') + expect_match(paste(s$log, collapse = '\n'), 'Name pattern kept 1 of 2 index row') + + #a pattern that matches nothing is an ordinary empty view rather than an error, and the + #range() a summary would take over no rows must not warn + put_inputs(session, pattern = 'nope*', load = 3) + session$flushReact() + s = reactiveValuesToList(state) + expect_equal(nrow(s$rows), 0L) + expect_no_error(session$getOutput('store_summary')) + #renderUI hands back a tag list rather than a string, so it is pasted to characters first + expect_match(paste(as.character(session$getOutput('store_summary')), collapse = ''), + 'No store in the index matches') + expect_match(session$getOutput('frames_info'), 'No frames to show') + expect_match(session$getOutput('idx_info'), 'excluded every row') + + #back to the whole index, so the narrowing is not sticky + put_inputs(session, pattern = '', load = 4) + session$flushReact() + expect_equal(nrow(reactiveValuesToList(state)$rows), 2L) +}, session = shiny::MockShinySession$new()) + +#ex 15a2 the helper both the tabs and the search go through. All patterns must match, so a +#comma separated field is an AND rather than a union, and a blank or absent pattern is no +#filter at all rather than a filter that matches nothing +pr_rows = data.frame(label = c('a/tile1.zarr', 'a/tile2.zarr'), status = 'ok', + stringsAsFactors = FALSE) +expect_identical(nrow(app_env$pattern_rows(pr_rows, app_env$glob_regex('tile1'))), 1L) +expect_identical(nrow(app_env$pattern_rows(pr_rows, app_env$glob_regex('tile*'))), 2L) +expect_identical(nrow(app_env$pattern_rows(pr_rows, app_env$glob_regex('*.zarr'))), 2L) +#both have to match, and no single label can be both tile1 and tile2 +expect_identical(nrow(app_env$pattern_rows(pr_rows, app_env$glob_regex(c('tile1', 'tile2')))), 0L) +#blank, NULL and an empty set all leave the rows alone +expect_identical(nrow(app_env$pattern_rows(pr_rows, character(0))), 2L) +expect_identical(nrow(app_env$pattern_rows(pr_rows, NULL)), 2L) +expect_identical(nrow(app_env$pattern_rows(pr_rows[0, , drop = FALSE], + app_env$glob_regex('tile1'))), 0L) + +#ex 15b the store name pattern is a glob rather than a regular expression, converted with +#glob2rx. What has to hold is that a name finds a store anywhere in its path rather than +#only as the whole string, that * and ? are the wildcards, and that the characters glob2rx +#does not escape are still literals rather than being read as regex +expect_identical(app_env$glob_regex('tile2'), 'tile2') +expect_identical(app_env$glob_regex('tile*'), 'tile.*') +expect_identical(app_env$glob_regex('*tile*'), '.*tile.*') +expect_identical(app_env$glob_regex('*.zarr'), '.*\\.zarr') +#the anchors glob2rx adds are dropped, so 'tile2' is a substring test on a full store path +expect_true(grepl(app_env$glob_regex('tile2'), '/data/releases/dr1/tile2.zarr')) +expect_true(grepl(app_env$glob_regex('*.zarr'), '/data/releases/dr1/tile2.zarr')) +#the characters glob2rx leaves alone must not become regex operators: '+' is a literal +#here, not 'one or more of the previous', and '|' is a literal rather than alternation +expect_true(grepl(app_env$glob_regex('a+b'), 'xa+bx')) +expect_false(grepl(app_env$glob_regex('a+b'), 'xab')) +expect_true(grepl(app_env$glob_regex('grz|riz'), 'xgrz|rizx')) +expect_false(grepl(app_env$glob_regex('grz|riz'), 'xgrzx')) +#a pattern containing a backslash must still compile, which it would not if glob2rx were +#handed a bare trailing one +expect_no_warning(grepl(app_env$glob_regex('a\\'), 'x')) +#vectorised over the comma separated field, and a blank or NA pattern filters nothing +expect_identical(app_env$glob_regex(c('tile*', '*.zarr')), c('tile.*', '.*\\.zarr')) +expect_length(app_env$glob_regex(''), 0L) +expect_length(app_env$glob_regex(NA_character_), 0L) +expect_length(app_env$glob_regex(character(0)), 0L) + +#and the globs work through the search path rather than only in the helper +testServer(app_env$server, expr = { + for(pat in c('tile*', '*tile*', '*.zarr')){ + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1 + 0.02, img_kv$CRVAL2), + pattern = pat, load = 1, run = 1) + session$flushReact() + s = reactiveValuesToList(state) + #both tiles survive the pattern, and the position is inside tile1 + expect_match(paste(s$log, collapse = '\n'), 'Name pattern kept 2', + info = paste('pattern', pat)) + expect_length(s$res, 1L) + } + #a glob that matches nothing is reported as such rather than quietly searching everything + put_inputs(session, pattern = 'nope*', load = 2, run = 2) + session$flushReact() + expect_match(paste(reactiveValuesToList(state)$log, collapse = '\n'), + 'Name pattern kept 0') +}, session = shiny::MockShinySession$new()) + +#ex 15c the Index tab's store name filter is the same glob, and the Frames tab reads it +#through the same helper, so the two views cannot disagree about what is on screen +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + index_rows_html = function(){ + paste(as.character(session$getOutput('index_table')), collapse = '') + } + #a bare name is a substring test, so it finds the store it names and not the other + put_inputs(session, idx_filter = 'tile2') + html = index_rows_html() + expect_true(grepl('tile2', html)) + expect_false(grepl('tile1', html)) + expect_match(session$getOutput('frames_info'), 'Frames in view: 1') + #a wildcard reaches both + put_inputs(session, idx_filter = 'tile*') + expect_true(grepl('tile1', index_rows_html())) + expect_true(grepl('tile2', index_rows_html())) + expect_match(session$getOutput('frames_info'), 'Frames in view: 2') + #and an asterisk is a wildcard rather than the regex quantifier it would be if the text + #reached grepl unchanged, which is what makes 'tile*' work at all + put_inputs(session, idx_filter = '*.zarr') + expect_match(session$getOutput('frames_info'), 'Frames in view: 2') +}, session = shiny::MockShinySession$new()) + +#ex 16 the frames tab. The plot is an interactive plotly panel, so what has to hold is the +#contract between the widget and the server: the footprints are drawn from index numbers +#alone, every vertex carries the id of the frame it belongs to, and a click or a box drag +#comes back through that id as a position. The panel sits in a tab Shiny keeps suspended, +#so it is read here as the JSON the renderer hands to the browser +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + spec_of = function() jsonlite::fromJSON( + paste(as.character(session$getOutput('frames')), collapse = ''), + simplifyVector = FALSE) + spec = spec_of() + #with no cutouts in memory at all the tab still renders, which is the point of drawing + #the footprints from the index rather than from the tiles + expect_false(is.null(spec)) + #one polyline trace carrying every footprint, one marker trace carrying the centres, and + #one trace held open for the clicked positions. A trace per tile would mean a trace per + #thousand tiles, so the count is the thing; that it stays at three whatever has been + #picked is what lets a click leave the zoom alone + expect_length(spec$x$data, 3) + expect_identical(spec$x$data[[1]]$mode, 'lines') + expect_identical(spec$x$data[[2]]$mode, 'markers') + expect_identical(spec$x$data[[3]]$mode, 'markers') + fr = app_env$index_footprints(as.data.frame(reactiveValuesToList(state)$rows)[ + reactiveValuesToList(state)$rows$status == 'ok', , drop = FALSE]) + n_ok = nrow(fr) + expect_gt(n_ok, 1) + expect_equal(length(spec$x$data[[2]]$x), n_ok) + #five vertices per ring (four corners and the closing point) with a NaN separator between + #rings, which is what stops plotly drawing a line from one tile to the next. The trailing + #separator is dropped on the way out, so the total is bounded rather than pinned to a + #plotly internal: what has to hold is that the payload stays the same length as the + #coordinates, and that every frame contributes exactly five vertices with an id + expect_equal(length(spec$x$data[[1]]$customdata), length(spec$x$data[[1]]$x)) + expect_gte(length(spec$x$data[[1]]$x), n_ok * 5) + expect_lte(length(spec$x$data[[1]]$x), n_ok * 6) + #the ids are row numbers of the unfiltered set, which is what keeps a pick pointing at + #the same tile when a filter takes other rows away. Numbers rather than store names + #because every one of those vertices carries one + cd = function(sp, trace) vapply(sp$x$data[[trace]]$customdata, + function(z) if(is.null(z)) NA_real_ else as.numeric(z), + numeric(1)) + expect_identical(cd(spec, 2), as.numeric(seq_len(n_ok))) + #and every vertex of a ring carries its own ring's id, so a box or lasso drag that catches + #an edge resolves to the right frame. The separator carries nothing + ring = cd(spec, 1) + expect_identical(ring[1:5], rep(1, 5)) + expect_true(is.na(ring[6])) + expect_identical(ring[7:11], rep(2, 5)) + #the RA axis runs backwards, the way a sky map is read, and it is the range that does it + xr = unlist(spec$x$layout$xaxis$range) + expect_gt(xr[1], xr[2]) + #equal degrees per pixel, so a square tile is drawn square rather than stretched to the + #panel by whatever shape the release happens to have + expect_identical(spec$x$layout$xaxis$scaleanchor, 'y') + #a box drag must be able to catch a tile in any direction, since a selection that only + #worked left to right would miss tiles on a reversed axis + expect_identical(spec$x$layout$selectdirection, 'any') + expect_identical(spec$x$layout$dragmode, 'zoom') + #the hover text names the tile, which is the one thing needed to identify what is under + #the cursor on a release of thousands of stores + hv = vapply(spec$x$data[[2]]$text, function(z) as.character(z), character(1)) + expect_true(all(grepl('tile', hv))) + expect_true(all(grepl('RA, Dec', hv))) + expect_true(all(grepl('extname', hv))) + + #a click anywhere is a position, given to the server by the browser as degrees rather + #than as the point plotly thinks was hit. This is the whole reason the coordinate is + #worked out client side: plotly's click event reports the coordinates of the nearest + #point, which would snap every pick to a tile centre or marker + click = function(ra, dec){ + put_inputs(session, frames_click = list(ra = ra, dec = dec, t = 1)) + } + before = paste(as.character(session$getOutput('frames')), collapse = '') + click(fr$ra[1] + 0.001, fr$dec[1] - 0.001) + expect_match(session$getOutput('frames_info'), 'Picked by click: 1') + #the panel is not redrawn by a click, which is the whole point of drawing the pick + #through the proxy: a re-render reconciles a new specification against the panel on + #screen, and that is what used to snap the view back out to the full extent + expect_identical(paste(as.character(session$getOutput('frames')), collapse = ''), before) + #a second click adds to the list rather than replacing it + click(fr$ra[2] + 0.002, fr$dec[2] + 0.002) + expect_match(session$getOutput('frames_info'), 'Picked by click: 2') + #clicking the same position twice must not duplicate it + click(fr$ra[2] + 0.002, fr$dec[2] + 0.002) + expect_match(session$getOutput('frames_info'), 'Picked by click: 2') + #a click whose coordinates never arrived is ignored rather than picked as NA + click(NA, NA) + expect_match(session$getOutput('frames_info'), 'Picked by click: 2') + + #what goes to the Cutouts tab is the position that was clicked, to the rounding used + put_inputs(session, send_pos = 1) + session$flushReact() + log = paste(reactiveValuesToList(state)$log, collapse = '\n') + expect_match(log, 'Sent 2 clicked position') + expect_match(log, paste(signif(fr$ra[1] + 0.001, 9), signif(fr$dec[1] - 0.001, 9)), + fixed = TRUE) + #and it is not the centre of the nearest tile, which is what it used to be + expect_false(grepl(paste(signif(fr$ra[1], 9), signif(fr$dec[1], 9)), log, fixed = TRUE)) + + #a box selection resolves through the ids of the points it caught. The two traces each + #carry a point per frame, so the same frame arrives twice and must still be one row + put_inputs(session, 'plotly_selected-frames' = as.character(jsonlite::toJSON( + list(list(curveNumber = 0L, pointNumber = 3L, x = fr$ra[2], y = fr$dec[2], + customdata = 2), + list(curveNumber = 1L, pointNumber = 0L, x = fr$ra[1], y = fr$dec[1], + customdata = 1), + list(curveNumber = 1L, pointNumber = 1L, x = fr$ra[2], y = fr$dec[2], + customdata = 2)), auto_unbox = TRUE))) + session$flushReact() + info = session$getOutput('frames_info') + expect_match(info, 'Selected by box: 2') + expect_match(info, 'Selected: tile1, tile2') + #the box reported is the extent of what was caught, with the smaller bound first + #whatever way the drag went, since the RA axis is reversed + lo = as.numeric(sub('.*Selection box: ([-0-9.]+) to .*', '\\1', info)) + hi = as.numeric(sub('.*Selection box: [-0-9.]+ to ([-0-9.]+) RA.*', '\\1', info)) + expect_lt(lo, hi) + expect_equal(c(lo, hi), range(c(fr$xmin[1:2], fr$xmax[1:2])), tolerance = 1e-3) + #sending a selection sends the frames in it, not the centre of the box + put_inputs(session, send_sel = 1) + session$flushReact() + log = paste(reactiveValuesToList(state)$log, collapse = '\n') + expect_match(log, 'Sent 2 selected frame centre') + + #clearing the clicked list is deliberate, and leaves the box selection alone: a legend + #toggle or a stray click must not throw away a list the user built + put_inputs(session, clear_picks = 1) + session$flushReact() + info = session$getOutput('frames_info') + expect_match(info, 'Picked by click: 0') + expect_match(info, 'Selected by box: 2') + + #the Index tab's filters apply here too, so a session narrowed by name shows the same + #tiles in both places. The surviving frame keeps the id it was given in the unfiltered + #set, which is what keeps a box selection pointing at the right tile + put_inputs(session, idx_filter = 'tile2') + session$flushReact() + spec = spec_of() + expect_equal(length(spec$x$data[[2]]$x), 1) + expect_equal(as.numeric(spec$x$data[[2]]$customdata[[1]]), 2) + expect_match(session$getOutput('frames_info'), 'Frames in view: 1') + #the box now holds only the frame that is still in the view + expect_match(session$getOutput('frames_info'), 'Selected by box: 1') + #with nothing clicked left, sending adds no position at all rather than a stale one + put_inputs(session, send_pos = 2) + session$flushReact() + log = paste(reactiveValuesToList(state)$log, collapse = '\n') + expect_equal(sum(grepl('clicked position', strsplit(log, '\n')[[1]])), 1L, + info = 'only the earlier send should be in the log') +}, session = shiny::MockShinySession$new()) + +#ex 16b the Frames tab before anything is loaded. A panel with no index behind it has to +#say so in words rather than leaving a blank box, which reads as a broken app rather than +#as an empty one, and no button may invent a position out of nothing +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + session$flushReact() + expect_match(session$getOutput('frames_info'), 'Load an index on the Store tab first') + #the plot and the table have nothing to draw, and say so by interrupting quietly rather + #than by erroring loudly or showing a stale panel + cond = tryCatch(session$getOutput('frames'), error = function(e) e) + expect_true(inherits(cond, 'shiny.silent.error')) + #a click arriving with no index behind it changes nothing about what the tab says, and + #neither Send button may invent a position out of nothing. The id is recorded in picks, + #which is harmless because loading an index clears them before it can be resolved + put_inputs(session, 'plotly_click-frames' = as.character(jsonlite::toJSON( + list(list(curveNumber = 1L, pointNumber = 0L, x = 1, y = 1, customdata = 1)), + auto_unbox = TRUE))) + session$flushReact() + expect_match(session$getOutput('frames_info'), 'Load an index on the Store tab first') + put_inputs(session, send_pos = 1, send_sel = 1) + session$flushReact() + expect_match(session$getOutput('frames_info'), 'Load an index on the Store tab first') + log = paste(reactiveValuesToList(state)$log, collapse = '\n') + expect_false(grepl('frame centre\\(s\\) to the Cutouts tab', log)) +}, session = shiny::MockShinySession$new()) + +#ex 17 credentials. A blank field falls back to the environment, which is how a scripted +#run and this app come by the same keys without them being typed into a form, and a typed +#field wins over the environment. Restored explicitly rather than with on.exit, which does +#not reliably belong to a frame at the top level of a test file +want = c('RFITS_S3_REGION', 'RFITS_S3_ACCESS_KEY') +was = Sys.getenv(want, unset = NA) +Sys.setenv(RFITS_S3_REGION = 'ap-southeast-2', RFITS_S3_ACCESS_KEY = 'ENVKEY') +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + creds = reactiveValuesToList(state)$con$creds + expect_identical(creds$region, 'ap-southeast-2') + expect_identical(creds$access_key, 'ENVKEY') + put_inputs(session, region = 'eu-west-1', access_key = 'FIELDKEY', load = 2) + session$flushReact() + creds = reactiveValuesToList(state)$con$creds + expect_identical(creds$region, 'eu-west-1') + expect_identical(creds$access_key, 'FIELDKEY') +}, session = shiny::MockShinySession$new()) +#A variable that was unset goes away again rather than being left as an empty string, +#which the app would read as absent anyway but which would confuse a later block +for(name in want){ + if(is.na(was[[name]])){ + Sys.unsetenv(name) + }else{ + do.call(Sys.setenv, stats::setNames(list(was[[name]]), name)) + } +} +#and with nothing in the environment, the fields are the only source, so a blank form +#yields blank credentials rather than a stale value. Only checked when the variable really +#is unset on this machine, since a run that has the S3 credentials in its environment +#would legitimately pick them up here +if(is.na(was[['RFITS_S3_REGION']])){ + testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + creds = reactiveValuesToList(state)$con$creds + expect_null(creds$region) + expect_null(creds$endpoint) + }, session = shiny::MockShinySession$new()) +} + +#ex 18 a bucket and a directory together is refused before anything is contacted, because +#the two back ends disagree about what a store name means +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, bucket = 'somewhere', load = 1) + session$flushReact() + expect_true(is.null(reactiveValuesToList(state)$idx)) + expect_match(paste(reactiveValuesToList(state)$log, collapse = '\n'), 'not both') + #and neither of them is also refused, with a message that says which + put_inputs(session, bucket = '', dir = '', load = 2) + session$flushReact() + expect_match(paste(reactiveValuesToList(state)$log, collapse = '\n'), + 'Give a bucket \\(with credentials\\) or a local directory') +}, session = shiny::MockShinySession$new()) + +#ex 19 rebuild ignores an index that is already there. The checkbox is the only way to +#notice a store whose tiles changed underneath a published index, and the rebuilt copy is +#the session's own file rather than the published one +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, load = 1) + session$flushReact() + published = reactiveValuesToList(state)$idx$path + expect_false(is.null(published)) + put_inputs(session, rebuild = TRUE, load = 2) + session$flushReact() + s = reactiveValuesToList(state) + expect_true(s$idx$built) + expect_false(identical(s$idx$path, published)) + #the published index is untouched by a rebuild, which is the point + expect_true(file.exists(published)) + expect_match(paste(s$log, collapse = '\n'), 'Rebuilding the index') +}, session = shiny::MockShinySession$new()) + +#ex 20 the downloads. Both bundle with a write then archive, two steps, and the temporary +#directory has to outlive the first to be there for the second. This reaches into +#MockShinySession's private registry, so it is skipped if that moves rather than failing a +#run over a detail of the test harness +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.02, ' ', img_kv$CRVAL2, '\n', + img_kv$CRVAL1, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + expect_length(reactiveValuesToList(state)$res, 2L) + priv = session$.__enclos_env__$private + if(is.null(priv) || is.null(priv$file_generators)){ + skip('this shiny version does not expose registered downloads') + } + if(!requireNamespace('zip', quietly = TRUE)){ + skip('zip is needed to check the bundles') + } + keys = priv$file_generators$keys() + expect_true(any(grepl('dl_fits', keys))) + expect_true(any(grepl('dl_jpeg', keys))) + #The JPEG bundle is registered, but it is not written and checked here for the moment. + #On the macOS runner its content() returns without producing an archive: the jpeg device + #does not open, so the cutout is drawn to R's automatic fallback pdf device instead and + #no .jpg exists for write_all() to zip, which returns NULL and leaves content() to exit + #quietly rather than error. The check directory of the failing run holds the evidence, a + #stray Rplots.pdf whose one image is 51x51 px (the cutout, with useRaster) on a 7x7 inch + #page, not the 6x6 inch one jpeg() was asked for: + #https://github.com/asgr/Rfits/actions/runs/36117476840/job/108014846816 + #The real reason is swallowed by with_capture() into state$log as 'could not write', so + #the test can only report the missing archive. Linux and Windows skip this whole file + #because zarr will not load there, so macOS is the only job that reaches this block and + #the only one that fails. Revisit the device handling in jpeg_args() and then restore + #the selector below to widen the loop back over both bundles. + #for(key in keys[grepl('dl_fits|dl_jpeg', keys)]){ + for(key in keys[grepl('dl_fits', keys)]){ + gen = priv$file_generators$get(key) + dest = tempfile(fileext = '.zip') + expect_no_error(gen$content(dest)) + #an archive that was written but left empty is the failure mode to catch here + expect_gt(file.size(dest), 0) + listed = zip::zip_list(dest) + expect_equal(nrow(listed), 2L) + expect_true(all(listed$type == 'file')) + #names come from the results, so the two bundles describe the same cutouts + expect_equal(sub('[.](fits|jpg)$', '', listed$filename), names(reactiveValuesToList(state)$res)) + ext = if(grepl('fits', key)) '[.]fits$' else '[.]jpg$' + expect_equal(sum(grepl(ext, listed$filename)), 2L) + } +}, session = shiny::MockShinySession$new()) + +#ex 21 the FITS download specifically, read back from the archive. This is the one place +#the app hands someone a file they will use elsewhere, so the pixels and the WCS both have +#to come out the far end intact +if(requireNamespace('zip', quietly = TRUE)){ + testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1 + 0.02, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + priv = session$.__enclos_env__$private + if(is.null(priv) || is.null(priv$file_generators)){ + skip('this shiny version does not expose registered downloads') + } + keys = priv$file_generators$keys() + gen = priv$file_generators$get(keys[grepl('dl_fits', keys)]) + dest = tempfile(fileext = '.zip') + gen$content(dest) + out = file.path(tempdir(), 'app_unzip') + dir.create(out, showWarnings = FALSE) + zip::unzip(dest, exdir = out) + files = list.files(out, pattern = '[.]fits$', full.names = TRUE) + expect_length(files, 1L) + back = Rfits_read_image(files[1]) + #the cutout, not the parent tile + expect_identical(dim(back$imDat), c(51L, 51L)) + expect_equal(back$keyvalues$CRVAL1, img_kv$CRVAL1, tolerance = 1e-6) + expect_equal(pixscale(back), pixscale(src_image), tolerance = 1e-4) + #the box was centred where it was asked for, which only holds if the WCS survived + cen = centre(back) + expect_equal(unname(cen[1, 'RA']), unname(img_kv$CRVAL1 + 0.02), tolerance = 0.01) + expect_equal(unname(cen[1, 'Dec']), unname(img_kv$CRVAL2), tolerance = 0.01) + }, session = shiny::MockShinySession$new()) +} + +#ex 22 a session index file must not be left behind. A remote or rebuilt index is the +#app's own temporary file, and one per page reload would accumulate for the life of the R +#process on a server hosting many users +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, rebuild = TRUE, load = 1) + session$flushReact() + path = reactiveValuesToList(state)$idx$path + expect_true(file.exists(path)) + session$close() + expect_false(file.exists(path)) +}, session = shiny::MockShinySession$new()) + +#ex 23 the brush fields, checked against the app text as well as behaviourally. Shiny's +#brush object has xmin/xmax/ymin/ymax and never a range vector, so reading one off the +#brush is the bug that made the Frames tab answer 'Inf to -Inf' and select nothing. The +#grep looks for the field access rather than the words, because the comment on the helper +#that replaced it has to be allowed to name what it fixed +expect_false(any(grepl('br$xrange|br$yrange|\\$xrange|\\$yrange', app_text))) + +#ex 24 the gallery draws each cutout as a square cell in a grid rather than as a full +#width panel, which is what stopped every cutout being a wide letter box +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + cut_width = 280, load = 1, run = 1) + session$flushReact() + expect_length(reactiveValuesToList(state)$res, 1L) + html = paste(as.character(session$getOutput('gallery')), collapse = '\n') + expect_match(html, 'rf-cut-grid', fixed = TRUE) + expect_match(html, 'rf-cut-cell', fixed = TRUE) + expect_match(html, 'rf-cut', fixed = TRUE) + #the requested side reaches both the grid template and the cell cap + expect_match(html, '280px', fixed = TRUE) + expect_match(html, 'id="cutplot_1"', fixed = TRUE) + #height is given as a percentage so the plot fills the square wrapper, rather than as a + #pixel height that would make the drawing area as wide as the column + expect_match(html, 'height:100%', fixed = TRUE) +}, session = shiny::MockShinySession$new()) + +#ex 25 the display controls are live and capped. Only max_show panels are registered, but +#the message has to say so rather than leave the user counting +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + put_inputs(session, max_show = 1) + session$flushReact() + html = paste(as.character(session$getOutput('gallery')), collapse = '\n') + expect_match(html, 'id="cutplot_1"', fixed = TRUE) + put_inputs(session, max_show = 0) + session$flushReact() + expect_no_error(session$getOutput('gallery')) + #a silly width falls back rather than producing a zero sized grid + put_inputs(session, cut_width = 1) + session$flushReact() + html = paste(as.character(session$getOutput('gallery')), collapse = '\n') + expect_match(html, 'minmax\\(min\\(100%, [0-9]+px\\), 1fr\\)') +}, session = shiny::MockShinySession$new()) + +#ex 26 the store each cutout came from is reported in the form a user recognises. For a +#local directory that is the path, and it is what the caption under each panel shows +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + res = reactiveValuesToList(state)$res + expect_identical(length(attr(res, 'filename')), length(res)) + expect_match(attr(res, 'filename')[1], 'tile1[.]zarr') + #and the caption in the gallery carries it + html = paste(as.character(session$getOutput('gallery')), collapse = '\n') + expect_match(html, 'tile1[.]zarr') +}, session = shiny::MockShinySession$new()) + +#ex 27 a candidate store that opens cleanly but holds no overlap must be named. This is +#the difference between 'the release does not cover that position' and a result that looks +#quietly lost, which is what two tiles and one picture used to read as. At box = 400 the +#index offers both tiles because a 400 pixel box centred on tile1 reaches into tile2's +#neighbourhood, but tile2's own footprint does not cover the position, so it is scanned, +#answers nothing, and has to be reported as scanned rather than as an error +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + box = 400, max_stores = 25, load = 1) + session$flushReact() + put_inputs(session, run = 1) + session$flushReact() + s = reactiveValuesToList(state) + log = paste(s$log, collapse = '\n') + #one cutout, from the tile that actually covers the position + expect_length(s$res, 1L) + expect_match(names(s$res)[1], 'tile1') + #the store that was scanned but did not overlap is named in that same sentence, which is + #the assertion that matters: a bare mention of tile2 anywhere in the log would pass even + #if the reporting were removed, because the index build names every store it visits + line = grep('no overlap at the requested position', strsplit(log, '\n')[[1]], value = TRUE) + expect_length(line, 1L) + expect_match(line[1], 'tile2') +}, session = shiny::MockShinySession$new()) + + +#ex 28 which cutouts go into a bundle. The selection is one logical vector with three +#ways of writing it -- the buttons, the tick beside each plotted cutout, and the row +#checkboxes of the results table -- so what has to hold is that they agree, that a new run +#starts from everything included, and that the count on the page tracks all of it +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.05, ' ', img_kv$CRVAL2, '\n', + img_kv$CRVAL1, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + res = reactiveValuesToList(state)$res + expect_length(res, 2L) + #a fresh run includes everything, whatever the last run's ticks said + expect_identical(reactiveValuesToList(state)$sel, rep(TRUE, 2L)) + expect_equal(n_selected(), 2L) + #ids carry the run number, so a box left on the page from an earlier, longer request + #cannot be read as a tick against this one + expect_equal(cell_id(1), 'sel_1_1') + + #untick one cell through the box beside it + put_inputs(session, sel_1_1 = TRUE, sel_1_2 = FALSE) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, FALSE)) + expect_equal(n_selected(), 1L) + expect_identical(names(selected_res()), names(res)[1]) + #and the count is shown + #helpText interleaves the values and the literals across lines, so the match is loose + expect_match(paste(as.character(session$getOutput('sel_count')), collapse = ' '), + '1\\s+of\\s+2') + + #Include none, then invert. Both have to survive the boxes on the page still reporting + #their old values, which is what a round trip through the pushed update looks like + put_inputs(session, sel_none = 1) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, FALSE)) + expect_equal(n_selected(), 0L) + put_inputs(session, sel_1_1 = FALSE, sel_1_2 = FALSE) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, FALSE)) + put_inputs(session, sel_invert = 1) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, TRUE)) + put_inputs(session, sel_1_1 = TRUE, sel_1_2 = TRUE) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, TRUE)) + put_inputs(session, sel_none = 1) + put_inputs(session, sel_all = 1) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, TRUE)) + + #a tick on a cell that has not been drawn yet must not be read at all, since a partial + #set would otherwise clear the results that are included but off screen + put_inputs(session, max_show = 1) + put_inputs(session, sel_1_1 = TRUE) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, TRUE)) + put_inputs(session, sel_1_1 = FALSE) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, TRUE)) + put_inputs(session, max_show = 24) + + #one tick in the results table, reported as the index of the cutout in the result list + #rather than as a row number, since the rows get sorted and filtered in the browser + put_inputs(session, sel_none = 1) + put_inputs(session, sel_1_1 = FALSE, sel_1_2 = FALSE) + put_inputs(session, match_tick = list(i = 2, on = TRUE)) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, TRUE)) + #a change outside the current result list is ignored rather than recycled + put_inputs(session, match_tick = list(i = 99, on = TRUE)) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, TRUE)) + put_inputs(session, match_tick = list(i = 2, on = FALSE)) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, FALSE)) + + #a run that returns a different number of cutouts resets to all in + put_inputs(session, sel_none = 1) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), run = 2) + session$flushReact() + expect_equal(cell_id(1), 'sel_2_1') + expect_identical(reactiveValuesToList(state)$sel, rep(TRUE, 1L)) + #the previous run's unticked box is stale and must not be read against this one + put_inputs(session, sel_1_1 = FALSE) + expect_identical(reactiveValuesToList(state)$sel, TRUE) +}, session = shiny::MockShinySession$new()) + +#ex 28b the selection is pushed back to the page, including to every box on it. The state +#on its own is not enough: 'Include none' has to clear the boxes as well, or the boxes +#report their old ticks back on the next flush and undo the button. That is the bug the +#count beside the buttons was hiding, because the count reads the state and the pictures +#read the page. +# +#updateCheckboxInput is replaced with something that records what was asked for. It has to +#be put in the environment the app was sourced into rather than in the testServer body, +#because an observer looks the name up in the environment it was created in, which is that +#one and not the one this expression runs in +tick_pushes = list() +app_env$updateCheckboxInput = function(session, inputId, ..., value){ + tick_pushes[[length(tick_pushes) + 1]] <<- list(id = inputId, value = value) + invisible(NULL) +} +withr::defer(rm(updateCheckboxInput, envir = app_env), teardown_env()) + +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.05, ' ', img_kv$CRVAL2, '\n', + img_kv$CRVAL1, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + tick_pushes <<- list() + + #both boxes are rewritten whenever the selection moves, and only the unticked one differs + put_inputs(session, sel_1_1 = TRUE, sel_1_2 = FALSE) + #asserted before anything else, because every check below reads the same list and all() + #over an empty one is true, so a shadow that never fired would otherwise pass quietly + expect_gte(length(tick_pushes), 2L) + ids = vapply(tick_pushes, function(x) x$id, character(1)) + expect_true(all(c('sel_1_1', 'sel_1_2') %in% ids)) + vals = setNames(lapply(tick_pushes, function(x) x$value), ids) + expect_false(isTRUE(vals$sel_1_2)) + expect_true(isTRUE(vals$sel_1_1)) + + #Include none is the case that used to be lost. An all FALSE vector is falsy, so a req() + #on the selection aborted the push and the page never heard about it + tick_pushes <<- list() + put_inputs(session, sel_none = 1) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, FALSE)) + ids = vapply(tick_pushes, function(x) x$id, character(1)) + expect_true(all(c('sel_1_1', 'sel_1_2') %in% ids)) + expect_true(all(!vapply(tick_pushes, function(x) isTRUE(x$value), logical(1)))) + + #the boxes follow the state rather than the other way round: once they have been told, + #reporting them settles the selection instead of oscillating + put_inputs(session, sel_1_1 = FALSE, sel_1_2 = FALSE) + expect_identical(reactiveValuesToList(state)$sel, c(FALSE, FALSE)) + tick_pushes <<- list() + put_inputs(session, sel_all = 1) + expect_true(all(vapply(tick_pushes, function(x) isTRUE(x$value), logical(1)))) + put_inputs(session, sel_1_1 = TRUE, sel_1_2 = TRUE) + expect_identical(reactiveValuesToList(state)$sel, c(TRUE, TRUE)) +}, session = shiny::MockShinySession$new()) + +#ex 28c the results table carries a real column of checkboxes. DT's own row selection is +#only a highlight, so the boxes a user is meant to click are drawn by the app +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.05, ' ', img_kv$CRVAL2, '\n', + img_kv$CRVAL1, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + skip_if_not(app_env$has_dt, 'DT is not installed') + html = paste(as.character(session$getOutput('match_table')), collapse = '\n') + #the widget payload is JSON, so the quotes inside a cell arrive escaped; they are not + #what is being asserted and unescaping them keeps the patterns readable + html = gsub('\\\\', '', html) + expect_match(html, 'rf-tick', fixed = TRUE) + expect_equal(length(gregexpr('type="checkbox"', html, fixed = TRUE)[[1]]), 2L) + #each box carries the index of its cutout, and starts ticked because the run did + expect_match(html, 'data-rf-i="1"', fixed = TRUE) + expect_match(html, 'data-rf-i="2"', fixed = TRUE) + expect_match(html, 'checked', fixed = TRUE) + #and the callback that wires them up is in the widget, not lost between renderers + expect_match(html, 'match_tick', fixed = TRUE) + expect_match(html, 'rf_set_ticks', fixed = TRUE) +}, session = shiny::MockShinySession$new()) + +#ex 29 the download options. The compression string is what cfitsio parses out of the file +#name, so its shape is worth pinning: the algorithm, then the tile sizes, then a semicolon +#and the quantization level +testServer(app_env$server, expr = { + expect_equal(dl_opts()$fits_format, 'raw') + expect_equal(comp_spec(list(alg = 'RICE', tile = '', quant = NA_real_)), 'RICE') + #the box is typed by a person, so spaces and a stray comma are tidied rather than + #passed through into the name cfitsio will parse + expect_equal(comp_spec(list(alg = 'RICE', tile = ' 64, 64 ', quant = NA_real_)), + 'RICE 64,64') + expect_equal(comp_spec(list(alg = 'RICE', tile = '64 64,', quant = NA_real_)), + 'RICE 64,64') + expect_equal(comp_spec(list(alg = 'RICE', tile = '64,64', quant = 8)), + 'RICE 64,64; q 8') + expect_equal(comp_spec(list(alg = 'HCOMPRESS', tile = '', quant = -0.0002)), + 'HCOMPRESS; q -0.0002') + #0 has to survive as text, since it is the difference between lossy and lossless + expect_equal(comp_spec(list(alg = 'GZIP', tile = '', quant = 0)), 'GZIP; q 0') + #a quality outside the device's range is pulled back rather than passed on + put_inputs(session, jpeg_quality = 500) + expect_equal(dl_opts()$jpeg_quality, 100) + put_inputs(session, jpeg_quality = NA) + expect_equal(dl_opts()$jpeg_quality, 75) +}, session = shiny::MockShinySession$new()) + +#ex 30 a compressed bundle, read back from the archive. The point of the option is that +#the file is smaller and still opens, so both halves are checked; the pixels may not be +#identical, because cfitsio quantizes unless told otherwise +if(requireNamespace('zip', quietly = TRUE)){ + testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + priv = session$.__enclos_env__$private + if(is.null(priv) || is.null(priv$file_generators)){ + skip('this shiny version does not expose registered downloads') + } + fits_gen = function(){ + keys = priv$file_generators$keys() + priv$file_generators$get(keys[grepl('dl_fits', keys)][1]) + } + raw = tempfile(fileext = '.zip') + fits_gen()$content(raw) + raw_dir = file.path(tempdir(), 'app_unzip_raw') + dir.create(raw_dir, showWarnings = FALSE) + zip::unzip(raw, exdir = raw_dir) + raw_file = list.files(raw_dir, pattern = '[.]fits$', full.names = TRUE) + expect_length(raw_file, 1L) + + put_inputs(session, fits_format = 'compress', fits_alg = 'GZIP', fits_tile = '', + fits_quant = 0) + #the name of the archive says what is in it, since raw and compressed are not + #interchangeable and a downloads folder will hold both + keys = priv$file_generators$keys() + gen = fits_gen() + expect_match(gen$filename(), 'compressed') + comp = tempfile(fileext = '.zip') + gen$content(comp) + comp_dir = file.path(tempdir(), 'app_unzip_comp') + dir.create(comp_dir, showWarnings = FALSE) + zip::unzip(comp, exdir = comp_dir) + comp_file = list.files(comp_dir, pattern = '[.]fits$', full.names = TRUE) + expect_length(comp_file, 1L) + #a tile compressed image lives in a binary table, so it is read from extension 2 + back = Rfits_read_image(comp_file[1], ext = 2) + expect_identical(dim(back$imDat), c(51L, 51L)) + expect_equal(max(abs(back$imDat - Rfits_read_image(raw_file[1])$imDat)), 0, + tolerance = 1e-6) + expect_equal(back$keyvalues$CRVAL1, img_kv$CRVAL1, tolerance = 1e-6) + expect_true(isTRUE(back$keyvalues$ZIMAGE)) + #and the raw download of the same cutout stays a plain image + plain = Rfits_read_image(raw_file[1]) + expect_null(plain$keyvalues$ZIMAGE) + expect_identical(dim(plain$imDat), c(51L, 51L)) + }, session = shiny::MockShinySession$new()) +} + +#ex 31 a cutout whose header came from a tile compressed store must still download as a +#readable raw file. The shape a compressed store records is ZNAXIS, and Rfits_write_image +#honours ZIMAGE when it is in the keywords, so writing one out raw without stripping them +#gives a plain image that tells a reader to expect a binary table it does not hold +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + item = reactiveValuesToList(state)$res[[1]] + item$keyvalues$ZIMAGE = TRUE + item$keyvalues$ZBITPIX = -32 + item$keyvalues$ZNAXIS = 2L + item$keyvalues$ZNAXIS1 = 999 + item$keyvalues$ZNAXIS2 = 999 + item$keycomments$ZIMAGE = '' + item$keycomments$ZNAXIS1 = '' + item$keycomments$ZNAXIS2 = '' + item$keynames = names(item$keyvalues) + + stripped = prepare_fits_item(item, list(fits_format = 'raw')) + expect_null(stripped$keyvalues$ZIMAGE) + expect_null(stripped$keyvalues$ZNAXIS1) + #the shape is taken from the pixels, which is the only thing that can be authoritative + expect_identical(stripped$keyvalues$NAXIS1, nrow(item$imDat)) + expect_identical(stripped$keyvalues$NAXIS2, ncol(item$imDat)) + #a compressed download keeps the keys, since cfitsio rewrites them for real tiles + kept = prepare_fits_item(item, list(fits_format = 'compress')) + expect_true(isTRUE(kept$keyvalues$ZIMAGE)) + + #and the file it writes has to open, which is the assertion that catches the original + #failure rather than merely the bookkeeping around it + out = tempfile(fileext = '.fits') + Rfits_write_image(stripped, filename = out) + back = Rfits_read_image(out) + expect_identical(dim(back$imDat), dim(item$imDat)) + expect_equal(max(abs(back$imDat - item$imDat)), 0, tolerance = 1e-6) +}, session = shiny::MockShinySession$new()) + +#ex 32 an empty selection downloads nothing rather than everything, and says so. A user +#who has clicked Include none and then the download button needs to be told the two +#actions are the reason for the empty archive, not that the app lost the results +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + put_inputs(session, sel_none = 1) + expect_length(selected_idx(), 0L) + expect_null(selected_res()) + #write_all reports rather than writing an archive of nothing + wrote = write_all('fits', function(item, path){ + Rfits_write_image(item, filename = path) + }) + expect_null(wrote) + log = paste(reactiveValuesToList(state)$log, collapse = '\n') + expect_match(log, 'No cutouts are selected', fixed = TRUE) +}, session = shiny::MockShinySession$new()) + +#ex 33 every include box that the gallery draws is an input the server reads back, so a +#renamed id would silently leave the app unable to unselect anything. Checked against the +#rendered cell as well as the observers, because the id is built by a helper +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste(img_kv$CRVAL1, img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + html = paste(as.character(session$getOutput('gallery')), collapse = '\n') + expect_match(html, 'id="sel_1_1"', fixed = TRUE) + #the results card carries the three buttons and the count + bar = paste(as.character(session$getOutput('select_bar')), collapse = '\n') + for(id in c('sel_all', 'sel_none', 'sel_invert')){ + expect_match(bar, paste0('id="', id, '"'), fixed = FALSE) + } +}, session = shiny::MockShinySession$new()) + +#ex 34 the tables that have no callback of their own must still render. DT checks the +#callback argument against its own default and stops for anything else, NULL included, so +#naming it unconditionally errored the Index and Frames tables with "The 'callback' +#argument only accept a value returned from JS()". The default is left unset for those and +#supplied only by the results table, which needs one to report its tick boxes +testServer(app_env$server, expr = { + put_inputs(session, run_inputs) + put_inputs(session, positions = paste0(img_kv$CRVAL1 + 0.02, ' ', img_kv$CRVAL2), + load = 1, run = 1) + session$flushReact() + if(!app_env$has_dt){ + skip('DT is not installed') + } + #each of the three tables renders rather than erroring, which is the whole assertion: + #two of them have no callback and one does + for(id in c('index_table', 'frames_table', 'match_table')){ + expect_no_error(session$getOutput(id)) + } + #and the one that does carry a callback still carries it, since dropping it would leave + #the results table's boxes unable to report a change + html = paste(as.character(session$getOutput('match_table')), collapse = '') + expect_match(gsub('\\\\', '', html), 'match_tick', fixed = TRUE) +}, session = shiny::MockShinySession$new()) + +#ex 35 the payload that draws a clicked position on the Frames plot. plotly's restyle wants +#one value per trace, so the arrays have to be a list holding one array, {x: [[...]]}. A +#bare list() lets jsonlite unbox a length one vector, and a single pick then goes over the +#wire as a scalar that restyle cannot draw: the first click appeared to do nothing and the +#second drew two marks at once, because only then was the vector long enough to survive +#unboxing. Checked as the JSON Shiny would send rather than as the R object, since the +#unboxing is the bug and it happens on the way out +shape = function(ra, dec){ + as.character(shiny:::toJSON(list(x = app_env$pick_restyle_args(ra, dec)$x, + y = app_env$pick_restyle_args(ra, dec)$y))) +} +expect_identical(shape(numeric(0), numeric(0)), '{"x":[[]],"y":[[]]}') +#the decisive case: one pick must still arrive as an array of one +expect_identical(shape(53.1234, -27.8123), '{"x":[[53.1234]],"y":[[-27.8123]]}') +expect_identical(shape(c(1, 2, 3), c(4, 5, 6)), '{"x":[[1,2,3]],"y":[[4,5,6]]}') +#and never as the unboxed scalar, which is what the bare list() produced +expect_false(grepl('"x":\\[53', shape(53.1234, -27.8123))) diff --git a/tests/testthat/test_Rfits_zarr.R b/tests/testthat/test_Rfits_zarr.R index 395e36e..6a3609e 100644 --- a/tests/testthat/test_Rfits_zarr.R +++ b/tests/testthat/test_Rfits_zarr.R @@ -168,6 +168,206 @@ expect_error(Rfits_write_image_zarr(data_2d, file_chunk, extname = 'badchunk', expect_error(Rfits_write_image_zarr(data_2d, file_chunk, extname = 'badchunk', chunk_shape = c(2, 9)), 'chunk_shape') +#ex 11b the band splitter cuts whole chunks and covers the array exactly once. The +#bands are disjoint in chunk space, which is what lets a worker write one without +#reading anything another worker has written +bands_fn = Rfits:::.zarr_chunk_bands +band_cover = function(shape, chunk, nb){ + sel = bands_fn(shape, chunk, nb) + if(is.null(sel)){ + return(NULL) + } + #the band splitter cuts along one dimension only, so every other one spans the array + naxis = which(vapply(seq_along(shape), function(d) + any(vapply(sel, function(s) !identical(s[[d]], c(1L, as.integer(shape[d]))), logical(1))), + logical(1))) + grid = as.integer(ceiling(shape/chunk)) + g = array(seq_len(prod(grid)), grid) + claims = integer(prod(grid)) + for(s in sel){ + sub = do.call(`[`, c(list(g), lapply(seq_along(grid), function(d){ + if(d == naxis){ + seq(ceiling(s[[d]][1]/chunk[d]), ceiling(s[[d]][2]/chunk[d])) + }else{ + seq_len(grid[d])}}))) + claims[sub] = claims[sub] + 1L + } + return(list(naxis = naxis, nbands = length(sel), all = all(claims >= 1L), + once = all(claims == 1L))) +} +cover = band_cover(c(23, 17), c(5, 4), 4) +expect_identical(cover$naxis, 2L) +expect_true(cover$all) +expect_true(cover$once) +cover3 = band_cover(c(2, 10, 10), c(2, 5, 5), 3) +expect_identical(cover3$naxis, 3L) +expect_true(cover3$all) +expect_true(cover3$once) +#more workers than chunks only makes as many bands as there are chunks +expect_identical(bands_fn(c(10, 10), c(5, 5), 3)[[1]][[2]], c(1L, 5L)) +expect_length(bands_fn(c(10, 10), c(5, 5), 3), 2L) +#nothing to split when no dimension holds two chunks +expect_null(bands_fn(c(9, 9), c(10, 10), 4)) +expect_null(bands_fn(c(5), c(5), 4)) +#the split axis is the last splittable one, so a band stays contiguous in memory. Here +#dim 1 is a single chunk so cannot split, dims 2 and 3 both could, and 3 wins +c3 = bands_fn(c(2, 10, 10), c(2, 5, 5), 3)[[1]] +expect_identical(c3[[1]], c(1L, 2L)) +expect_identical(c3[[2]], c(1L, 10L)) +expect_identical(c3[[3]], c(1L, 5L)) + +#Whether the cores paths are exercised at all. Launching workers needs both halves below. +#NOT_CRAN is the opt-in devtools::test() and testthat::test_local() set, which is the +#skip_on_cran() idiom, but it is not enough on its own: devtools::check() sets NOT_CRAN and +#the Rproj passes --as-cran, so a check run reaches this file with NOT_CRAN true and a core +#limit in force at the same time. _R_CHECK_LIMIT_CORES_ then makes parallel refuse more than +#two processes rather than merely noting them, which is an error and not a skip. Both +#conditions are read here rather than calling skip_on_cran() because this file has no +#test_that() blocks, so a skip at top level abandons every expectation after it rather than +#one test. The result is that these run in the developer and test_local workflow and are +#quiet under R CMD check. A worker loads the installed package rather than a loaded one, +#which is also what makes these the only tests that can catch a symbol a worker cannot +#resolve. +cores_ok = identical(Sys.getenv('NOT_CRAN'), 'true') && + tolower(Sys.getenv('_R_CHECK_LIMIT_CORES_', '')) %in% c('', 'false') + +#ex 11c cores writes the same array as writing it in one, byte for byte. Small arrays +#are used on purpose, since the point is equivalence rather than speed +if(cores_ok){ + band_src_c = matrix(as.numeric(1:40000), 200, 200) + band_src_c[5, 5] = NA + band_serial_c = file.path(subdir, 'band_serial.zarr') + band_par_c = file.path(subdir, 'band_par.zarr') + Rfits_write_image_zarr(band_src_c, band_serial_c, extname = 'data1', + data_type = 'float32', chunk_shape = c(50, 50), clevel = 6, + keyvalues = list(TEST = 1), keycomments = list(TEST = 'c')) + band_res_c = Rfits_write_image_zarr(band_src_c, band_par_c, extname = 'data1', + data_type = 'float32', chunk_shape = c(50, 50), + clevel = 6, cores = 4, + keyvalues = list(TEST = 1), + keycomments = list(TEST = 'c')) + back_par = Rfits_read_image_zarr(band_par_c, extname = 'data1') + back_serial = Rfits_read_image_zarr(band_serial_c, extname = 'data1') + expect_equal(back_par$imDat, back_serial$imDat) + #the NA is the array fill value, so a band that did not cover it would show up here + expect_identical(is.na(back_par$imDat), is.na(band_src_c)) + expect_identical(back_par$keyvalues, back_serial$keyvalues) + expect_identical(band_res_c$dim, c(200L, 200L)) + #and the chunk files are the same bytes, not merely the same numbers + keys_s = sort(list.files(file.path(band_serial_c, 'data1'))) + keys_p = sort(list.files(file.path(band_par_c, 'data1'))) + expect_identical(keys_s, keys_p) + if(requireNamespace('digest', quietly = TRUE)){ + md5_keys = function(store, keys) vapply(keys, function(k) + digest::digest(readBin(file.path(store, 'data1', k), 'raw', 1e8), algo = 'md5'), '') + chunk_keys = setdiff(keys_s, 'zarr.json') + expect_identical(md5_keys(band_serial_c, chunk_keys), md5_keys(band_par_c, chunk_keys)) + } + #more cores than chunks is allowed, and the extra workers simply get nothing + expect_true(all(Rfits_write_image_zarr(band_src_c, file.path(subdir, 'band_many.zarr'), + extname = 'data1', data_type = 'float32', + chunk_shape = c(50, 50), clevel = 1, + cores = 16)$dim == c(200, 200))) + #cores says so rather than doing nothing quietly when there is nothing to split, which + #means one chunk in every dimension. The array must still be written correctly, by the + #serial path + nosplit = file.path(subdir, 'band_nosplit.zarr') + expect_message(Rfits_write_image_zarr(data_2d, nosplit, extname = 'data1', + chunk_shape = c(4, 6), cores = 4), + 'nothing to split') + expect_equal(Rfits_read_image_zarr(nosplit, extname = 'data1', header = FALSE), data_2d) + #the same for a store object, whose contents cannot be carried to a worker. This one + #would have been splittable, so the message is about the store and not the chunking + store_zarr = file.path(subdir, 'band_store.zarr') + store_obj = Rfits:::.zarr_store_new(store_zarr) + expect_message(Rfits_write_image_zarr(data_2d, store_obj, extname = 'data1', + chunk_shape = c(2, 3), cores = 4), + 'store object') + expect_equal(Rfits_read_image_zarr(store_zarr, extname = 'data1', header = FALSE), data_2d) + #appending is reported and done in one. The increment grows dimension 1, so two stacks + #of 2 x 6 make the 4 x 6 the array started as + band_app = file.path(subdir, 'band_app.zarr') + Rfits_write_image_zarr(data_2d[1:2, ], band_app, extname = 'stack', + chunk_shape = c(2, 3), data_type = 'float64') + expect_message(Rfits_write_image_zarr(data_2d[3:4, ], band_app, extname = 'stack', + append = TRUE, cores = 4), + 'append = TRUE') + expect_equal(Rfits_read_image_zarr(band_app, extname = 'stack', header = FALSE), data_2d) + #a bad cores value is refused before any worker is started + expect_error(Rfits_write_image_zarr(data_2d, file.path(subdir, 'band_badcores.zarr'), + extname = 'data1', cores = 0), 'cores') + #and it survives on the aliases, which are the same function + expect_equal(Rfits_write_cube_zarr(array(as.numeric(1:800), c(10, 10, 8)), + file.path(subdir, 'band_cube.zarr'), extname = 'data1', + chunk_shape = c(5, 5, 4), cores = 2, clevel = 1)$dim, + c(10, 10, 8)) + expect_equal(Rfits_read_image_zarr(file.path(subdir, 'band_cube.zarr'), extname = 'data1', + header = FALSE), array(as.numeric(1:800), c(10, 10, 8))) +} + +#ex 11d the band write, without launching a cluster. The worker body is called directly +#for each band, which is the part that has to be right: a worker resolves its own symbols +#and writes into a store it opened itself. The band split above is checked on its own, and +#a real cores run is the same code with the loop fanned out over processes +write_band_bands = function(src, store_path, chunk, cores = 4){ + bands = Rfits:::.zarr_chunk_bands(dim(src), chunk, cores) + expect_true(length(bands) > 0) + for(sel in bands){ + #The same slice the parallel path sends to a worker, drop = FALSE included: a band + #covering a whole axis of length one is otherwise flattened to a vector, and a store + #cannot broadcast that into its selection + band = do.call(`[`, c(list(src), lapply(sel, function(b) b[1]:b[2]), list(drop = FALSE))) + expect_identical(length(dim(band)), length(dim(src))) + Rfits:::.zarr_write_band(list(filename = store_path, + path = Rfits:::.zarr_name_to_path('data1'), + selection = sel, band = band)) + } +} +band_src = matrix(as.numeric(1:120), 20, 6) +band_src[5, 5] = NA +band_serial = file.path(subdir, 'band_body_serial.zarr') +band_written = file.path(subdir, 'band_body_par.zarr') +Rfits_write_image_zarr(band_src, band_serial, extname = 'data1', data_type = 'float32', + chunk_shape = c(5, 5), clevel = 6) +Rfits_write_image_zarr(band_src, band_written, extname = 'data1', data_type = 'float32', + chunk_shape = c(5, 5), clevel = 6) +write_band_bands(band_src, band_written, c(5L, 5L)) +expect_equal(Rfits_read_image_zarr(band_written, extname = 'data1', header = FALSE), + Rfits_read_image_zarr(band_serial, extname = 'data1', header = FALSE)) +#the NA is the array fill value, so a band that did not cover it would show up here +expect_identical(is.na(Rfits_read_image_zarr(band_written, extname = 'data1', + header = FALSE)), is.na(band_src)) +#an axis of length one is the case a band flattens, so it keeps its shape and its values +band_deg = matrix(as.numeric(1:20), 20, 1) +band_deg_path = file.path(subdir, 'band_body_deg.zarr') +Rfits_write_image_zarr(band_deg, band_deg_path, extname = 'data1', chunk_shape = c(4L, 1L)) +write_band_bands(band_deg, band_deg_path, c(4L, 1L), cores = 2) +expect_identical(dim(Rfits_read_image_zarr(band_deg_path, extname = 'data1', + header = FALSE)), c(20L, 1L)) +expect_equal(as.numeric(Rfits_read_image_zarr(band_deg_path, extname = 'data1', + header = FALSE)), as.numeric(1:20)) + +#ex 11e the same thing through a real cluster. The worker body above is called in this +#process, so it cannot catch the case that actually broke: a worker reaching for something +#that lives in the namespace but is not attached, which fails on every band before a pixel +#is written. This is the only test that exercises that path. +# +#Guarded by the same switch as ex 11c. It also needs the installed package rather than a +#loaded one, since a worker loads what is installed, so under load_all it is the installed +#copy that is checked against the source. +if(cores_ok && requireNamespace('Rfits', quietly = TRUE)){ + band_par = file.path(subdir, 'band_par.zarr') + band_par_res = Rfits_write_image_zarr(band_src, band_par, extname = 'data1', + data_type = 'float32', chunk_shape = c(5, 5), + clevel = 6, cores = 2) + expect_identical(band_par_res$dim, c(20L, 6L)) + expect_equal(Rfits_read_image_zarr(band_par, extname = 'data1', header = FALSE), + Rfits_read_image_zarr(band_serial, extname = 'data1', header = FALSE)) + #the NA still lands where it was put, so no band silently wrote over another's + expect_identical(is.na(Rfits_read_image_zarr(band_par, extname = 'data1', + header = FALSE)), is.na(band_src)) +} + #ex 12 pointers read only what is asked of them point = Rfits_point_zarr(file_dims, extname = 'data4') expect_identical(class(point), 'Rfits_pointer_zarr') @@ -637,7 +837,7 @@ expect_message(Rfits_write_image_zarr(inc, file_app, extname = 'data1', append = #ex 38 compressor mapping, and the recorded level is the applied level file_comp = file.path(subdir, 'codecs.zarr') codec_of = function(path, extname){ - zarr::open_zarr(path, protocol = 'local', read_only = TRUE)$get_node(.zarr_name_to_path(extname)) + zarr::open_zarr(path, protocol = 'local', read_only = TRUE)$get_node(Rfits:::.zarr_name_to_path(extname)) } for(name in c('blosc', 'blosclz', 'lz4', 'lz4hc', 'zstd')){ ext = paste0('c_', name) @@ -887,6 +1087,85 @@ expect_error(Rfits_dir_to_zarr(dir = empty_dir, target = batch_out), 'No FITS fi expect_error(Rfits_dir_to_zarr(dir = file.path(subdir, 'no_such_dir'), target = batch_out), 'Directory does not exist') +#ex 47b cores converts several files at once, and must agree with doing them one by +#one. A worker that failed to load Rfits would show up as an error row rather than a +#silent success, which is what checking the table as well as the pixels buys here +par_out = file.path(subdir, 'batch_par') +#a bad cores value is refused before any worker is started, so this one needs no gate +expect_error(Rfits_dir_to_zarr(dir = batch_dir, target = par_out, cores = 0), 'cores') +#Everything below launches processes, and so is gated on cores_ok for the reason given +#there: a CRAN incoming check sets _R_CHECK_LIMIT_CORES_ and asks a package not to +if(cores_ok){ + par = Rfits_dir_to_zarr(dir = batch_dir, target = par_out, recursive = FALSE, + cores = 2, verbose = FALSE) + expect_identical(nrow(par), 2L) + expect_true(all(par$status == 'ok')) + #the order is the order of the files given, not the order the workers finished in + expect_identical(basename(par$store), basename(batch$store)) + for(name in basename(batch$store)){ + expect_equal(Rfits_read_image_zarr(file.path(par_out, name), extname = 'data1')$imDat, + Rfits_read_image_zarr(file.path(batch_out, name), + extname = 'data1')$imDat) + } + #more cores than files is allowed, and the extra workers simply get nothing + expect_true(all(Rfits_dir_to_zarr(dir = batch_dir, target = par_out, recursive = FALSE, + cores = 8, verbose = FALSE)$status == 'ok')) + #one unreadable file among good ones is still recorded against the right row. This is + #the case a parallel batch gets wrong most easily: the rows have to stay aligned with + #the files they describe however the workers finish. missing.fits is absent on purpose, + #which is the same fixture ex 46 uses for the serial path + mix_par = Rfits_dir_to_zarr(filelist = c(file.path(batch_dir, 'image_one.fits'), + file.path(batch_dir, 'missing.fits'), + file.path(batch_dir, 'cube_one.fits')), + target = par_out, cores = 3, verbose = FALSE) + expect_identical(mix_par$status, c('ok', 'error', 'ok')) + expect_true(grepl('readable', mix_par$error[2])) + expect_identical(basename(mix_par$store)[2], 'missing.zarr') +} +#the cluster a cores run makes belongs to that call alone, so whatever backend the +#session has is neither used nor disturbed. A leftover registration would be a real +#hazard rather than a tidy one, since the next %dopar% would then be handed processes +#that have already exited. getDoParName is NULL before anything has been attached and +#a string after, hence the collapsing rather than comparing the values directly +par_backend = function() paste(foreach::getDoParName(), collapse = '/') +before_name = par_backend() +before_workers = as.integer(foreach::getDoParWorkers()) +if(cores_ok){ + Rfits_dir_to_zarr(dir = batch_dir, target = par_out, recursive = FALSE, + cores = 2, verbose = FALSE) + expect_identical(par_backend(), before_name) + expect_identical(as.integer(foreach::getDoParWorkers()), before_workers) +} +#and a batch of its own still runs beside a cluster the caller registered. This one +#replaces the session's backend while it runs, which is a second reason to keep it behind +#the switch: the restore below is best effort, and a CRAN incoming check is not the place +#to find out it was not enough +if(cores_ok){ + registered_run = local({ + entry = par_backend() + on.exit({ + doParallel::stopImplicitCluster() + if(identical(entry, 'doSEQ') || is.null(entry)) foreach::registerDoSEQ() + }) + doParallel::registerDoParallel(cores = 2) + par2 = Rfits_dir_to_zarr(dir = batch_dir, target = par_out, recursive = FALSE, + cores = 2, verbose = FALSE) + #checked here rather than after the on.exit, since that is what this is about: the + #cores call must not have replaced the cluster the caller registered + workers = as.integer(foreach::getDoParWorkers()) + ser2 = Rfits_dir_to_zarr(dir = batch_dir, target = par_out, recursive = FALSE, + verbose = FALSE) + return(list(par = all(par2$status == 'ok'), ser = all(ser2$status == 'ok'), + workers = workers, name = par_backend())) + }) + expect_true(registered_run$par) + expect_true(registered_run$ser) + #the caller's cluster is left with its own worker count, i.e. not replaced. The name + #depends on the platform, since cores gives fork workers unless they are unavailable + expect_identical(registered_run$workers, 2L) + expect_false(identical(registered_run$name, 'doSEQ')) +} + # --- Searching a directory of stores by position (Rfits_cutout_zarr_dir) ----------- #ex 48 a 3x3 grid of 200x200 tiles at 1 arcsec/pixel, built straight into Zarr with a @@ -1193,21 +1472,34 @@ expect_error(Rfits_cutout_zarr_dir(dir = cut_dir, RA = 1, Dec = 1, extname = cha expect_error(cut_silent(dir = cut_dir, pattern = 'nothing_here', RA = 1, Dec = 1), 'No Zarr stores found') -#ex 57 the metadata cache. Reading it must give exactly the same answer as not having -#it, and must survive a filtered run without losing the stores that run skipped +#ex 57 the metadata cache, which is a parquet index of the search metadata of each store. +#Reading it must give exactly the same answer as not having it, and must survive a +#filtered run without losing the stores that run skipped +skip_if_not_installed("arrow") cache_file = file.path(subdir, 'cutout_cache.rds') +#The .rds name is the one a caller of the older cache format already has, and is +#deliberately left in place below to check that it resolves rather than being doubled up +cache_parquet = Rfits:::.zarr_index_local_path(cache_file) +expect_identical(cache_parquet, file.path(subdir, 'cutout_cache.parquet')) cold = cut_silent(dir = cut_dir, RA = corner[1], Dec = corner[2], box = 101, cache = cache_file) warm = cut_silent(dir = cut_dir, RA = corner[1], Dec = corner[2], box = 101, cache = cache_file) -expect_true(file.exists(cache_file)) +expect_true(file.exists(cache_parquet)) expect_identical(names(cold), names(warm)) expect_identical(sort(names(warm)), sort(names(four))) filtered = cut_silent(dir = cut_dir, RA = corner[1], Dec = corner[2], box = 101, cache = cache_file, pattern = 'tile_[12]_1') expect_true(all(c('tile_1_1', 'tile_2_1') %in% names(filtered))) #the filtered run keeps the entries it did not visit -expect_length(readRDS(cache_file), 9) +index_rows = function(path){ + arrow::read_parquet(Rfits:::.zarr_index_local_path(path)) +} +stores_row = function(path){ + ix = index_rows(path) + ix[ix$kind == 'store', ] +} +expect_identical(nrow(stores_row(cache_parquet)), 9L) #a header that has genuinely changed is noticed, since local entries are checked #against the metadata file rather than trusted changed = cut_tile(2, 3) @@ -1253,9 +1545,15 @@ expect_identical(pwarm[[1]]$type, 'cube') expect_true(all(c('NAXIS3', 'CRPIX3', 'CRVAL3', 'CTYPE3') %in% names(pwarm[[1]]$keyvalues))) expect_identical(pwarm[[1]]$keyvalues$NAXIS3, 4L) -#the cache holds strictly more keywords than the record the search filters with -pent = readRDS(ptr_cache)[[1]] -expect_true(length(pent$info$full_keyvalues) > length(pent$info$keyvalues)) +#the index holds strictly more keywords than the record the search filters with, since +#the trimmed two-axis form cannot build a pointer for a cube +pent = Rfits:::.zarr_index_tile( + Rfits:::.zarr_index_light_rows(Rfits:::.zarr_index_local_path(ptr_cache))[1, ], + keyvalues = Rfits:::.zarr_index_payload_rows( + Rfits:::.zarr_index_local_path(ptr_cache), + Rfits:::.zarr_index_light_rows(Rfits:::.zarr_index_local_path(ptr_cache))$cache_key[1] + )$keyvalues[[1]]) +expect_true(length(pent$full_keyvalues) > length(pent$keyvalues)) #cached and uncached runs must agree field by field, so the cache cannot change #what a search reports for(f in c('filename', 'extname', 'type', 'dim', 'keyvalues')){ @@ -1263,15 +1561,36 @@ for(f in c('filename', 'extname', 'type', 'dim', 'keyvalues')){ } #an entry written before the cache held the full keywords is re-read rather than #used, since it cannot build a correct pointer -broken = readRDS(ptr_cache) -for(e in seq_along(broken)){ - broken[[e]]$info$full_keyvalues = NULL +ptr_parquet = Rfits:::.zarr_index_local_path(ptr_cache) +broken = Rfits:::.zarr_index_load_all(ptr_parquet) +at = which(broken$kind == 'store') +broken$keyvalues[at] = list(raw(0)) +broken$has_keyvalues[at] = FALSE + +replacement = tempfile( + pattern = "cutout_ptr-", + tmpdir = dirname(ptr_parquet), + fileext = ".parquet" +) + +Rfits:::.zarr_index_write(broken, replacement) + +# Release Arrow's mapped file before replacing the original on Windows. +rm(broken) +gc() + +if (!file.rename(replacement, ptr_parquet)) { + unlink(ptr_parquet) + if (!file.rename(replacement, ptr_parquet)) { + stop("Could not replace the Parquet index") + } } -saveRDS(broken, ptr_cache) preflow = cut_silent(dir = ptr_dir, RA = kv_cube$CRVAL1, Dec = kv_cube$CRVAL2, box = 51, cache = ptr_cache, extract = FALSE) expect_true(all(c('NAXIS3', 'CRVAL3') %in% names(preflow[[1]]$keyvalues))) -expect_true(!is.null(readRDS(ptr_cache)[[1]]$info$full_keyvalues)) +#and the stripped rows are repaired by the run that had to re-read them +expect_true(all(index_rows(ptr_parquet)$has_keyvalues[index_rows(ptr_parquet)$kind == + 'store'])) #A lazy pointer is not opened by the search: the slot is there but holds no handle, #which is the whole saving. The first slice opens it and keeps it, so a second slice @@ -1319,6 +1638,46 @@ second_slice = pslice[75:125, 75:125] expect_true(identical(get0('store', envir = pslice$store, inherits = FALSE), handle)) expect_equal(second_slice$imDat, first_slice$imDat) +#ex 57b Rfits_zarr_index reads an existing index back rather than rebuilding it, which is +#the other half of the index being worth having. The rows come out of an arrow scan, which +#returns a plain data.frame, so the row builder has to cope with that as well as with the +#data.table arrow::read_parquet returns when something in the session has asked for one +idx_dir = file.path(subdir, 'index_grid') +dir.create(idx_dir) +for(n in 1:3){ + Rfits_write_image_zarr(matrix(0, 50, 50), file.path(idx_dir, paste0('t', n, '.zarr')), + extname = 'data1') +} +idx_path = file.path(subdir, 'index1') +idx_built = Rfits_zarr_index(dir = idx_dir, index = idx_path, verbose = FALSE) +expect_identical(nrow(idx_built), 3L) +expect_true(file.exists(Rfits:::.zarr_index_local_path(idx_path))) +#reading it back is the same rows, and the .parquet extension is supplied +idx_back = Rfits_zarr_index(index = idx_path, verbose = FALSE) +expect_identical(nrow(idx_back), 3L) +expect_identical(sort(idx_back$cache_key), sort(idx_built$cache_key)) +expect_true(inherits(idx_back, 'data.table')) +#a data.frame in place of a data.table, still from the scanned rows +idx_flat = Rfits_zarr_index(index = idx_path, data.table = FALSE, verbose = FALSE) +expect_true(is.data.frame(idx_flat)) +expect_false(inherits(idx_flat, 'data.table')) +expect_identical(nrow(idx_flat), 3L) +#what an index holds is reportable without reading its rows +idx_info = Rfits_zarr_index_info(idx_path) +expect_identical(class(idx_info), 'Rfits_zarr_index_info') +expect_identical(idx_info$version, Rfits:::.zarr_index_version) +expect_identical(idx_info$n_rows, 3L) +expect_identical(idx_info$extnames, 'data1') +expect_output(print(idx_info), 'Zarr index') +#a newer index is refused rather than half read, since a search that quietly found nothing +#in a file whose columns had moved would look exactly like tiles that did not overlap +newer = Rfits:::.zarr_index_rows(list( + Rfits:::.zarr_index_meta_row('index_version', Rfits:::.zarr_index_version + 1L), + Rfits:::.zarr_index_blank_row())) +newer_path = file.path(subdir, 'index_newer') +Rfits:::.zarr_index_write(newer, Rfits:::.zarr_index_local_path(newer_path)) +expect_error(Rfits_zarr_index(index = newer_path, verbose = FALSE), 'newer version') + #ex 58 header = FALSE gives the bare array, and extname may offer several candidates nohead = cut_silent(dir = cut_dir, RA = cen_22[1], Dec = cen_22[2], box = 51, header = FALSE) @@ -1796,11 +2155,11 @@ again = Rfits_cutout_zarr_dir(bucket = bucket, prefix = batch_prefix, region = r RA = img_kv$CRVAL1, Dec = img_kv$CRVAL2, box = 51, cache = s3_cache, extract = FALSE, verbose = FALSE) expect_identical(names(first), names(again)) -expect_true(file.exists(s3_cache)) +s3_parquet = Rfits:::.zarr_index_local_path(s3_cache) +expect_true(file.exists(s3_parquet)) #the listing of the prefix is cached beside the headers, since a walk costs a #request per directory and is repeated on every search without it -scache = readRDS(s3_cache) -expect_true(any(grepl('^LIST\\|', names(scache)))) +expect_true(any(grepl('^WALK\\|', index_rows(s3_parquet)$cache_key))) #refresh drops the cached listing and walks again, and must still agree third = Rfits_cutout_zarr_dir(bucket = bucket, prefix = batch_prefix, region = region, endpoint = endpoint, access_key = keys$access_key, @@ -1811,8 +2170,8 @@ third = Rfits_cutout_zarr_dir(bucket = bucket, prefix = batch_prefix, region = r verbose = FALSE) expect_identical(names(third), names(again)) #a narrower prefix is a different spec, so it cannot be served by the broad listing -narrow = file.path(subdir, 's3_narrow.rds') -file.copy(s3_cache, narrow, overwrite = TRUE) +narrow = file.path(subdir, 's3_narrow.parquet') +file.copy(s3_parquet, narrow, overwrite = TRUE) sub_store = Rfits_cutout_zarr_dir(bucket = bucket, prefix = paste0(batch_prefix, '/'), region = region, endpoint = endpoint, access_key = keys$access_key,