index.Rmd

--- 
title: "Sublab: A QWrks-Study of the Subjectivity on the Future of Labor"
author: 
  - name: "Maximilian Held"
    affiliation: "Friedrich-Alexander Universität Erlangen-Nürnberg (FAU)"
  - name: "Sabine Pfeiffer"
    affiliation: "Friedrich-Alexander Universität Erlangen-Nürnberg (FAU)"
date: "`r format(Sys.time(), '%d %B, %Y')`"
bibliography: held_library.bib
editor_options: 
  chunk_output_type: console
---

```{r, child="README.md"}
```

```{r setup, cache = FALSE, include = FALSE}
source("setup.R")
```


# Method

## Items

```{r concourse}
concourse <- readxl::read_xlsx(path = "concourse.xlsx", sheet = 1)
# TODO subsetting these does not retain handles
concourse$german <- concourse$german %>%
  set_names(value = concourse$handle) %>% 
  psItemContent(lang = "de-DE")
concourse$english <- concourse$english %>% 
  set_names(value = concourse$handle) %>% 
  psItemContent(lang = "en-US")
```

```{r grid}
grids <- NULL
grids$zaw17 <- as_psGrid(obj = rep(x = 5, times = 9), polygon = "hexagon", offset = "odd")
grids$ts_18 <- as_psGrid(qmethod::make.distribution(nstat = nrow(concourse), max.bin = 5))
```


## Data

```{r}
sorts <- tibble::tibble(
  name = character(),
  group = character(),
  gender = character(),
  age = numeric(),
  datetime = integer(),
  sort = matrix(),
  comments = matrix()
)
```


```{r zaw17, warning = FALSE, cache = TRUE}
# should pipe all the way through this but it is too slow
zaw17 <- fs::path("raw", "2017-10-zaw40") %>% 
  fs::dir_ls(all = FALSE, recursive = TRUE, type = "file", glob = "*2017_10*") %>% 
  map_dfr(.f = function(x) {
    split_path <- x %>% fs::path_split() %>% extract2(1)
    name <- split_path %>% 
      extract(3) %>% 
      stringr::str_extract_all(pattern = "^[^-]*[^ -]", simplify = TRUE) %>%
      as.vector(.)
    condition <- split_path %>% 
      extract(4)
    time <- split_path %>% 
      extract(5) %>% 
      fs::path_ext_remove() %>% 
      lubridate::ymd_hms(tz = "Europe/Berlin")
    sort <- x %>% 
      readr::read_csv(col_names = as.character(-5:4), na = "NA", col_types = "cccccccccc", skip = 1) %>% 
      dplyr::select(-1) %>% 
      as.matrix(.) %>% 
      tryCatch(
        expr = {
          psSort(sort = ., polygon = "hexagon", offset = "odd")
        },
        error = function(cnd) {
          warning(glue::glue(
            "Skipped importing {x}. {conditionMessage(cnd)}"
          ))
          as_psSort(obj = grids$zaw17)
        }
      )
    # TODO the transformation to psClosedSorts should really happen here, but is currently blocked by https://github.com/tidyverse/purrr/issues/538
    age <- x %>%
      fs::path_dir() %>% 
      fs::path("age", ext = "csv") %>% 
      readr::read_csv(col_names = FALSE, col_types = c("ii"), skip = 1) %>% 
      select(2) %>% 
      deframe()
    gender <- x %>%
      fs::path_dir() %>% 
      fs::path("gender", ext = "csv") %>% 
      readr::read_csv(col_names = FALSE, col_types = c("ic"), skip = 1, na = "no response") %>% 
      select(2) %>% 
      deframe()
    tibble(
      name = name,
      group = "zaw17",
      gender = gender,
      age = age,
      time = time,
      condition = condition,
      sort = list(sort)
    )
  }) %>% 
  # drop all completely empty sorts
  dplyr::filter(
    !all(is.na(sort[[1]]))
  )
zaw17 <- zaw17 %>% 
  # retain only latest date
  arrange(name, condition, time) %>% 
  group_by(name, condition) %>% 
  dplyr::filter(time == last(time)) %>% 
  ungroup() 

# transform to canonical form
zaw17$sort <- plyr::laply(.data = zaw17$sort, .fun = function(x) {
  as_psClosedSorts(obj = x, items = concourse$handle, grid = grids$zaw17)
})

sorts <- rbind.data.frame(sorts, zaw17)
# notice: item feedback is all just typos, not necessary to be imported here
```

```{r gs_entry, eval = FALSE}
# this reads in everything from googlesheets
library(googlesheets)
ts18_entry <- gs_title(x = "sublab", verbose = TRUE)
walk(.x = gs_ws_ls(ts18_entry), .f = function(x) {
  gs_read(ss = ts18_entry, ws = x, range = "A3:K9", col_names = FALSE, na = c("#N/A")) %>% 
    write_csv(path = fs::path("raw/2018-05 students and team/", x, ext = "csv"), append = FALSE, col_names = FALSE)
})
```


