-
Notifications
You must be signed in to change notification settings - Fork 21
/
item_update.R
88 lines (78 loc) · 2.69 KB
/
item_update.R
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
#' @title Update a SB item with new metadata
#'
#' @template manipulate_item
#' @param info list of metadata info (key-value pairs) to change on the item
#'
#' @return An object of class \code{sbitem}
#'
#' @import httr
#' @import jsonlite
#'
#' @description
#' Updates metadata associated with a ScienceBase item based on
#' supplied list of new or updated metadata elements.
#'
#' @examples \dontrun{
#' res <- item_create(user_id(), "item-to-update")
#' out <- item_update(res, list(title = "item-updated"))
#' out$title
#' }
#' @export
item_update = function(sb_id, info, ...){
item <- as.sbitem(sb_id)
is_info_list(info)
r = sbtools_PUT(url = paste0(pkg.env$url_item, item$id),
body = toJSON(info, auto_unbox = TRUE, null='null'),
..., accept_json())
# catch 405, which is, I think, expired login
if ('errors' %in% names(content(r))) {
stop(content(r)$errors$message)
}
return(as.sbitem(content(r)))
}
#' @title Update many SB items with new metadata
#'
#' @export
#' @param sb_id An \code{\link{sbitem}} object or a character ScienceBase ID
#' corresponding to the item
#' @param info list of metadata info (key-value pairs) to change on the item
#' @param ... Additional parameters are passed on to \code{\link[httr]{PUT}}
#'
#' @description
#' A method to update multiple ScienceBase items with a single call and a single HTTP service
#' request. Can be useful for improving performance of updating a large number of items at once.
#'
#' @return One or more objects of class \code{sbitem} in a list
#' @details If length of \code{sb_id} > 1, then length of \code{info} input must be the same
#' @examples \dontrun{
#' # helper function to make a random name
#' aname <- function() paste0(sample(letters, size = 5, replace = TRUE), collapse = "")
#'
#' res <- items_create(user_id(), title = c(aname(), aname()))
#' out <- items_update(res, info = list( list(title = aname()), list(title = aname()) ) )
#' vapply(out, "[[", "", "title")
#' }
items_update <- function(sb_id, info, ...){
if (length(sb_id) == 1) sb_id <- list(sb_id)
item <- vapply(sb_id, function(z) as.sbitem(z)$id, "")
invisible(lapply(info, is_info_list))
body <- unname(
Map(function(x, y) {
c(list('id' = x, null = "null"), y)
}, item, info
)
)
res <- sbtools_PUT(url = pkg.env$url_items,
body = toJSON(body, auto_unbox = TRUE),
..., accept_json())
# catch 405, which is, I think, expired login
if ('errors' %in% names(content(res))) {
stop(content(res)$errors$message, call. = FALSE)
}
lapply(content(res), as.sbitem)
}
is_info_list <- function(x) {
if (!is.list(x)) {
stop('Info must be a list of name-value pairs that can be serialized into JSON', call. = FALSE)
}
}