R/AnalysisFunctions.R

In kollaR: Event Classification, Visualization and Analysis of Eye Tracking Data

#'Test whether a gaze coordinates are within or outside a rectangular or elliptical AOI.
#'The data fram aois must contain variables with minimum x, minimum y, maximum x, and maximum y values and
#'type where rect or rectangle means that the AOI is a rectangle and ellipse or circle that the AOI is an ellipse
#'The coordinate variables must be named:
#'      x0 OR xmin:   minimum x value
#'      x1 OR xmax:   maximum x value
#'      y0 OR ymin:   minimum y value
#'      y1 OR ymax:   maximum y value

#'If a column called name is present, the output for each
#'AOI will be labelled accordingly. Otherwise, the output will be labelled according to the order of the AOI in the data frame.
#'The df 'gaze' must contain the variables onset, duration, x, and y.
#'Latency will be defined as the value in onset of the first detected gaze coordinate in the AOI Make sure
#'that the timestamps are correct!
#'The function can be used with gaze data either fixations, saccades, or single samples. Note that the output variables are not equally relevant for all types of
#'gaze data. For example, both total duration and latency are relevant in many analyses focusing on fixations, but total duration may be less relevant in analyses of
#'saccades.
#'@param gaze data frame with each row representing a gaze coordinate from a fixation, saccade, or sample. Must include the variables x, y, duration, and onset. Onset zero should
#'typically be trial onset
#'@param aois data frame with AOIs.
#'@param outside If FALSE, summarize data within AOIs. If TRUE, summarize data outside AOIs.
#'@return data frame with total duration, number of occurrences and latency to first detected gaze coordinates for each AOI. Data are in long format.
aoi_test <- function(gaze, aois, outside = FALSE){

  #If the data frame aois has a variable with AOI names, name the output accordingly. Otherwise, name the output by aoi number
  if (is.null(aois$name)) {
    aois$name <- seq(1, nrow(aois))

  }

  #Convert names of coordinates
  names(aois) <- gsub("xmin", "x0", names(aois))
  names(aois) <- gsub("xmax", "x1", names(aois))
  names(aois) <- gsub("ymin", "y0", names(aois))
  names(aois) <- gsub("ymax", "y1", names(aois))

  #Circle converted to ellipse
  aois$type[aois$type =="rect"] <- "rectangle"
  aois$type[aois$type =="circle"] <- "ellipse"


  n.aois <- dim(aois)[1]
  data.out <- data.frame()

  for (i in 1: n.aois){
    #Find the relevant fixations

    if(aois$type[i] == "ellipse") { #Test whether the gaze coordinates are within a circle/ellipse
      h <- (aois$x0[i]+aois$x1[i])/2
      k <- (aois$y0[i] + aois$y1[i])/2
      a <- abs(aois$x1[i] - aois$x0[i])/2
      b <- abs(aois$y1[i] - aois$y0[i])/2

      inaoi <- ((gaze$x -h)^2 /a^2 + (gaze$y-k)^2/b^2) <= 1

    } else if (aois$type[i] =="rectangle") { #Test whether gaze coordinates are within a rectangle
      inaoi <- gaze$x>= aois$x0[i] & gaze$x <= aois$x1[i] &
        gaze$y >= aois$y0[i] & gaze$y <= aois$y1[i]


    }


    if (outside == FALSE){
      suppressWarnings(
        firsthit <- min(which(inaoi ==TRUE)) #First registered gaze point inside AOI
      )
      data.out <- rbind(
        data.out, data.frame(
          total.duration = sum(gaze$duration[inaoi]),
          n.fix = sum(inaoi),
          latency = gaze$onset[firsthit],
          aoi = aois$name[i]))

    } else if (outside == TRUE) {
      suppressWarnings(
        firsthit <- min(which(inaoi ==FALSE))) #First registered gaze point OUTSIDE AOI
      data.out <- rbind(
        data.out, data.frame(
          total.duration = sum(gaze$duration[!inaoi]),
          n.fix = sum(!inaoi),
          latency = gaze$onset[firsthit],
          aoi = aois$name[i]

        ))
    }

  }
  return(data.out)
}




#'Draw one or more areas of interest, AOIs, on one or more stimulus images and save the coordinates to the R prompt.
#'The function returns a data frame with all saved AOIs. By default, AOIs are drawn in a
#'coordinate system where y is 0 in the lower extreme of the image, e.g., an ascending y axis. Tobii eye trackers use a coordinate system with a descending
#'y-axis, e.g., x and y are 0 in the upper left corner of the image. Make sure that your AOIS match the coordinate system of your eye tracker output.
#'By setting the parameter reverse.y.axis to TRUE, the saved AOIs will be reformatted to fit a coordinate system with a descending y-axis.
#'All AOIS have the variables xmin, xmax, ymin and ymax. xmin is the minimum x value, ymin the minimum y value. xmax the maximum x value. ymax the maximum y value. Major
#'updates to this function were made in version 1.1.4
#'@param img_paths can be either the path to a directory where one or more images van be found OR an array of paths to one or more images.
#'@return data frame with type and coordinates of drawn AOIs