```{r ts18, message=FALSE}
ts18 <- map_dfr(
  .x = fs::dir_ls(path = "raw/2018-05 students and team/", glob = "*.csv", all = TRUE), 
  .f = function(x) {
    filename <- fs::path_file(path = x)
    name <- stringr::str_split(string = filename, pattern = "_", simplify = TRUE)[1,1]
    condition <- stringr::str_split(string = filename, pattern = "_", simplify = TRUE)[1,2] %>% 
      fs::path_ext_remove() %>% 
      unclass()
    sort <- readr::read_csv(file = x, col_names = FALSE, col_types = "ccccccccccc") %>% 
      as.matrix() %>% 
      as_psSort()
    validate_S3(x = sort, grid = grids$ts_18, items = concourse$handle)
    if (name %in% c("ailin", "nemo", "RedWine")) {
      # those are the students
      group <- "students_18"
      # TODO add times as per the jpegs to retain the order of conditions
      time <- lubridate::ymd("20180419", tz = "Europe/Berlin")
    } else {
      # this is the team
      group <- "team"
      time <- lubridate::ymd("20180613", tz = "Europe/Berlin")
    }
    tibble::tibble(
      name = name,
      time = time,
      condition = condition,
      sort = list(sort),
      group = group
    )
})

ts18$sort <- plyr::laply(.data = ts18$sort, .fun = function(x) {
  as_psClosedSorts(obj = x, grid = grids$ts_18, items = concourse$handle)
})
# TODO dplyr bind_row would be nicer, but does not yet work with matrix columns
sorts <- add_row(.data = sorts, name = ts18$name, group = ts18$group, time = ts18$time, condition = ts18$condition, sort = ts18$sort)
```


