#' Webmorph.org API
#'
#' @param script the name of the webmorph script
#' @param ... arguments to pass on to the script in POST
#' @param .error whether to warn, stop or do nothing on error
#'
#' @return the response as a list
#' @export
#'
#' @examples
#' \dontrun{
#' web(a = 1, b = FALSE, c = "testing")
#' }
web <- function(script = "webmorphR", ..., .error = c("warn", "stop", "none")) {list(...)
url <- paste0("https://webmorph.org/scripts/", script)
r <- httr::POST(url, body = list(...))
resp <- httr::content(r)
if (isTRUE(resp$error)) {
.error <- match.arg(.error)
e <- resp$errorText %>%
paste(collapse = "\n") %>% # in case it's an array
charToRaw() %>% # force read_html to treat as string
xml2::read_html() %>% # read as HTML
rvest::html_text() # strip HTML tags
if (.error == "warn") warning(e, call. = FALSE)
if (.error == "stop") stop(e, call. = FALSE)
}
invisible(resp)
}
#' Login to webmorph.org
#'
#' @param email The email address associated with the account
#' @param password The password for the account
#'
#' @return NULL
#' @export
#'
#' @examples
#' \dontrun{
#' login()
#' }
login <- function(email = Sys.getenv("WEBMORPH_EMAIL"),
password = Sys.getenv("WEBMORPH_PASSWORD")) {
resp <- web("userLogin", email = email, password = password, .error = "stop")
message("Logged in as user ", resp$user)
projList <- get_projects() # sets $_SESSION['projects']
if (nrow(projList) > 0) {
set_project(projList$id[[1]])
}
invisible(resp$user)
}
#' Log out of webmorph.org
#'
#' @return NULL
#' @export
#'
#' @examples
#' \dontrun{
#' logout()
#' }
logout <- function() {
resp <- web("userLogout")
if (isFALSE(resp$error)) message("Logged out")
}
#' Get webmorph.org project list
#'
#' @param notes whether to resturn the notes for each project
#'
#' @return data frame of project id, name and notes (optional)
#' @export
#'
#' @examples
#' \dontrun{
#' get_projects(notes = TRUE)
#' }
get_projects <- function(notes = FALSE) {
resp <- web("projListGet", .error = "stop")
msg <- sprintf("Your projects are using %s of %s",
format_size(resp$userAllocation$size*1024*1024),
format_size(resp$userAllocation$allocation*1024*1024)
)
message(msg)
proj <- data.frame(
id = sapply(resp$projects, `[[`, "id"),
name = sapply(resp$projects, `[[`, "name")
)
if (notes) proj$notes = sapply(resp$projects, `[[`, "notes")
proj
}
#' Set the Working Project
#'
#' @param project the ID of the project to set
#'
#' @return project id and permissions
#' @export
#'
#' @examples
#' \dontrun{
#' set_project(8675309)
#' }
#'
set_project <- function(project) {
resp <- web("projSet", project = project, .error = "stop")
message("You have ", resp$perm, " permissions for project ", project)
Sys.setenv(webmorph_project_id = project)
invisible(list(project_id = project,
permissions = resp$perm))
}
#' Get Project ID from a list of filenames
#'
#' @param files (leave blank to get current project ID)
#'
#' @return project ID
#' @export
#'
#' @examples
#' get_project_id(c("8675309/img.jpg", "8675309/img.tem"))
#' \dontrun{
#' get_project_id()
#' }
#'
get_project_id <- function(files = NULL) {
suppressWarnings({
project_id <- gsub("^(\\d{1,11})/.*$", "\\1", files) %>%
unique() %>% as.integer()
})
if (length(project_id) == 0 || any(is.na(project_id))) {
# default project ID
project_id <- Sys.getenv("webmorph_project_id")
} else if (length(project_id) != 1) {
stop("All files need to be in the same project.")
}
if (project_id == "") {
stop("The project ID must be an integer and present at the start of each file name (e.g., '123/folder/file.jpg') or you can set the project with set_project(id)")
}
project_id
}
#' Get directory contents
#'
#' @param dir the directory to look in
#' @param project_id the project ID
#'
#' @return nested list of the directory
#' @export
#'
#' @examples
#' \dontrun{
#' load_dir("compsites")
#' }
#'
load_dir <- function(dir = "", project_id = Sys.getenv("webmorph_project_id")) {
resp <- web("dirLoad", subdir = paste(project_id, dir, sep = "/"),
.error = "stop")
# get all file paths
purrr::flatten(resp$dir[[1]]) %>%
`[`(. == "") %>%
names() %>%
sub(paste0("^i", project_id), "", .) # remove initial i (does stuff on the web)
}
#' Download files from webmorph
#'
#' @param files a list or vector of file names to download, must start with the project number, e.g. "1/averages/f_multi.jpg"
#' @param destination A folder to save the files to, defaults to the directory structure of the project
#'
#' @return a list of local paths to the files
#' @export
#'
#' @examples
#' \dontrun{
#' download_file("composites", "img/comp")
#' }
download_file <- function(files, destination = NULL) {
if (length(files) > 1) {
paths <- sapply(files, download_file, destination = destination)
# names(paths) <- NULL
message("Downloaded ", length(paths), " files")
return(invisible(paths))
}
if (is.null(destination)) {
fname <- files
} else {
fname <- file.path(destination, basename(files))
}
dir.create(dirname(fname), recursive = TRUE, showWarnings = FALSE)
files <- sub("^/", paste0(get_project_id(files), "/"), files)
r <- httr::POST("https://webmorph.org/scripts/fileZip",
body = list(files = files),
httr::write_disk(fname, TRUE))
invisible(fname)
}
#' Upload files to webmorph.org
#'
#' @param files vector of paths of files to upload
#' @param dir directory to upload them to
#'
#' @return list of successfully uploaded files
#' @export
#'
#' @examples
#' \dontrun{
#' demo_stim() %>% upload_file("test_dir")
#' }
upload_file <- function(files, dir = "/") {
url <- "https://webmorph.org/scripts/fileUpload"
# save images to tempdir if files is a stim list
if ("stimlist" %in% class(files)) {
stimuli <- files
files <- write_stim(stimuli, tempdir(), "jpg") %>%
unlist()
names(files) <- sapply(files, basename)
}
# need to set current project to avoid permissions rejection
dir <- paste0(dir, "/") %>% gsub("/+", "/", .)
project_id <- get_project_id(dir)
dir <- gsub("^/", paste0(project_id, "/"), dir)
suppressMessages(check <- set_project(project_id))
if (check$permissions != "all") {
stop("You do not have permission to upload images to project ", check$project_id)
}
if (webmorph_options("verbose")) {
pb <- progress::progress_bar$new(
total = length(files), clear = FALSE,
format = "Uploading [:bar] :current/:total :elapsedfull"
)
pb$tick(len = 0)
}
uploaded <- sapply(files, function(path) {
body <- list(`upload[0]` = httr::upload_file(path),
basedir = dir)
r <- httr::POST(url, body = body)
resp <- httr::content(r)
if (webmorph_options("verbose")) pb$tick()
if (isTRUE(resp$error)) {
warning(resp$errorText)
FALSE
} else {
resp$newFileName[[1]]
}
})
uploaded[uploaded != "FALSE"] %>%
sub(paste0("^", project_id), "", .)
}
#' Delete directories on webmorph.org
#'
#' @param dir directory to delete
#'
#' @return logical, if directory was deleted
#' @export
#'
#' @examples
#' \dontrun{
#' delete_dir("test")
#' }
delete_dir <- function(dir) {
if (substr(dir, 0, 1) == "/") dir <- paste0(get_project_id(), dir)
resp <- web("dirDelete", 'dirname[]' = dir)
isTRUE(resp$info[dir] == "deleted")
}
#' Delete files on webmorph.org
#'
#' @param files files to delete
#'
#' @return list of deleted files
#' @export
#'
#' @examples
#' \dontrun{
#' delete_files(c("test/img.jpg", "test/img.tem"))
#' }
delete_file <- function(files) {
# need to set current project to avoid permissions rejection
project_id <- get_project_id(files)
suppressMessages(check <- set_project(project_id))
if (check$permissions != "all") {
stop("You do not have permission to delete images from project ", check$project_id)
}
files <- sapply(files, gsub, pattern = "^/",
replacement = paste0(project_id, "/"))
if (webmorph_options("verbose")) {
pb <- progress::progress_bar$new(
total = length(files), clear = FALSE,
format = "Deleting [:bar] :current/:total :elapsedfull"
)
pb$tick(len = 0)
}
#names(files) <- rep('files[]', length(files))
#do.call(web, c(list(script = "fileDelete"), files))
deleted <- sapply(files, function(path) {
resp <- web("fileDelete", 'files[]' = path)
if (webmorph_options("verbose")) pb$tick()
if (isTRUE(resp$error)) {
warning(resp$errorText)
FALSE
} else {
TRUE
}
})
message("... ", sum(deleted), " of ",
length(deleted), " deleted")
deleted
}
#' Make an Average Face
#'
#' @param files the image files to average
#' @param outname local path to save average to
#' @param texture logical, textured average
#' @param norm how to normalise
#' @param normpoint points for twopoint normalisation
#' @param format image format
#'
#' @return stimlist
#' @export
#'
#' @examples
#' \dontrun{
#' demo_stim("lisa") %>% average(norm = "twopoint")
#' }
average <- function(files, outname = tempfile(),
texture = TRUE,
norm = c("none", "twopoint", "rigid"),
normpoint = 0:1,
format = c("jpg", "png", "gif")) {
if ("stimlist" %in% class(files)) {
stimuli <- validate_stimlist(files, TRUE)
# upload to temp dir first
tdir <- sample(c(LETTERS, 0:9), 10) %>%
paste(collapse = "") %>%
paste0("/", ., "/")
files <- upload_file(stimuli, tdir)
# delete on exit
on.exit(delete_dir(tdir))
}
project_id <- get_project_id(files)
# select image files and remove project_id
filenames <- gsub(paste0("^", project_id), "", files)
filenames <- filenames[grepl("\\.(jpg|gif|png)$", files)]
query <- list(
subfolder = project_id,
savefolder = '/.tmp/',
count = 1,
texture0 = ifelse(isTRUE(as.logical(texture)), "true", "false"),
norm0 = match.arg(norm),
normPoint0_0 = normpoint[[1]],
normPoint1_0 = normpoint[[2]],
format0 = match.arg(format),
images0 = filenames
)
json_body <- jsonlite::toJSON(
list(theData = query), auto_unbox = TRUE)
url <- "https://webmorph.org/scripts/tcAverage"
r <- httr::POST(url, body = json_body, encode = "raw")
resp <- httr::content(r)
if (isTRUE(resp$error)) { warning(resp$errorText) }
tmpdir <- tempdir()
suppressMessages(
avg <- download_file(resp$newFileName, tmpdir)
)
dir.create(dirname(outname), recursive = TRUE, showWarnings = FALSE)
imgname <- paste0(outname, ".", match.arg(format))
temname <- paste0(outname, ".tem")
file.copy(avg[[1]], imgname, overwrite = TRUE)
file.copy(avg[[2]], temname, overwrite = TRUE)
read_stim(c(imgname, temname))
}
#' Make a Transform
#'
#' The first 7 arguments are vectorised, so you can put in a vector of image names or shape/color/texture values.
#'
#' @param trans_img image(s) to transform
#' @param from_img negative end of the transform dimension
#' @param to_img positive end of the transform dimension
#' @param shape,color,texture amount to transform (1.0 = 100% of the difference between the from_img and to_img)
#' @param outname local path to save transform to
#' @param norm how to normalise
#' @param normpoint points for twopoint normalisation
#' @param sample_contours whether to sample contours
#' @param warp warping algorithm to use
#' @param format image format
#'
#' @return stimlist
#' @export
#'
#' @examples
#' \dontrun{
#' stimuli <- demo_stim()
#' transf <- transform(
#' trans_img = stimuli, # transform all stimuli
#' from_img = stimuli$f_multi,
#' to_img = stimuli$m_multi,
#' shape = c(fem = -0.5, masc = 0.5)
#' )
#' plot(transf, nrow = 2, labels = TRUE)
#' }
#'
transform <- function(trans_img = NULL, from_img = NULL, to_img = NULL,
shape = 0,
color = 0,
texture = 0,
outname = NULL,
norm = c("none", "twopoint", "rigid"),
normpoint = 0:1,
sample_contours = TRUE,
warp = c("multiscale", "linear", "multiscalerb"),
format = c("jpg", "png", "gif")) {
# deal with webmorph lists
to_upload <- c()
if ("stim" %in% class(trans_img)) {
trans_img <- validate_stimlist(trans_img, TRUE)
}
if ("stim" %in% class(from_img)) {
from_img <- validate_stimlist(from_img, TRUE)
}
if ("stim" %in% class(to_img)) {
to_img <- validate_stimlist(to_img, TRUE)
}
if ("stimlist" %in% class(trans_img)) {
to_upload <- trans_img
}
if ("stimlist" %in% class(from_img)) {
to_upload <- c(to_upload, from_img)
}
if ("stimlist" %in% class(to_img)) {
to_upload <- c(to_upload, to_img)
}
if (length(to_upload) > 0) {
# find identical stimuli to avoid duplicate upload
n <- length(to_upload)
pairs <- expand.grid(a = 1:n, b = 1:n)
upairs <- pairs[pairs$a < pairs$b, ]
idpairs <- mapply(identical, to_upload[upairs$a], to_upload[upairs$b])
dupes <- upairs[which(idpairs == TRUE), ]
nondupes <- setdiff(1:n, dupes$b)
# upload to temp dir first and # delete on exit
tdir <- sample(c(LETTERS, 0:9), 10) %>% paste(collapse = "") %>% paste0("/", ., "/")
uploaded <- upload_file(to_upload[nondupes], tdir)
on.exit(delete_dir(tdir))
# remove tems from uploaded
remote_img <- uploaded[!grepl("tem$", uploaded)]
names(remote_img) <- sub("\\.(jpg|gif|png)$", "", names(remote_img))
# replace with remote filenames
# still doesn't solve if stim have the same name but aren't identical
if ("stimlist" %in% class(trans_img)) {
trans_img <- remote_img[names(trans_img)]
}
if ("stimlist" %in% class(from_img)) {
from_img <- remote_img[names(from_img)]
}
if ("stimlist" %in% class(to_img)) {
to_img <- remote_img[names(to_img)]
}
}
# set up a batch file
files <- c(trans_img, from_img, to_img)
project_id <- get_project_id(files)
# select image files and remove project_id
filenames <- list(trans = trans_img, from = from_img, to = to_img) %>%
lapply(gsub, pattern = paste0("^", project_id), replacement = "") %>%
lapply(function(x) { x[grepl("\\.(jpg|gif|png)$", x)] })
# get all to the same length
n_img <- sapply(filenames, length) %>% max()
filenames <- lapply(filenames, rep_len, n_img) %>% as.data.frame()
n_param <- list(shape, color, texture) %>%
sapply(length) %>% max()
param <- data.frame(
shape = rep_len(shape, n_param),
color = rep_len(color, n_param),
texture = rep_len(texture, n_param)
)
batch <- tidyr::crossing(param, filenames)
# outnames
if (!is.null(outname)) {
n <- nrow(batch)
outname <- gsub("\\.(jpg|gif|png)$", "", outname)
if (length(outname) < n) {
outname <- rep_len(outname, n) %>%
paste0("_", 1:n)
}
batch$outname <- outname[1:n]
} else {
# construct outnames
trans_names <- names(trans_img)
from_names <- names(from_img)
to_names <- names(to_img)
if (all(from_names == trans_names)) from_names = ""
if (all(from_names == to_names)) to_names = ""
if (all(to_names == trans_names)) to_names = ""
imgnames <- list(trans = trans_names,
from = from_names,
to = to_names) %>%
lapply(function(x) if (length(x)==1) "" else x) %>%
lapply(rep_len, n_img) %>%
as.data.frame()
paramnames <- data.frame(
shape = rep_len(names(shape) %||% "", n_param),
color = rep_len(names(color) %||% "", n_param),
texture = rep_len(names(texture) %||% "", n_param)
)
# fix if no names and multiple params
if (nrow(paramnames) > 1 &&
is.null(names(shape)) &&
is.null(names(color)) &&
is.null(names(texture))) {
paramnames$shape <- nrow(paramnames) %>%
as.character() %>%
nchar() %>%
paste0("%0", ., "d") %>%
sprintf(1:nrow(paramnames))
}
o <- tidyr::crossing(paramnames, imgnames)
oname <- paste(o$shape, o$color, o$texture,
o$trans, o$from, o$to, sep = "_") %>%
gsub("_{2,}", "_", .) %>%
gsub("^_", "", .) %>%
gsub("_$", "", .)
batch$outname <- paste0(tempdir(), "/", oname)
}
batch_transform(batch, project_id, norm, normpoint, sample_contours, warp, format)
}
#' Batch Transform
#'
#' @param batch data frame containing batch info
#' @param project_id the project ID
#' @param norm how to normalise
#' @param normpoint points for twopoint normalisation
#' @param sample_contours whether to sample contours
#' @param warp warping algorithm to use
#' @param format image format
#'
#' @return webmorph_list
#' @export
#'
batch_transform <- function(batch,
project_id = Sys.getenv("webmorph_project_id"),
norm = c("none", "twopoint", "rigid"),
normpoint = 0:1,
sample_contours = TRUE,
warp = c("multiscale", "linear", "multiscalerb"),
format = c("jpg", "png", "gif")) {
# change columns like trans-img to trans
nm <- names(batch)
newnm <- gsub("-img$", "", nm)
names(batch) <- newnm
# check for required columns
required <- c("trans", "from", "to", "shape", "color", "texture", "outname")
missing <- setdiff(required, newnm)
if (length(missing) > 0) {
stop("The batch table is missing columns: ", paste(missing, collapse = ","))
}
# remove image suffixes and make local if starts with /
batch$outname <- gsub("\\.(jpg|gif|png)$", "", batch$outname)
batch$outname <- gsub("^/", "./", batch$outname)
# clean parameters
for (x in c("shape", "color", "texture")) {
if (is.character(batch[[x]])) batch[x] <- gsub("%", "", batch[[x]]) %>% as.numeric()
prob_pcnts <- abs(batch[[x]]) > 3
batch[[x]][prob_pcnts] <- batch[[x]][prob_pcnts] / 100
}
batch_transform_(batch, project_id, norm, normpoint, sample_contours, warp, format)
}
#' Batch Transform (internal)
#'
#' @param batch checked data frame containing batch info
#' @param project_id the project ID
#' @param norm how to normalise
#' @param normpoint points for twopoint normalisation
#' @param sample_contours whether to sample contours
#' @param warp warping algorithm to use
#' @param format image format
#'
#' @return stimlist
#' @keywords internal
batch_transform_ <- function(batch,
project_id = Sys.getenv("webmorph_project_id"),
norm = c("none", "twopoint", "rigid"),
normpoint = 0:1,
sample_contours = TRUE,
warp = c("multiscale", "linear", "multiscalerb"),
format = c("jpg", "png", "gif")) {
tmpdir <- tempdir()
imgname <- c()
temname <- c()
n <- nrow(batch)
if (webmorph_options("verbose")) {
pb <- progress::progress_bar$new(
total = n, clear = FALSE,
format = "Transforming [:bar] :current/:total :elapsedfull"
)
pb$tick(len = 0)
}
for (i in 1:n) {
query <- list(
subfolder = project_id,
savefolder = '/.tmp/',
count = 1,
transimage0 = batch$trans[[i]],
fromimage0 = batch$from[[i]],
toimage0 = batch$to[[i]],
shape0 = batch$shape[[i]],
color0 = batch$color[[i]],
texture0 = batch$texture[[i]],
sampleContours0 = ifelse(isTRUE(as.logical(sample_contours)), "true", "false"),
norm0 = match.arg(norm),
warp0 = match.arg(warp),
normPoint0_0 = normpoint[[1]],
normPoint1_0 = normpoint[[2]],
format0 = match.arg(format)
)
json_body <- jsonlite::toJSON(
list(theData = query), auto_unbox = TRUE)
url <- "https://webmorph.org/scripts/tcTransform"
r <- httr::POST(url, body = json_body, encode = "raw")
resp <- httr::content(r)
if (isTRUE(resp$error)) { warning(resp$errorText) }
suppressMessages(
trans <- download_file(resp$newFileName, tmpdir)
)
dir.create(dirname(batch$outname[i]), recursive = TRUE, showWarnings = FALSE)
imgname[i] <- paste0(batch$outname[i], ".", match.arg(format))
temname[i] <- paste0(batch$outname[i], ".tem")
file.copy(trans[[1]], imgname[[i]], overwrite = TRUE)
file.copy(trans[[2]], temname[[i]], overwrite = TRUE)
if (webmorph_options("verbose")) pb$tick()
}
read_stim(c(imgname, temname))
}
Add the following code to your website.
For more information on customizing the embed code, read Embedding Snippets.