draw_aois <- function(img_paths) {



  if(dir.exists(img_paths[1]))
  {img_paths <- dir(img_paths, full.names = T)}

  stopifnot(length(img_paths) > 0)

  shapes <- data.frame(
    xmin = numeric(0),
    xmax = numeric(0),
    ymin = numeric(0),
    ymax = numeric(0),
    image = character(0),
    type = character(0),
    name = character(0)
  )

  draw_shape <- function(xmin, xmax, ymin, ymax, shape,
                         col = "red", lwd = 2) {
    if (shape == "rectangle") {
      graphics::rect(xmin, ymin, xmax, ymax, border = col, lwd = lwd)
    }

    if (shape == "ellipse") {
      theta <- seq(0, 2 * pi, length.out = 200)

      x_center <- mean(c(xmin, xmax))
      y_center <- mean(c(ymin, ymax))

      x_radius <- abs(xmax - xmin) / 2
      y_radius <- abs(ymax - ymin) / 2

      x <- x_center + x_radius * cos(theta)
      y <- y_center + y_radius * sin(theta)

      graphics::lines(x, y, col = col, lwd = lwd)
    }
  }

  reverse_y_axis <- function(dat) {
    if (nrow(dat) == 0) return(dat)

    for (img in unique(dat$image)) {
      img_path <- img_paths[basename(img_paths) == img][1]
      img_height <- magick::image_info(magick::image_read(img_path))$height

      idx <- dat$image == img

      old_ymin <- dat$ymin[idx]
      old_ymax <- dat$ymax[idx]

      dat$ymin[idx] <- img_height - old_ymax
      dat$ymax[idx] <- img_height - old_ymin
    }

    dat
  }

  ui <- fluidPage(
    h4(textOutput("image_name")),

    radioButtons(
      "shape_type",
      "Shape:",
      choices = c("Rectangle" = "rectangle", "Ellipse" = "ellipse"),
      selected = "rectangle",
      inline = TRUE
    ),

    textInput(
      "shape_name",
      "Shape name/tag:",
      value = ""
    ),

    checkboxInput(
      "reverse_y",
      "Export with reversed y-axis values, so y = 0 is at the top of the image",
      value = FALSE
    ),

    plotOutput(
      "imgplot",
      brush = brushOpts(
        id = "brush",
        resetOnNew = TRUE
      )
    ),

    actionButton("save_shape", "Save shape"),
    actionButton("delete_last", "Delete last saved row"),
    actionButton("prev_img", "Previous image"),
    actionButton("next_img", "Next image"),
    actionButton("done", "Done / export to R"),

    tableOutput("shape_table")
  )

  server <- function(input, output, session) {

    values <- reactiveValues(
      shapes = shapes,
      img_index = 1,
      latest_brush = NULL
    )

    current_img <- reactive({
      image_read(img_paths[values$img_index])
    })

    current_image_name <- reactive({
      basename(img_paths[values$img_index])
    })

    output$image_name <- renderText({
      paste0(
        "Image ",
        values$img_index,
        " of ",
        length(img_paths),
        ": ",
        current_image_name()
      )
    })

    output$imgplot <- renderPlot({
      plot(current_img())

      saved_for_image <- values$shapes[
        values$shapes$image == current_image_name(),
        ,
        drop = FALSE
      ]

      if (nrow(saved_for_image) > 0) {
        for (i in seq_len(nrow(saved_for_image))) {
          draw_shape(
            xmin = saved_for_image$xmin[i],
            xmax = saved_for_image$xmax[i],
            ymin = saved_for_image$ymin[i],
            ymax = saved_for_image$ymax[i],
            shape = saved_for_image$type[i],
            col = "red",
            lwd = 2
          )

          #  graphics::text(
          #   x = saved_for_image$xmin[i],
          #  y = saved_for_image$ymax[i],
          # labels = saved_for_image$name[i],
          #  pos = 4,
          # col = "red"
          #)
        }
      }

      b <- values$latest_brush

      if (!is.null(b)) {
        draw_shape(
          xmin = b$xmin,
          xmax = b$xmax,
          ymin = b$ymin,
          ymax = b$ymax,
          shape = input$shape_type,
          col = "blue",
          lwd = 2
        )

        #  graphics::text(
        #   x = b$xmin,
        #  y = b$ymax,
        # labels = input$shape_name,
        #pos = 4,
        #col = "blue"
        #)
      }
    })

    observeEvent(input$brush, {
      values$latest_brush <- input$brush
    }, ignoreNULL = TRUE)

    observeEvent(input$save_shape, {
      req(values$latest_brush)

      b <- values$latest_brush

      new_shape <- data.frame(
        xmin = b$xmin,
        xmax = b$xmax,
        ymin = b$ymin,
        ymax = b$ymax,
        image = current_image_name(),
        type = input$shape_type,
        name = input$shape_name,
        stringsAsFactors = FALSE
      )

      values$shapes <- rbind(values$shapes, new_shape)
    })

    observeEvent(input$delete_last, {
      if (nrow(values$shapes) > 0) {
        values$shapes <- values$shapes[-nrow(values$shapes), , drop = FALSE]
      }
    })

    observeEvent(input$next_img, {
      if (values$img_index < length(img_paths)) {
        values$img_index <- values$img_index + 1
        values$latest_brush <- NULL
      }
    })

    observeEvent(input$prev_img, {
      if (values$img_index > 1) {
        values$img_index <- values$img_index - 1
        values$latest_brush <- NULL
      }
    })

    output$shape_table <- renderTable({
      if (input$reverse_y) {
        reverse_y_axis(values$shapes)
      } else {
        values$shapes
      }
    })

    observeEvent(input$done, {
      out <- values$shapes

      if (input$reverse_y) {
        out <- reverse_y_axis(out)
      }

      stopApp(out)
    })
  }

  runApp(shinyApp(ui, server))
}