```{r zaw16_students, warnings = FALSE}
rawdat <- NULL
rawdat$students16 <- read.csv(file = "raw/2016-07-Students.csv",
                              header = TRUE,
                              sep = ";",
                              na.strings = "",
                              stringsAsFactors = FALSE)
rawdat$zaw16 <- read.csv(file = "raw/2016-09-ZAW40.csv",
                         header = TRUE,
                         sep = ";",
                         na.strings = "",
                         stringsAsFactors = FALSE)

# always first students16, then zaw16
group <- c(rep("students16", nrow(rawdat$students16)),
           rep("zaw16", nrow(rawdat$zaw16)))
userid <- c(rawdat$students16$form3, rawdat$zaw16$form1)
gender <- c(rawdat$students16$form0, rawdat$zaw16$form0)
gender <- factor(x = gender,
                 levels = c(0:2),
                 labels = c("male", "female", "other"),
                 exclude = 3)
agegroup <- c(rawdat$students16$form1, rep(NA, nrow(rawdat$zaw16)))
agegroup <- ordered(x = agegroup,
                    levels = c(0:4),
                    exclude = 5,
                    labels = c("younger than 16", "17 to 18", "19 to 21", "22 to 24", "24 or older"))

condition <- c(rawdat$students16$form2, rep(0, nrow(rawdat$zaw16)))  # zaw16 only did "desirable"
condition <- factor(x = condition,
                     levels = c(0:1),
                     labels = c("desirable", "probable"))
condition <- as.character(condition)

# fix time
datetime <- strptime(x = c(rawdat$students16$datetime, rawdat$zaw16$datetime), format = "%Y-%m-%d %H:%M:%S", tz = "CET")

# fix durations
durations <- rbind(rawdat$students16[, c("dur0", "dur1", "dur2", "dur3", "dur4", "dur5")],
                   rawdat$zaw16[, c("dur0", "dur1", "dur2", "dur3", "dur4", "dur5")])
colnames(durations) <- c("dur_info", "dur_roughsort", "dur_mainsort", "dur_checksort", "dur_extstat", "dur_survey")
durations <- durations/60  # make this into minutes

# comments
comments_neg <- c(rawdat$students16$comment18, rawdat$zaw16$comment6)
comments_pos <- c(rawdat$students16$comment8, rawdat$zaw16$comment35)

# fix q data ==========
qdata <- rbind(rawdat$students16[,3:43], rawdat$zaw16[,3:43])

concourse$number <- concourse$id
concourse$id <- paste0("s", concourse$id)
checkmate::assert_set_equal(x = colnames(qdata), y = concourse$id)
colnames(qdata) <- concourse$handle

# now put everything in the right order and back in place ====
cleandat <- cbind(userid,
                  datetime,
                  agegroup,
                  gender,
                  group,
                  condition,
                  qdata,
                  durations,
                  comments_neg,
                  comments_pos,
                  deparse.level = 2,
                  stringsAsFactors = FALSE)

# kill early tests
cleandat <- cleandat[cleandat$userid != "123", ]
cleandat <- cleandat[cleandat$userid != "MartinTest", ]

# add peoplevars
peoplevars <- data.frame(userid = unique(cleandat$userid))
peoplevars <- cbind(peoplevars, cleandat[match(peoplevars$userid, cleandat$userid), c("agegroup", "gender", "group")])
peoplevars[peoplevars$userid %in% c("Bernadette", "Jan", "Christiane"), "group"] <- "team"  # this was another team member.
peoplevars$group <- as.factor(peoplevars$group)
peoplevars$userid <- as.character(peoplevars$userid)
peoplevars$selfid <- suppressWarnings(is.na(as.integer(peoplevars$userid)))
peoplevars$name <- peoplevars$userid
# just add some manual fake names to improve looks
# real anonymization is not necessary here, because numbers are anon to begin with
peoplevars$name[!(peoplevars$selfid)] <- c("Christian",
                                           "Lisa",
                                           "Matthias",
                                           "Julia",
                                           "Tom",
                                           "Susanne",
                                           "Alex",
                                           "Gudrun",
                                           "Vanessa",
                                           "Tony",
                                           "Lars",
                                           "Rene",
                                           "Peter",
                                           "Andrea",
                                           "Werner",
                                           "Renate",
                                           "Konstanze",
                                           "Linda")
# deanonimyze team members
peoplevars$name[peoplevars$name == "Jan"] <- "Max16"
peoplevars$name[peoplevars$name == "Christiane"] <- "Sabine16"
peoplevars$name[peoplevars$name == "Bernadette"] <- "Verena16"

# extract qdata
qdes <- cleandat[cleandat$condition == "desirable", concourse$handle]
rownames(qdes) <- cleandat[cleandat$condition == "desirable", "userid"]
qdes <- t(qdes)
qprob <- cleandat[cleandat$condition == "probable", concourse$handle]
rownames(qprob) <- cleandat[cleandat$condition == "probable", "userid"]
qprob <- t(qprob)
qres <- NULL
qres$desirable <- qdes
qres$probable <- qprob

# add single papersort ====
# this was done the night before zaw2016 by a team member
peoplevars <- rbind(peoplevars, data.frame(userid = "testemployee",
                                           agegroup = NA,
                                           gender = "male",
                                           group = "team",
                                           selfid = FALSE,
                                           name = "Robert"))
papersort <- readxl::read_xlsx(path = "raw/papersorts/papersorts.xlsx")
qres$desirable <- cbind(qres$desirable, testemployee = papersort$desirable)
qres$probable <- cbind(qres$probable, testemployee = papersort$probable)

# add screenshotted qsorts ====
# these were the cases whre HTML5Q just glitched out
glitchies <- readxl::excel_sheets(path = "raw/2016 zaw40 and students/screenshots.xlsx")[-c(1,2)]
screenshots <- sapply(X = glitchies, simplify = FALSE, USE.NAMES = TRUE, FUN = function(x) {
  res <- readxl::read_xlsx(path = "raw/2016 zaw40 and students/screenshots.xlsx", sheet = x, range = "B1:L7", col_names = FALSE)
  colnames(res) <- as.character(-5:5)
  return(res)
})

# intermediate helper
# TODO this should be a pensieve feature
meltsorts <- function(x, lookup) {
  long <- reshape2::melt(x, factorsAsStrings = FALSE)
  colnames(long) <- c("x", "item")
  long$x <- as.numeric(as.character(long$x))
  res <- long[match(x = lookup$number, table = long$item), "x"]
  res <- as.matrix(res)
  rownames(res) <- lookup$handle
  return(res)
}

# zaw16 glitchies
glitchies_stg <- c("stg-jane-doe", "Hanswurst", "stg-anna", "stg-search", "stg-emma")
peoplevars <- rbind(peoplevars, data.frame(
  userid = glitchies_stg,
  agegroup = NA,
  gender = c("female", "male", "female", NA, "female"),
  group = "zaw16",
  selfid = c(FALSE, TRUE, TRUE, TRUE, TRUE),
  name = c("Jane", "Hans", "Anna", "Search", "Emma")
))
# only desirable was gathered, so this is all we need
qres$desirable <- cbind(
  qres$desirable,
  sapply(X = glitchies_stg, simplify = TRUE, USE.NAMES = TRUE, FUN = function(x) {
    meltsorts(x = screenshots[[x]], lookup = concourse[, c("number", "handle")])
  })
)

# there are also two student16 participants for whom *both* conditions glitched out, so we're adding them here
peoplevars <- rbind(peoplevars, data.frame(
  userid = c("4", "14"),
  agegroup = NA,
  gender = NA,
  group = "students16",
  selfid = c(FALSE, FALSE),
  name = c("Anette", "Anton")
))
# there is no definitive source on whether these are doable or desirable; this is just an educated guess
qres$desirable <- cbind(
  qres$desirable,
  sapply(
    X = c("14a", "4b"),
    simplify = TRUE,
    USE.NAMES = TRUE,
    FUN = function(x) {
      meltsorts(x = screenshots[[x]], lookup = concourse[, c("number", "handle")])
    }
  )
)
colnames(qres$desirable)[colnames(qres$desirable) == "14a"] <- "14"
colnames(qres$desirable)[colnames(qres$desirable) == "4b"] <- "4"
qres$probable <- cbind(
  qres$probable,
  sapply(
    X = c("14b", "4a"),
    simplify = TRUE,
    USE.NAMES = TRUE,
    FUN = function(x) {
      meltsorts(x = screenshots[[x]], lookup = concourse[, c("number", "handle")])
    }
  )
)
colnames(qres$probable)[colnames(qres$probable) == "14b"] <- "14"
colnames(qres$probable)[colnames(qres$probable) == "4a"] <- "4"

comments <- sorts_16 <- array(data = NA,
                           dim = c(nrow(qprob), nrow(peoplevars), 2),
                           dimnames = list(items = rownames(qprob), 
                                           people = peoplevars$name,
                                           condition = c("desirable", "probable")))
for (cond in names(qres)) {  # co for conditions
  for (p in colnames(qres[[cond]])) {  # p for people
    pname <- peoplevars[peoplevars$userid == p, "name"]
    for (i in rownames(qres[[cond]])) {  # i for items
      # easy part: the qsorts
      sorts_16[i, pname, cond] <- qres[[cond]][i, p]
    }  
      # now for the comments
    for (v in c("comments_neg", "comments_pos")) {  # v for valence of comment
      current_comment <- cleandat[cleandat$userid == p & cleandat$condition == cond, v]  # get the full comment
      if (length(current_comment) > 0) {  # empty char if there is no feedback
       current_split <- stringr::str_split(string = current_comment, pattern = "[)][ ]", simplify = FALSE)[[1]]  # split it in statement id and actual text
       current_text <- current_split[2]
       current_id <- stringr::str_extract(string = current_split[1], pattern = "[s]\\d{1,2}")  # always takes the form of s22 etc
       current_handle <- as.character(concourse[concourse$id == current_id, "handle"])  # replace with handle
       comments[current_handle, pname, cond] <- current_text  
      }
    }
  }
}

# these all match perfectly with regard to desirable/probable
sorts_16[,"Renate", "desirable"] <- meltsorts(x = screenshots$`7b`, lookup = concourse[, c("number", "handle")])[,1]
sorts_16[,"Christian", "desirable"] <- meltsorts(x = screenshots$`23a`, lookup = concourse[, c("number", "handle")])[,1]
sorts_16[,"Sabine16", "probable"] <- meltsorts(x = screenshots$`sabine-wahrscheinlich`, lookup = concourse[, c("number", "handle")])[,1]
sorts_16[,"Linda", "probable"] <- meltsorts(x = screenshots$`5a`, lookup = concourse[, c("number", "handle")])[,1]
sorts_16[,"Tony", "probable"] <- meltsorts(x = screenshots$`19a`, lookup = concourse[, c("number", "handle")])[,1]
sorts_16[,"Lars", "probable"] <- meltsorts(x = screenshots$`12b`, lookup = concourse[, c("number", "handle")])[,1]

# add written feedback from 2016 students
# feedback template does not specify whether this is for desirable/doable, so we're assigning it to both
# this kind of feedback is *also* imported as github issues to improve the items; that's what it was about, but we'll include it here, too, because it can be substantively interesting.
comments["live_2_work", peoplevars[peoplevars$userid == "7", "name"], ] <- "Interpretationsproblem: Lebt man nur um zu arbeiten, oder ist Arbeit Teil meines Lebens?"
comments["own_boss", peoplevars[peoplevars$userid == "9", "name"], ] <- "bezogen auf die Arbeit oder mein Leben?"

# robert had a hex sort, now we store this differently
sorts_16[,"Robert",] <- sorts_16[,"Robert",] * 2

# fix nonconforming dimname
dimnames(sorts_16)$people[dimnames(sorts_16)$people == "Biene Maja"] <- "Biene_Maja"
dimnames(comments)$people[dimnames(comments)$people == "Biene Maja"] <- "Biene_Maja"
peoplevars[peoplevars$name == "Biene Maja", ] <- "Biene_Maja"

# separate them out
zaw_students_team16 <- list(
  desirable = sorts_16[,,"desirable"],
  probable = sorts_16[,,"probable"]
)
zaw_students_team16 <- imap(.x = zaw_students_team16, .f = function(x, condname) {
  # delete completely empty sorts
  empties <- plyr::aaply(
    .data = x, 
    .margins = 2,
    .fun = function(col) {
      all(is.na(col))
    }
  )
  x <- x[,!empties]
  x <- psClosedSorts(t(x))
  # validation is currently impossible because robert (with a hex grid) is in here
  
  these_peoplevars <- peoplevars %>% 
    as_tibble() %>% 
    right_join(tibble(name = rownames(x)), by = "name") %>% 
    dplyr::filter(name %in% rownames(x)) %>% 
    dplyr::mutate(
      age = recode(
        agegroup,
        `younger than 16` = 16,  # very unlikely that there were younger people
        `17 to 18` = 17,  # this should have been 16 to 18
        `19 to 21` = 20,  # just take the midpoint
        `22 to 24` = 23
        # older than 24 gets NA by default
      ),
      # TODO we have actual datetimes (for html5tools), but those are not currently used
      time = recode(
        group,
        students16 = lubridate::ymd_hms("20160715_160000", tz = "Europe/Berlin"),
        team = lubridate::ymd_hms("20160715_130000", tz = "Europe/Berlin"),  # same date as students
        zaw16 = lubridate::ymd_hms("20160919_140000", tz = "Europe/Berlin")
      )
    )
    
  tibble::tibble(
    name = these_peoplevars$name,
    group = these_peoplevars$group,
    gender = as.character(these_peoplevars$gender),
    age = rlang::as_integer(these_peoplevars$age),
    time = these_peoplevars$time,
    condition = condname,
    sort = x,
    comments = t(comments[colnames(x),rownames(x),condname])
  )
})

zaw_students_team16 <- do.call(rbind, zaw_students_team16)

sorts <- add_row(
  .data = zaw_students_team16, 
  name = sorts$name, 
  group = sorts$group,
  gender = sorts$gender,
  age = sorts$age,
  time = sorts$time,
  condition = sorts$condition,
  sort = sorts$sort
)
```


