importKellyGrid.R

# Функция-парсер протокола репертуарной решетки из программы
# KELLY (В.И. Похилько, Н.Н. Страхов) Автор: Юрий Тукачев
# yurij.tukachev@gmail.com

importKellyGrid <- function(file, dir = NULL, encode = "UTF-8") {
  # Необходимые пакеты
  require(stringr)
  require(OpenRepGrid)
  require(tcltk)
  if (!is.null(dir)) 
    file <- paste(dir, file, sep = "/", collapse = "")
  if (missing(file)) {
    Filters <- matrix(c("Файл протокола Kelly", 
      ".PRT", "Файл протокола Kelly (текстовый)", 
      ".TXT"), 2, 2, byrow = TRUE)
    file <- tk_choose.files(filters = Filters, multi = TRUE)
  }
  # Загружаем файл из программы Kelly
  kelly.grid <- iconv(readLines(file), from = "866", to = encode, 
    sub = NA, mark = TRUE, toRaw = FALSE)
  
  # Сохраняем шапку протокола для добавления в виде комментария
  comment.grid <- toString(str_trim(gsub("\\.+", "", kelly.grid[1:8])))
  # head(kelly.grid) #Что получилось? kelly.grid
  # kelly.grid[1:25] #Первые 25 строк Размерность матрицы
  # (элементы х конструкты)
  str = grep("МАТРИЦА: ", kelly.grid)
  st <- kelly.grid[str]
  m <- str_extract_all(st, "[0-9]+")
  m.dim <- c(as.numeric(m[[1]][1]), as.numeric(m[[1]][2]))  # Матрица
  # m.dim[1] #Элементов m.dim[2] #Конструктов
  
  # Максимальный размах
  str.r = grep("РАЗМАХ:", kelly.grid)
  str <- kelly.grid[str.r]
  r <- as.numeric(str_extract_all(str, "[0-9]+"))  #максимальный размах
  
  # Извлекаем элементы
  first.element.pos <- grep("СПИСОК ЭЛЕМЕНТОВ", 
    kelly.grid) + 2  #Номер строки первого элемента
  end.element.pos <- first.element.pos + m.dim[1] - 1  #Номер строки последнего элемента
  elements.list <- sapply(first.element.pos:end.element.pos, 
    function(x) {
      str_extract_all(kelly.grid[x], "[а-яА-Я\\-]+")
    })
  elements <- sapply(1:m.dim[1], function(x) {
    gsub(", ", " ", toString(elements.list[[x]]))
  })
  
  # Извлекаем список конструктов
  first.construct.pos <- grep("СПИСОК КОНСТРУКТОВ", 
    kelly.grid) + 2  #Номер строки первого элемента
  end.construct.pos <- first.construct.pos + m.dim[2] * 3 - 
    3  #Номер строки последнего элемента
  
  # Номера строк для левого и правого полюсов конструктов
  left.cons.pole.pos <- first.construct.pos
  right.cons.pole.pos <- first.construct.pos + 1
  
  # Левый
  constructs.list.left <- sapply(seq(left.cons.pole.pos, end.construct.pos, 
    3), function(x) {
    str_extract_all(kelly.grid[x], "[а-яА-Я\\-]+")
  })
  constructs.left <- sapply(1:m.dim[2], function(x) {
    gsub(", ", " ", toString(constructs.list.left[[x]]))
  })
  
  # Правый
  constructs.list.right <- sapply(seq(right.cons.pole.pos, 
    end.construct.pos + 1, 3), function(x) {
    str_extract_all(kelly.grid[x], "[а-яА-Я\\-]+")
  })
  constructs.right <- sapply(1:m.dim[2], function(x) {
    gsub(", ", " ", toString(constructs.list.right[[x]]))
  })
  
  # Считываем матрицу с баллами
  points <- grep(" xx ", kelly.grid) + 2
  if (length(points) > 1) {
    scores <- unlist(sapply(1:length(points), function(x) {
      nt <- sapply(points[x]:(points[x] + m.dim[2] - 1), 
        function(x) {
          str_extract_all(kelly.grid[x], "[0-9]+")
        })
      mt <- t(sapply(1:m.dim[2], function(x) {
        c(as.numeric(nt[[x]]))
      }))
      mt <- mt[, -1]
    }))
  } else {
    scores <- as.vector(sapply(1:length(points), function(x) {
      nt <- sapply(points[x]:(points[x] + m.dim[2] - 1), 
        function(x) {
          str_extract_all(kelly.grid[x], "[0-9]+")
        })
      mt <- sapply(1:(m.dim[2]), function(x) {
        c(as.numeric(nt[[x]]))
      })
      mt <- mt[-1, ]
    }))
  }
  
  # Баллы в исходной решетке (максимальный балл соответствует
  # левому полюсу конструкта) Перекодируем баллы: максимальный
  # балл соответствует правому полюса конструкта
  scores <- (r + 1) - scores
  
  # Создаем решетку
  args <- list(name = elements, l.name = constructs.left, r.name = constructs.right, 
    scores = scores)
  newGrid <- makeRepgrid(args)
  newGrid <- setScale(newGrid, 1, r)
  
  # Сохраняем шапку протокола в виде комментария к созданной
  # решетке
  comment(newGrid) <- comment.grid
  return(newGrid)
}