R/read_data.R

In gjcooper/gcphd-model_of_dce: Models of Consumer Choice Experiments

#' Read data generated by the Expyriment python library
#'
#' Import Exypriment data into R. The function concatinates all data and returns
#' a R data frame with all subjects. Between subject factors will be added as
#' variables to the data matrix.
#'
#' Copyright: 2012-2015 Florian Krause <siebenhundertzehn@googlemail.com>
#'            2012-2015 Oliver Lindemann <lindemann09@googlemail.com>
#' License: GPL-3.0+
#' Adapted for this package by Gavin Cooper <gavin@gavincooper.net> 2020
#'
#' @param folder The data folder (string)
#' @param filename_pattern The pattern with which the names of each data file
#'   start (string)
#' @return A list containing each participants data converted from JSON
#'
#' @export
read_expyriment_data <- function(folder, filename_pattern) {
  pattern <- paste("^", filename_pattern, ".*\\.xpd", sep = "")

  data <- data.frame()
  for (fl_name in list.files(path = folder, pattern)) {
    path <- file.path(folder, fl_name)
    message("reading ", path)
    d <- utils::read.csv(path, comment.char = "#", na.strings = c("NA", "None"))
    fl <- file(path, "r")
    while (TRUE) {
      line <- readLines(fl, n = 1)
      if (!length(line) || !length(grep("#", line))) {
        break
      } else {
        if (length(grep("^#s ", line)) > 0) {
          tmp <- unlist(strsplit(sub("#s ", "", line), ":"))
          if (length(tmp) < 2) {
            tmp <- unlist(strsplit(sub("#s ", "", line), "="))
          }
          if (grep("^ ", tmp[2])) {
            tmp[2] <- substring(tmp[2], 2)
          }
          if (tmp[1] != "id") {
            d <- cbind(d, new = tmp[2])
            names(d)[ncol(d)] <- tmp[1]
          }
        }
      }
    }
    close(fl)
    if (nrow(data) < 1) {
      data <- d
    } else {
      data <- rbind(data, d)
    }
  }
  data
}


#' Reformat data from the Expyriment file format to a useful tibble
#'
#' Import Exypriment data into R. The function concatinates all data and returns
#' a R data frame with all subjects. Between subject factors will be added as
#' variables to the data matrix.
#'
#' Copyright: 2012-2015 Florian Krause <siebenhundertzehn@googlemail.com>
#'            2012-2015 Oliver Lindemann <lindemann09@googlemail.com>
#' License: GPL-3.0+
#' Adapted for this package by Gavin Cooper <gavin@gavincooper.net> 2020
#'
#' @param folder The data folder (string)
#' @param filename_pattern The pattern with which the names of each data file
#'   start (string)
#' @return A list containing each participants data converted from JSON
#'
#' @import dplyr
#' @importFrom forcats fct_recode
#' @export
reformat <- function(x) {
  factor_cols <- c("PriceRatingOrder", "ResponseCounterbalancing",
                   "AcceptRejectFocus", "GreyedItemDisplay")
  short_codes <- c(H = "High", L = "Low", D = "OutOfBounds")
  cfix <- function(x, end = 1) {
    substr(x, 3, nchar(x) - end)
  }

  x %>%
    tibble() %>%
    filter(BlockName != "Practice Block") %>%
    rename_with(.fn = cfix, .cols = starts_with("b'"), end=2) %>%
    mutate(across(any_of(factor_cols), .fns = cfix)) %>%
    mutate(
      PriceSalience = fct_recode(PriceSalience, !!!short_codes),
      RatingSalience = fct_recode(RatingSalience, !!!short_codes)
    ) %>%
    mutate(Correct = as.logical(Correct)) %>%
    mutate(trial_cat = case_when(
      PriceSalience %in% c("H", "L") & RatingSalience %in% c("H", "L") ~ "both",
      PriceSalience %in% c("H", "L") ~ "psing",
      RatingSalience %in% c("H", "L")~ "rsing",
      TRUE ~ "neither"
    )) %>%
    mutate(subject_id = factor(subject_id)) %>%
    mutate(acceptAND = AcceptRejectFocus == "Accept")
}


#' Parses a JATOS datafile line in 2020 Pref SFT format
#'
#' For a particular line from a datafile, parse the JSON and return the result.
#'
#' @param data_line The string containing the line in question
#' @param line_index The line number of the line being processed
#'
#' @return The result of parsing the JSON from the line, or an error
parse_JATOS_line <- function(data_line, line_index) {
  out <- tryCatch({
      rjson::fromJSON(data_line)
    },
    error = function(cond) {
      print_JATOS_line(data_line, line_index)
    },
    warning = function(cond) {
      print_JATOS_line(data_line, line_index)
    }
  )
  return(out)
}


#' Print a problem JATOS datafile line if JSON parsing failed
#'
#' @inheritParams parse_JATOS_line
print_JATOS_line <- function(data_line, line_index) {
  if (nchar(data_line) == 0) {
    message(paste("Line", line_index, "empty"))
  } else if (nchar(data_line) < 60) {
    message(paste("Line", line_index, "contents:", data_line))
  } else {
    message(paste(
      "Line",
      line_index,
      "abbrev:",
      substring(data_line, 1, 25),
      "....",
      substring(data_line, nchar(data_line) - 25 + 1)
    ))
  }
}


#' Get data from a raw JSON file
#'
#' Reads data from a JATOS results file.
#' Each line from the file should be a JSON object from the PrefSFT2020 code
#'
#' @param datafile A string containing the local of a JATOS data export
#'
#' @return A list containing each participants data converted from JSON
#'
#' @export
get_JATOS_data <- function(datafile) {
  connection <- file(datafile, open = "r")
  data_lines <- readLines(connection)
  raw_data <- c()
  for (line_index in seq_along(data_lines)) {
    line_data <- parse_JATOS_line(data_lines[line_index], line_index)
    if (!is.null(line_data)) {
      raw_data <- append(raw_data, list(line_data))
    }
  }
  close(connection)
  raw_data
}

#' Use read_csv and bind_rows to rearrange data from JATOS file
#'
#' @param raw_data The data in raw format to extract from
#'
#' @return All experimental data as a tibble
#'
#' @export
extract_data <- function(raw_data) {
  part_data_list <- lapply(raw_data, FUN = function(line) {
    readr::read_csv(line$jsPsychData, col_types = readr::cols(.default = "c"))
  })
  part_data_list <- dplyr::bind_rows(lapply(
    part_data_list,
    function(dtt) {
      dplyr::mutate_all(dtt, as.character)
    }
  ))
  dplyr::bind_rows(part_data_list)
}


#' Load an RData file with pmwg samples for further analysis
#'
#' @param pmwg_file The environment from a run of pmwg as RData
#' @param final_obj The object (generally a pmwgs object) to extract
#'
#' @return The pmwgs object
#'
#' @export
get_samples <- function(pmwg_file, final_obj = "sampled") {
  # Load in the data into the global environment
  load(pmwg_file, envir = (e <- new.env()))
  e[[final_obj]]
}