### Studienanleitung (Condition of Instruction)

Vielen Dank, dass Sie an unserer Studie über die Subjektivität zur Arbeit teilnehmen.

<!-- Bitte klicken Sie auf den "Fortsetzen"-Button. -->

Stellen Sie sich vor, Sie treffen sich in einige Jahre nach ihrem Abschluss erneut mit ihren Kommilitoninnen und Kommilitonen.
Sie kommen ins Gespräch, und reflektieren über ihre zukünftige Arbeit.

Bitte beantworten Sie uns in dieser fiktiven Situation **zwei Fragen**, in dieser Reihenfolge:

- a) Was *möchten* Sie dann über ihre Arbeit sagen können, also wie *soll* ihre Arbeit der Zukunft aussehen?
- b) Was *werden* Sie *wahrscheinlich* über ihre Arbeit sagen können, also wie *wird* ihre Arbeit der Zukunft aussehen?

Sortieren Sie die folgenden Aussagen danach, wie sehr sie auf ihre fiktive zukünftive Einschätzung ihrer Arbeit zutreffen.


<!-- Bitte gehen Sie dabei wie folgt vor: -->

<!-- 1. Lesen Sie alle Karten einmal durch. -->
<!-- 2. Sortieren Sie die Karten grob in drei Kategorien. -->
<!-- 	Die Kategorien müssen *nicht* gleich groß sein. -->
<!-- 	1. Karten, dessen Inhalt Sie eher für unzutreffend halten, legen Sie auf einem Stapel rechts von der Schablone ab. -->
<!-- 	2. Karten, dessen Inhalt Sie eher für zutreffend halten, legen Sie auf einen Stapel links von der Schablone ab. -->
<!-- 	3. Karten, dessen Inhalt Sie neutral gegenüberstehen, widersprüchliche Reaktionen haben oder die Sie nicht verstehen legen Sie vor Ihnen über der Schablone ab. -->
<!-- 3. Konzentrieren Sie sich auf die Karten aus Kategorie **a**.  -->
<!-- 	Sortieren Sie die Karten nach dem Grad ihrer Zustimmung. -->
<!-- 	Beginnen Sie mit den Karten, denen Sie am meisten zustimmen und belegen Sie entsprechend die Felder vom rechten Rand der Schablone ausgehend. -->
<!-- 4. Wenn Sie mit den Karten der Kategorie **a** fertig sind, tragen Sie die Umrisse der ausgefüllten Felder in die beiliegende Tabelle ein. -->
<!-- 5. Machen Sie mit den Karten aus Kategorie **b** weiter. -->
<!-- 	Verfahren Sie wie in Schritt 3; beginnend mit den Karten deren Inhalt Sie am meisten ablehnen. -->
<!-- 	Belegen Sie mit diesen die Felder ausgehend vom linken Rand der Schablone. -->
<!-- 6. Tragen Sie erneut die entstandenen Umrisse in die beiliegende Tabelle ein. -->
<!-- 7. Verteilen Sie die verbleibenden Karten aus Kategorie **c** auf die leeren Felder entsprechend Ihrem Grad der Zustimmung. -->
<!-- 8. Kontrollieren Sie noch einmal die Verteilung aller Karten und nehmen Sie bei Bedarf Änderungen vor. -->
<!-- 9. Notieren Sie die Position der Karten anhand der Kennungen (etwa: `C21`) in der beiligenden Tabelle und benachrichtigen Sie den Umfrageleiter. -->


