R/web.R

In facelab/webmorph: Reproducible Stimuli

#' 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))
}