From f1ab2f022fdc780aca0944d90e9a0e844a0820d7 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Anton=20Luka=20=C5=A0ijanec?= Date: Mon, 27 May 2024 13:12:17 +0200 Subject: =?UTF-8?q?2024-02-19:=20popravljen=20(prej=C5=A1nji=20commit=20je?= =?UTF-8?q?=20napa=C4=8Den)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../survey/modules/mod_kakovost/R/calc.usability.R | 72 -------- .../survey/modules/mod_kakovost/R/gen.survey.str.R | 71 -------- .../modules/mod_kakovost/R/gen.usability.matrix.R | 181 --------------------- 3 files changed, 324 deletions(-) delete mode 100644 admin/survey/modules/mod_kakovost/R/calc.usability.R delete mode 100644 admin/survey/modules/mod_kakovost/R/gen.survey.str.R delete mode 100644 admin/survey/modules/mod_kakovost/R/gen.usability.matrix.R (limited to 'admin/survey/modules/mod_kakovost/R') diff --git a/admin/survey/modules/mod_kakovost/R/calc.usability.R b/admin/survey/modules/mod_kakovost/R/calc.usability.R deleted file mode 100644 index 4e4bb0c..0000000 --- a/admin/survey/modules/mod_kakovost/R/calc.usability.R +++ /dev/null @@ -1,72 +0,0 @@ -calc.usability <- function(m.all, return.type){ - # return.type: - # 1: return only absolute - # 2: return only % - # 3: return both (even rows: absolute, odd rows: %) - - ## calculations - m.all[, Prekinitve:=v3] - m.all[, Neodgovori:=v1] - m.all[, Nevsebinski:=v96+v97+v98+v99] - m.all[, Izpostavljen:=allqs-(v2+v3+v4+v5)] - setnames(m.all, "va", "Veljavni") - - m.all[, UNL:=Neodgovori/Izpostavljen] - m.all[is.na(UNL)==T, UNL:=0] - m.all[, UML:=(v3/allqs)+(1-(v3/allqs))*UNL] - m.all[, UCL:=1-UML] - m.all[, UIL:=v2/(v2+Izpostavljen)] - m.all[is.na(UIL)==T, UIL:=0] - m.all[, UAQ:=v4/allqs] - - m.all[, Uporabnost:=1-UML] - - #tidy up - setcolorder(m.all, c("recnum", "allqs", "Veljavni", "Nevsebinski", "Neodgovori", - "Izpostavljen", "Prekinitve", "Uporabnost", - "v1", "v2", "v3", "v4", "v5", "v96", "v97", "v98", "v99", - "UNL", "UML", "UCL", "UIL", "UAQ")) - - if(return.type==1){ - return(m.all) - }else{ - m.all.p <- copy(m.all) - - m.all.p[, (c("Veljavni", "Nevsebinski", "Neodgovori")) := lapply(.SD, "/", m.all.p$Izpostavljen), .SDcols=c("Veljavni", "Nevsebinski", "Neodgovori")] - m.all.p[, (c("Prekinitve", "v1", "v2", "v3", "v4", "v5", "v96", "v97", "v98", "v99")) := lapply(.SD, "/", m.all.p$allqs), .SDcols=c("Prekinitve", "v1", "v2", "v3", "v4", "v5", "v96", "v97", "v98", "v99")] - m.all.p[, Izpostavljen:=1] - - if(return.type==2){ - return(m.all.p) - }else{ - m.all[, Uporabnost:=Veljavni] - m.all[, c("UNL", "UML", "UCL", "UIL", "UAQ"):=NA] - m.all <- m.all[, lapply(.SD, as.character)] - - m.all.p[, allqs:=NA] - m.all.p[, allqs:=as.character(allqs)] - - change.cols <- c("Veljavni", "Nevsebinski", "Neodgovori", "Izpostavljen", "Prekinitve", "Uporabnost", - "v1", "v2", "v3", "v4", "v5", "v96", "v97", "v98", "v99", - "UNL", "UML", "UCL", "UIL", "UAQ") - m.all.p[, (change.cols):=lapply(.SD, function(x){paste0(round(x*100, 0), "%")}), .SD=change.cols] - - m.1ka <- data.table(matrix("", nrow=nrow(m.all)*2, ncol=ncol(m.all))) - - a.rows <- as.integer(seq(1, nrow(m.1ka), by=2)) - p.rows <- as.integer(seq(2, nrow(m.1ka), by=2)) - - set(m.1ka, a.rows, 1:ncol(m.1ka), value=m.all) - suppressWarnings(set(m.1ka, p.rows, 1:ncol(m.1ka), value=m.all.p)) - - setnames(m.1ka, colnames(m.all)) - m.1ka[, Status:=NA_character_] - setcolorder(m.1ka, c("recnum", "allqs", "Veljavni", "Nevsebinski", "Neodgovori", - "Izpostavljen", "Prekinitve", "Uporabnost", "Status", - "v1", "v2", "v3", "v4", "v5", "v96", "v97", "v98", "v99", - "UNL", "UML", "UCL", "UIL", "UAQ")) - - return(m.1ka) - } - } -} \ No newline at end of file diff --git a/admin/survey/modules/mod_kakovost/R/gen.survey.str.R b/admin/survey/modules/mod_kakovost/R/gen.survey.str.R deleted file mode 100644 index 32e1f57..0000000 --- a/admin/survey/modules/mod_kakovost/R/gen.survey.str.R +++ /dev/null @@ -1,71 +0,0 @@ -gen.survey.str <- function(colnames.dsa, questions.file, items.file){ - #import questions file - questions <- fread(questions.file, skip=1, header=F, - select=c(2, 5, 6, 8, 9, 10), - col.names=c("question.id", "variable", "tip", "size", "visible", "params")) - - #create variable list from survey data file - #remove "recnum" and "_text" fields - var.data <- colnames.dsa[sapply(colnames.dsa, function(x){substr(x, nchar(x)-4, nchar(x))})!="_text"] - - #create variable list from questions file - var.questions <- questions$variable - - #generate data.table from var.data list - survey.str <- data.table(variable = var.data) - - setkey(questions, "variable") - setkey(survey.str, "variable") - - #if all var.data in var.questions, do the simple merge and return file - if(all(var.data %in% var.questions)){ - survey.str <- questions[survey.str,] - return(survey.str) - }else{ #if not, import items file and do additional merge with it... - #import items file - items <- fread(items.file, skip=1, header=F, - select=c(2, 3, 4), - col.names=c("question.id", "item.id", "variable")) - - setkey(items, "question.id") - setkey(questions, "question.id") - - #bind variables from questions and items (for the later, only take instances with no match in the questions file...) - survey.str.qi <- rbindlist(list(questions[var.questions %in% var.data,], - items[questions[!(var.questions %in% var.data), -"variable", with=F], nomatch=0L]), - fill=T) - - #merge questions+items with survey data... - setkey(survey.str.qi, "variable") - setkey(survey.str, "variable") - survey.str <- survey.str.qi[survey.str,] - - #if all var.data is now matched, return the survey.str - if(!(any(is.na(survey.str)))){ - return(survey.str) - }else{ #if not, do additional merging... - #create index of all NA instaces from survey.str... - index <- apply(cbind(survey.str[, is.na(tip)], - (sapply(survey.str[, variable], function(x){ - substr(x, 1, regexpr("\\_[^\\_]*$", x)-1) - }) %in% survey.str.qi$variable) - ), - 1, all) - - #... using regex to find matches among unmatched instances from survey.str.qi - add <- merge(survey.str[index, list(variable, substr(variable, 1, regexpr("\\_[^\\_]*$", variable)-1))], - survey.str.qi[!(variable %in% survey.str$variable),], - by.x="V2", by.y="variable", all.y=F)[, list(question.id, item.id, tip, visible, size, params)] - - #update survey.str with new values - survey.str[index, c("question.id", "item.id", "tip", "visible", "size", "params") := as.list(add)] - - #if there is no NAs left, return survey.str, else return msg - if(!(any(is.na(survey.str$tip)))){ - return(survey.str) - }else{ - return(paste("No match found for: ", survey.str[is.na(tip), variable])) - } - } - } -} diff --git a/admin/survey/modules/mod_kakovost/R/gen.usability.matrix.R b/admin/survey/modules/mod_kakovost/R/gen.usability.matrix.R deleted file mode 100644 index a2b1465..0000000 --- a/admin/survey/modules/mod_kakovost/R/gen.usability.matrix.R +++ /dev/null @@ -1,181 +0,0 @@ -gen.usability.matrix <- function(dsa, survey.str){ - #define special values to detect - #order of this values is important: - # in case of conflicts @ chk.t types of questions the order sets the priporty of which values to keep - special.v <- c(-1, -3, -5, -96, -97, -98, -99, -4, -2) - - #define which variables belong to checkbox-like* questions - #(* i.e.: check for special values @ ANY variable per question/item ID) - # 2: normal checkbox - # 16: multicheckbox - # 17: ranking - chkbox.t <- c(2, 16, 17) - - ##all other variables belong to normal** questions - #(** i.e.: check for special values @ each variable per question/item ID) - #if there are no normal questions, create 0 matrix, otherwise... - if(nrow(survey.str[!(tip %in% chkbox.t),])==0){ - m.n <- matrix(0, nrow = nrow(dsa), ncol=length(special.v)+1) - }else{ - #create list of all normal questions - c.n <- colnames(dsa)[which(colnames(dsa) %in% survey.str[!(tip %in% chkbox.t), variable])] - - #...count all non-special values for each variable - #... + count each special value for each variable - m.n <- cbind(rowSums(sapply(dsa[, c.n, with=FALSE], function(x){!(x %in% special.v)})), - sapply(special.v, function(x){as.integer(rowSums(dsa[, c.n, with=FALSE]==x, na.rm=TRUE))})) - } - - ##procedure for tip:2 - #only run if there is an at least one tip:2 variable - if(survey.str[, any(tip==2)]){ - #get list of all unique tip:2 question ids - q.2 <- unique(survey.str[tip==2, question.id]) - #get list of all corresponding variables for each q.2 id - c.2 <- lapply(q.2, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[question.id==x & tip==2, variable])]}) - - #(do this for each instance in c.2): - #for each set of variables: - # check if any variable contains at least one non-special value - # + (for each special value) check if any variable contains at least special value - m.2 <- lapply(c.2, function(x){ - cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}), - sapply(special.v, function(y){ - apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)}) - }) - ) - }) - - # (do this for each instance in c.2) - # if multiple special values per respondent exist, keep only the first one - m.2 <- lapply(m.2, function(x){ - if(any(rowSums(x)>1)){ - p <- x[rowSums(x)>1,] - for(i in 1:nrow(p)){ - a <- p[i,] - f <- TRUE - for(j in 1:length(a)){ - print(j) - if(a[j] & f){ - f <- FALSE - }else if(a[j] & !f){ - a[j] <- FALSE - } - } - p[i,] <- a - } - x[rowSums(x)>1,] <- p - }else{x} - }) - - - #add to m.n - m.n <- m.n + Reduce('+', m.2) - } - - ##procedure for tip:16 - #only run if there is an at least one tip:16 variable - if(survey.str[, any(tip==16)]){ - #get list of all unique tip:16 item ids - q.16 <- unique(survey.str[tip==16, item.id]) - - #get list of all corresponding variables for each q.16 id - c.16 <- lapply(q.16, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[item.id==x & tip==16, variable])]}) - #(do this for each special value): - #for each set of variables, check if any variable contains at least one special value - # m.16 <- sapply(special.v, function(x){ - # rowSums(sapply(c.16, function(y){ - # apply(dsa[, y, with=FALSE], 1, function(q){any(q==x)}) - # })) - # }) - - #(do this for each instance in c.16): - #for each set of variables: - # check if any variable contains at least one non-special value - # + (for each special value) check if any variable contains at least special value - m.16 <- lapply(c.16, function(x){ - cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}), - sapply(special.v, function(y){ - apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)}) - }) - ) - }) - - # (do this for each instance in c.16) - # if multiple special values per respondent exist, keep only the first one - m.16 <- lapply(m.16, function(x){ - if(any(rowSums(x)>1)){ - p <- x[rowSums(x)>1,] - for(i in 1:nrow(p)){ - a <- p[i,] - f <- TRUE - for(j in 1:length(a)){ - print(j) - if(a[j] & f){ - f <- FALSE - }else if(a[j] & !f){ - a[j] <- FALSE - } - } - p[i,] <- a - } - x[rowSums(x)>1,] <- p - }else{x} - }) - - m.n <- m.n + Reduce('+', m.16) - } - - ##procedure for tip:17 - #only run if there is an at least one tip:17 variable - if(survey.str[, any(tip==17)]){ - #get list of all unique tip:17 question ids - q.17 <- unique(survey.str[tip==17, question.id]) - - #get list of all corresponding variables for each q.17 id - c.17 <- lapply(q.17, function(x){colnames(dsa)[which(colnames(dsa) %in% survey.str[question.id==x & tip==17, variable])]}) - - #similiar procedure as for tip:2 and tip:16.... - m.17 <- lapply(c.17, function(x){ - cbind(apply(dsa[, x, with=FALSE], 1, function(q){any(!(q %in% special.v))}), - sapply(special.v, function(y){ - apply(dsa[, x, with=FALSE], 1, function(q){any(q==y)}) - }) - ) - }) - - #... the only difference is that we are checking for all rowsums > 0, not > 1 - m.17 <- lapply(m.17, function(x){ - if(any(rowSums(x)>1)){ - p <- x[rowSums(x)>0,] - for(i in 1:nrow(p)){ - a <- p[i,] - f <- TRUE - for(j in 1:length(a)){ - if(a[j] & f){ - f <- FALSE - }else if(a[j] & !f){ - a[j] <- FALSE - } - } - p[i,] <- a - } - x[rowSums(x)>0,] <- p - }else{x} - }) - - m.n <- m.n + Reduce('+', m.17) - } - - m.n <- cbind(m.n, rowSums(m.n)) - - if(all(m.n[, ncol(m.n)][1]==m.n[, ncol(m.n)])){ - m.n <- as.data.table(m.n) - m.n[, recnum:=dsa$recnum] - setnames(m.n, colnames(m.n)[-length(colnames(m.n))], c("va", "v1", "v3", "v5", "v96", "v97", "v98", "v99", "v4", "v2", "allqs")) - setcolorder(m.n, c("recnum", colnames(m.n)[-length(colnames(m.n))])) - return(m.n) - }else{ - print("not all rowsums equal!") - } -} \ No newline at end of file -- cgit v1.2.3