Bitte beachten Sie dabei:

- Es gibt *keine richtigen oder falschen Sortierungen*.
	Ihre subjektive Einstellung und Interpretation zu den Aussagen auf den Karten zählt.
- Wenn Sie ein Item nicht verstehen, es Ihnen sinnlos erscheint oder Sie der Aussage ambivalent gegenüber stehen, sortieren Sie *zwischen* ihre positiven (zutreffenden) und negativen (nicht zutreffenden) Items oder über den Nullpunkt in der Mitte.
  In beiden Fällen werden wir Ihre Sortierung entsprechend in der Analyse berücksichtigen.
  Auch wenn Sie zu einem Item *keine* klare Einstellung haben, ist das für uns eine wichtige Information und Ausdruck Ihrer legitimen Subjektivität.
- Der Nullpunkt auf der Schablone ist bedeutungslos.
	Der Wert **–1** muss etwa nicht heißen, dass Sie einer dort gelegten Karte widersprechen; es deutet lediglich an, dass sie einer dort gelegten Karte *weniger* zustimmen als einer bei **0** gelegten Karte.
	Nur *relative* Positionen der Karten zählen.
- Nur die horizontale Position (von links nach rechts) der Karten ist bedeutsam.
	Die vertikale Position (von oben oder unten) innerhalb einer Spalte sagt nichts aus.
- Alle Karten müssen gelegt werden, und alle Felder belegt.
- Notieren Sie sich jederzeit Anmerkungen oder Ergänzungen zu den einzelnen Karten, auf dem separaten Feedback-Bogen.
- Sie können unten stehend auch eigene Aussagen für zukünftige Q-Sortierungen vorschlagen.
	Diese neuen Karten können Sie allerdings dieses Mal noch nicht in der Sortierung berücksichtigen.

Bitte gehen Sie nun auf die Website **`http://labouratory.de/qsort`** um an der Erhebung teilzunehmen.

\newpage

## Eigene Vorschläge für Items


### Durchgang A Positiv

Bitte nennen Sie uns ein fehlendes Item, dass Sie für *wünschenswert* gehalten hätten.
(Also ein Item, das im Durchgang a) ganz rechts gelegen hätte).

\vspace{70pt}

### Durchgang A Negativ

Bitte nennen Sie uns ein fehlendes Item, dass Sie für *nicht wünschenswert* gehalten hätten.
(Also ein Item, das im Durchgang a) ganz links gelegen hätte).

\vspace{70pt}

### Durchgang B Positiv

Bitte nennen Sie uns ein fehlendes Item, dass Sie für *wahrscheinlich* gehalten hätten.
(Also ein Item, das im Durchgang b) ganz rechts gelegen hätte).

\vspace{70pt}

### Durchgang B Negativ

Bitte nennen Sie uns ein fehlendes Item, dass Sie für *nicht wahrscheinlich* gehalten hätten.
(Also ein Item, das im Durchgang b) ganz links gelegen hätte).

\vspace{70pt}


# Analysis

## Correlations

We first consider simply the correlations of the Q-datamatrix, that is, the correlations *between people-variables*  across *item_cases*.
To at least approximate the ordinal (not interval) nature of the Q data collection, especially under a *forced distribution*, the correlations are calculated using Spearman's $\rho$, not the customary Pearson's $\rho$.

```{r illustrate}
# ms$desirable
```

```{r}
ms <- imap(.x = c(desirable = "desirable", probable = "probable"), .f = function(x, y) {
  des <- dplyr::filter(.data = sorts, condition == x)
  pull(des, sort) %>% 
    set_colnames(colnames(sorts$sort)) %>% 
    set_rownames(des$name) %>% 
    t()
})
```

```{r cors}
cors <- imap(.x = ms, .f = function(x, y) {
  cor(x = x, method = "spearman", use = "pairwise.complete.obs") %>% 
    QCors()
})
gridExtra::grid.arrange(
  plot(cors$desirable, use_js = FALSE, summarize = FALSE) + ggtitle("desirable"),
  plot(cors$probable, use_js = FALSE, summarize = FALSE) + ggtitle("probable")
)
```

```{r cors_histo}
df <- imap_dfr(.x = cors, .id = "condition", .f = function(x, y) {
  x[upper.tri(x = x, diag = TRUE)] <- NA
  as_tibble(reshape2::melt(data = x, na.rm = TRUE))
})
ggplot(data = df, mapping = aes(x = value, colour = condition)) + 
  geom_density() + xlim(-1, 1)
```

Typical for some Q data, there are also less negative correlations than positive correlations, indicating that people do *not*, on the surface, hold polar opposite as beliefs.

## Factor Extraction

```{r paran, cache = TRUE}
# TODO make this work with above correlation method specials
parans <- imap(.x = cors, .f = function(x, y) {
  psych::fa.parallel(
    x = x, 
    n.obs = nrow(ms[[y]]), 
    fm = "pa", 
    fa = "pc", 
    main = y, 
    error.bars = TRUE,
    se.bars = TRUE,
    quant = .95,
    use = "pairwise",
    n.iter = 5000
  )
})
```

```{r extraction}
pcas <- imap(.x = cors, .f = function(x, y) {
  psych::principal(
    r = x,
    nfactors = parans[[y]][["ncomp"]],
    residuals = FALSE,
    rotate = "quartimax",
    missing = TRUE,
    impute = "mean"
  )
})
```

```{r loas}
loas <- imap(.x = pcas, .f = function(x, y) {
  x$loadings %>% 
    unclass %>% 
    set_colnames(x = ., value = paste(y, colnames(.), sep = "_"))
})
```

```{r loas1}
imap(.x = loas, .f = function(x, y) {
  GGally::ggpairs(
    data = as.data.frame(x),
    upper = list(continuous = "density"),
    diag = list(continuous = "densityDiag")
  ) + 
    ggtitle(y)
})
```

```{r loas2, eval = FALSE}
imap(.x = loas, .f = function(x, y) {
  # only show team names
  teamies <- sorts %>% 
    dplyr::filter(group == "team") %>% 
    pull(name)
  names <- rownames(x)
  names[!(names %in% teamies)] <- NA
  
  # add other vars
  demos <- sorts %>% 
    dplyr::filter(name %in% rownames(x), condition == y) %>% 
    select(name, group, gender) %>% 
    right_join(tibble(name = rownames(x)), by = "name")
  
  ggplot(
    data = x, 
    mapping = aes_(
      x = as.name(colnames(x)[1]), 
      y = as.name(colnames(x)[2]), 
      label = names, 
      colour = demos$group, 
      shape = demos$gender
    )
  ) + 
    ggtitle(y) +
    xlim(c(-1,1)) + ylim(c(-1,1)) + coord_fixed() +
    geom_density2d(mapping = aes(colour = NULL, shape = NULL)) +
    geom_point() + 
    ggrepel::geom_label_repel() +
    scale_shape_manual(na.value = 0, values = c(5, 6))
}) %>% 
  invoke(.f = gridExtra::grid.arrange, .x = .)
```

```{r loas3, eval=FALSE}
teamies <- sorts %>% 
    dplyr::filter(group == "team") %>% 
    pull(name)
  names <- rownames(loas$desirable)
  names[!(names %in% teamies)] <- NA

imap_dfr(.x = loas, .id = "condition", .f = function(x, y) {
  x^2 %>% 
    reshape2::melt()
}) %>% 
    dplyr::filter(Var1 %in% names) %>% 
    ggplot(mapping = aes(x = Var1, y = value, fill = Var2)) +
    geom_bar(stat = "identity") + 
    coord_flip() + 
    facet_wrap(vars(condition))
```

## Factor Scores

```{r calc_scores}
scores <- imap(.x = loas, .f = function(x, y) {
  psych::factor.scores(x = ms[[y]], f = x, impute = "mean")$scores %>% 
    scale(center = TRUE, scale = TRUE)
})
```

```{r 1d_all}
it_order <- dplyr::arrange(
  .data = as_tibble(cbind(scores$desirable, scores$probable), rownames = "items"), 
  probable_RC3
)


imap_dfr(.x = scores, .id = "condition", .f = function(x, y) {
  reshape2::melt(x)
}) %>% 
  set_colnames(value = c("condition", "item", "component", "score")) %>% 
  ggplot(mapping = aes(x = score, y = item, colour = component)) +
  geom_point() + 
  scale_y_discrete(limits = it_order$items)
```


```{r 1d_sd}
df <- reshape2::melt(ms$probable, value.name = "sort")
colnames(df) <- c("item", "participant", "sort")
# merge on loas
df <- merge(x = df, y = loas$probable, by.y = "row.names", by.x = "participant")
df$p <- df$sort * df$probable_RC1^2

it_order <- dplyr::arrange(.data = as_tibble(cbind(scores$desirable, scores$probable), rownames = "items"), desirable_RC1)

# this_score <- tibble(item = rownames(scores$probable), score = scores$probable[,1])

# df <- merge(x = df, y = this_score, by = "item")
df_range <- range(df$p, na.rm = TRUE) %>% 
  abs() %>% 
  max() %>% 
  c(-., .)
ggplot(data = df, mapping = aes(x = p, y = item, fill = 0.5 - abs(0.5-..ecdf..))) +
  ggridges::stat_density_ridges(geom = "density_ridges_gradient", calc_ecdf = TRUE) + 
  viridis::scale_fill_viridis(name = "Tail probability", direction = -1) +
  scale_y_discrete(limits = it_order$items)
```


```{r 2d}
score_range <- range(scores) %>% 
  abs() %>% 
  max() %>% 
  c(-., .)
scores_df <- as.data.frame(cbind(scores$desirable, scores$probable))
combs <- expand.grid(colnames(scores_df)[1:2], colnames(scores_df)[3:5])
gs <- map2(
  .x = as.character(combs$Var1), 
  .y = as.character(combs$Var2), 
  .f = function(x, y) {
    scores_df %>% 
      ggplot(mapping = aes_(x = as.name(x), y = as.name(y), label = rownames(scores_df))) +
      geom_smooth(method = "lm") +
      geom_point() +
      ggrepel::geom_label_repel() +
      xlim(score_range) + ylim(score_range) + coord_fixed()
  })
invoke(.f = gridExtra::grid.arrange, .x = gs, nrow = 2)
```


```{r comp, eval = FALSE}
qmethod::q.compplot(results = res$des)
qmethod::q.compplot(results = res$prob)
```

```{r scores, eval = FALSE}
qmethod::q.scoreplot.ord(results = res$des, factor = 1, incl.qdc = FALSE, quietly = FALSE)
qmethod::q.scoreplot.ord(results = res$des, factor = 2, incl.qdc = FALSE, quietly = FALSE)
qmethod::q.scoreplot.ord(results = res$prob, factor = 1, incl.qdc = FALSE, quietly = FALSE)
qmethod::q.scoreplot.ord(results = res$prob, factor = 2, incl.qdc = FALSE, quietly = FALSE)
```

```{r cors twodim, eval = FALSE}
apply(X = fullsorts, MARGIN = 2, FUN = function(x) {
  cor(x = x, method = "spearman")
})
```

```{r paran2, eval = FALSE}
paran::paran(x = sorts[,,"desirable"], iterations = 10000)
paran::paran(x = sorts[,,"probable"], iterations = 10000)
```

```{r, eval = FALSE}
zwares <- NULL
zwares$desirable <- qmethod::qmethod(dataset = sorts[,,"desirable"], 
                                     nfactors = 1, 
                                     rotation = "none", 
                                     forced = FALSE, 
                                     distribution = rep(x = c(min(sorts, na.rm = TRUE):max(sorts, na.rm = TRUE)), times = distro),
                                     threshold = "none",
                                     allow.confounded = TRUE)
zwares$probable <- qmethod::qmethod(dataset = sorts[,,"probable"], 
                                     nfactors = 3, 
                                     rotation = "varimax", 
                                     forced = FALSE, 
                                     distribution = rep(x = c(min(sorts, na.rm = TRUE):max(sorts, na.rm = TRUE)), times = distro),
                                     threshold = "none",
                                     allow.confounded = TRUE)
zwares$desirable$loa
zwares$probable$loa

q.scoreplot.ord(results = zwares$desirable, factor = 1, incl.qdc = FALSE)

alloas <- cbind(zwares$desirable$loa, zwares$probable$loa, names = rownames(zwares$probable$loa), gruppe = peoplevars$group[peoplevars$name %in% rownames(zwares$desirable$loa)])
colnames(alloas)[1:4] <- c("desirable", "probable-1", "probable-2", "probable-3")

allscores <- cbind(zwares$desirable$zsc, zwares$probable$zsc, kurz = concourse$handle, text = concourse$english)
colnames(allscores)[1:4] <- c("desirable", "probable-1", "probable-2", "probable-3")

loa1 <- ggplot(data = alloas, mapping = aes(x = desirable, y = `probable-1`, label = names, shape = gruppe))
loa1 <- loa1 + geom_point(color = "blue")
loa1 <- loa1 + ggrepel::geom_text_repel()
dev.new()
loa1

loa2 <- ggplot(data = alloas, mapping = aes(x = desirable, y = `probable-2`, label = names, shape = gruppe))
loa2 <- loa2 + geom_point(color = "blue")
loa2 <- loa2 + ggrepel::geom_text_repel()
dev.new()
loa2

loa3 <- ggplot(data = alloas, mapping = aes(x = desirable, y = `probable-3`, label = names, shape = gruppe))
loa3 <- loa3 + geom_point(color = "blue")
loa3 <- loa3 + ggrepel::geom_text_repel()
dev.new()
loa3

score1 <- ggplot(data = allscores, mapping = aes(x = desirable, y = `probable-1`, label = kurz))
score1 <- score1 + geom_point(color = "blue")
score1 <- score1 + ggrepel::geom_text_repel()
score1
score2 <- ggplot(data = allscores, mapping = aes(x = desirable, y = `probable-2`, label = kurz))
score2 <- score2 + geom_point(color = "red")
score2 <- score2 + ggrepel::geom_text_repel()
score2
dev.new()
score3 <- ggplot(data = allscores, mapping = aes(x = desirable, y = `probable-3`, label = kurz))
score3 <- score3 + geom_point(color = "green")
score3 <- score3 + ggrepel::geom_text_repel()
score3

```


## References