From b55bff0b524e416ed3d6f6e17d563a7493341c65 Mon Sep 17 00:00:00 2001 From: Adam Blake Date: Mon, 9 Nov 2020 18:09:55 -0800 Subject: [PATCH] Include in-text survey items when splitting Before survey items were only found by matching /"^(?:Pre|Post)survey_"/. Instead, a new `survey_item_references` is generated from `survey_item_references.csv` using the script in `survey_item_references.r`. This list of reference IDs is used when splitting out the survey items. --- R/split_responses.R | 15 +++++++++++++-- R/sysdata.rda | Bin 0 -> 5223 bytes data-raw/survey_item_references.r | 8 ++++++++ tests/testthat/test-split_responses.R | 10 +++++----- 4 files changed, 26 insertions(+), 7 deletions(-) create mode 100644 R/sysdata.rda create mode 100644 data-raw/survey_item_references.r diff --git a/R/split_responses.R b/R/split_responses.R index d51c446..173c5cf 100644 --- a/R/split_responses.R +++ b/R/split_responses.R @@ -16,8 +16,19 @@ #' @export split_responses <- function(responses) { ensure_columns(responses, "item_id", stop, "Cannot split responses. ") - surveys <- stringr::str_detect(responses[["item_id"]], "^(?:Pre|Post)survey_") - quizzes <- stringr::str_detect(responses[["item_id"]], ".*_Practice_Quiz.*") + surveys <- survey_item_map(responses) + quizzes <- quiz_item_map(responses) groups <- ifelse(surveys, "surveys", ifelse(quizzes, "quizzes", "in_text")) split(tibble::as_tibble(responses), groups) } + + +survey_item_map <- function(responses) { + item_map_lower <- stringr::str_to_lower(survey_item_references[["item_id"]]) + stringr::str_to_lower(responses[["item_id"]]) %in% item_map_lower +} + + +quiz_item_map <- function(responses) { + stringr::str_detect(responses[["item_id"]], ".*_Practice_Quiz.*") +} diff --git a/R/sysdata.rda b/R/sysdata.rda new file mode 100644 index 0000000000000000000000000000000000000000..9c99812a4ec48310f88a2fcaaa2368ff06e86e58 GIT binary patch literal 5223 zcmV-t6qxHmT4*^jL0KkKS)A zEe+k>^@mH?(!kK##RUMMd)__d=S|3yJDtZd(eHU5ee;LJ_*AQ5s@6n(v`e-E!Jz;M zG6*1z35_z14H{$s(@g--XaE2J5l;z-(V}T0289Dn18M*O0000027mx*BPuX=Vc zAYe??9-1`(FbRk>41*v505UL;kpT@OB4s@?nx2sKA^M@9Xbk`W&;SEK(?A4LnwXku zYI>PHOhyyXnhmHLG|{G-4FCW%&;g*+(lpQ_NP#pU36oPP=|4oo&}ltJN2%#Hpaz-@ zho}LeriO-3nJef}MSubL;21oU9q>1&6;Nz|26j&upr8={5J5_S1cZzTj4Hl3A`8@V z1Clf^;=v=_pWEE|zg9PapwmBe_pP1FnbA+jg;3@;#N|Yx7Tb!vZ9YWk3pd}Cfkk;A+Rn|fN-Ws zz6JN$(O3+IE}ab_v|Awdem4={@2 z-QdHcch1O)3iW5S|>yU_PR;pkZC+c3~q-CD6$ zo?LUZ@Hd-`*6p?6GhYp-OJfv$6dAqXTykl_gujU~3+*5K-#udf~*97yo$L>N&w%5HSe>vf!3+Y#v_C46KLiwEsbO{Ao3VaoFtwKBg}2zMA#;5gVTz_}!Pp*` zGZuSr+d*zxWxF_2G-Y#}n#G+P_#1NI%2{Ql7%;tLXtU$40gABKa{_Cmfq>hSPP3L3 zYgA;GL~siNaJ@~MMZxTA6B8rFVJf;j6o?3`y*g=j7cvam*RH7T)lVU*qNJI$(|Ocj zJ7a+H#>Lz#sd3Jg?iWrQA#`}eAsyX{`xz_*$3>*_sia8ZdV`h<0CfjfuZTXARy!Ph zdGkPaAI&PgarQ9m!H5dlmG=~4%_xME1zZ9$-7#myC2@7U)EffqLpUf>vyj%&RyM|M zktid3Qep_*CnyV-t%EhGGcDlDA#1%RX={yMRctn+!Azb4kOIj=sMr`TQv(9_oEn%p zI@m7bIjIXYQfloZHEI*cT16bIc6KV^AYD;e+_E@|-n6pGRGPjk#Zgq^pk*Q#ip?oZ zfHetdb6D1=UISjkz=)X;@B%zj@(!6^pKl|a%Wcf$K2AWG_W8R=DEl;c>&m)Y3*By1 zL_$UG?C9PiwM)i5xsU@7U8Rf3YJLSJ$;3TIw@TW+U1MM1x1rLu&p3PDivhrJ0Ql={ zi3hCJi(9777%Zz@#V$uFdkykJ$-7axwi4CORaFXwn#9Z-b_?&sLDeGI#ND|1d^Ad!I=)kyhGoA08Uv zw_b}}8*Hr@gdGKV9h;}8MXl!aRa>JB7toPr(WXm0Y^%m0`Q(-q&a+@jP?9qS)zf<& z4tw6yh2S8(qUQ^7_2ex4=!t8wQO-L|-CJX!kHD{@058-zNDb{7RM z7(w8Huj40LK;U@o|#fJ2{uXw%ze$m}<{ zH07ff}mJv9duh#fQ%JaeP(T> zsFXw3FwvDAC{@FN-~zKtle3Dv^}5i72%W7ovlCS~vf!(1P9F3MJr>h~s%^rnP z=44tIU6Lz`mS=chCS3fpEX;|uldWvnCXT8ujSb018?9j~I=0R-7z4~LBEaO>n%K_O zZpw5^u5TG9)_H6vY{0_~&H0Iw#GUN}{r+%S6g zPRnu1)rXA~x>+@TYL<5~vtyf!a(u6aTUW(yIbw0(MT-y%dYv1~q!1g3hA?O)5jhpe zy?PmAEjr{oCI~-32wWpAUkmr9@vmOH;)x19`0k?N3|c}xXFlVpmYSMQ?{ZnGR^(YN z(3%l4;tJbTp(-Z1_0;MORwEj@X+?|UUIGJR1=db0wdTPC8MxJ2+ zAwE%P+m*#~S#3wcxtbdC+OwN|Ir5iecZ?E;M2#TCL+-#SQbkD!MHr*oJDk3~9nT}& z!ir9w0|PMV(h57o6A;PDUt8uRhsjwC-R3sz`9i5=)IrHW-q=M|Vzwtwuoq^QsDDY%M z-}rle1X8>?cvCP0@**7#rO%H)JJZGs9c1Tfb3HpP;`Wd4t?U|_IpV&+(jm?&_(ieY z(v~*&v8e+B$l-paT-1=kcsRRM<*6X8!t1lDw00pQ+xp8)sPo4VfKrYzz z2%i#`q9o=p7)M+8Ozvp~vu5T;1XFZuSGo_qk9AyrKNb3g9AR3N!d)+L7?FCBi4hIx zjK~Zq);o#cvh!+1s?muxe+-SvO%+hlA4Xa%x2@Z-fR6wI9`nsI99h~?Jl1$+OkkL? zp_*2JMS3?h(M6zsI}0oYrpu<>BWt8V2^9KjqO9_<34I=%p)=$7;@J(lz+YawGep{iwHUa$cMd6A4;GUOj5ID|J zhb27mJbp?O!DGXHnA+V_Rb!edNknnA7NkM6iJT;HtlSDva|$4lPq^~xW9Pp`W$bXC zJ4^7bt{9hxdsle$m7 zYag4VTZBTBgEtwf5Kq;O}aciX#$XhGT!5KTu>Ccn6K!AV*YAV`@7o24%s{2hb z(>CzmLEQs!5Hmsm_JAFh7wyrCJuK0-42ISt69(<=aW8s^4l3ld2r1NCFAOKsY10GU zS3CeZ-EWMIK&>zUegk_*REQ8EqaTL2@J6`UK^da0)UO*G64lHo%fneuj>W;s8rew} zbO~onY|=QE;1klc4@mCF#zGU0&qxQM_Xpcy7Z+Cw1cQ>R4_WIuK2j|X$vrKoFZ?c!JykYBrwu+I1?K zO6gh93fJ(3eFVyVUd6XeJHEl3(}wIhsOM^ z|IWqeR8zU%jG{sD+WcFwn+HUPY77_VHhOL;b|yk-a!m;mG)*I@Pm+#aX+fz;K-Ex{ z>633rG(#b%KHRgH8sqlb>1 z`wC`@?l9iVJ%zKcvem2u4rz4PJ8Tqe!YLRvAUD8L5#hd=wW(%<^KyqEgBB*wf@YI501c}(Zl z&Wtkc4~Kd<0iFQW$J!{Y(Oqc^M;xQ3(t*hgDPw!gEVzQT?%8)9udwQe5&FJJ2IPgX zYT)<}$6tZSrdgDwyikK-f^1icQl@K^ggd(o4-$dFuOfwjc9$Jg3k63&z8~Dg-$; z3du)Gko_fOiqO|m`DM(BABqQ?jQ6d}ZgDymSyjW)bYZt7Yo$WVC8K|vLrl|0nmX=5BRu5!pJ;{;75 z0ujVSL8!I42GR;5#1I1Fo?8or0KtHDKp{!p!$E=B1dyiV0Ttq3RLMsim32e4nOkHQ zFd#%B18r@g3S(%fLC7}SqMGoyhht$E3@n1^HTKB~3fc>(0mYe`rUq(yJ#&JMnnPTk zXd5~s21JPh5t0f*PY&hf?M9Liff&XRV&D>zR89^zNT6Y1wVtdBP_C~<7i!WgRJEIf zv0$LJ%I$1|Pzv{;eXO&*W`rh}v1W=Jo6I7agnN@G zLf}%$i&6_A5=S9`ZotXkPNNV*CDMe^`tE$Jl3fPLXvW^w-Q#O+)!*KJld;SkScUI@G zgH{V1CV}ksL0+R136vQTgbEIFApAE`uZDqr5B$G+;oG;*=J8wLB5oi;8AIUuE419g zib3PcV4dU$6O$9U8sY5Z5l?HUCEQKXNt)jOwFb5xdCW3SPLJPkw hw~bd=K~r@+vm4MthyceGKmh-Xxgwk>NKxeb$N+Q#jZ**s literal 0 HcmV?d00001 diff --git a/data-raw/survey_item_references.r b/data-raw/survey_item_references.r new file mode 100644 index 0000000..b1af41e --- /dev/null +++ b/data-raw/survey_item_references.r @@ -0,0 +1,8 @@ +survey_item_references <- read.csv('./data-raw/survey_item_references.csv', na.strings = c("", "NA")) + +logicals <- stringr::str_starts(names(survey_item_references), 'included_v') +survey_item_references[logicals] <- lapply(survey_item_references[logicals], as.logical) + +survey_item_references[!logicals] <- lapply(survey_item_references[!logicals], as.character) + +usethis::use_data(survey_item_references, internal = TRUE, overwrite = TRUE) diff --git a/tests/testthat/test-split_responses.R b/tests/testthat/test-split_responses.R index 521329e..3ca0482 100644 --- a/tests/testthat/test-split_responses.R +++ b/tests/testthat/test-split_responses.R @@ -1,6 +1,6 @@ mock_responses <- tibble::tibble( item_id = c( - "Presurvey_101_other_text", "Postsurvey_101_other_text", + "Presurvey_0719_Student_Background", "Postsurvey_0719_Attitudes", "Embedded_0719_Value", "Ch1_Practice_Quiz", "Ch6_Practice_Quiz_2", "literally", "anything", "else" ) @@ -22,16 +22,16 @@ test_that("response tables missing required columns throw informative errors", { ) }) -test_that("pre- and post- survey items end up in surveys", { - expect_identical(split$survey, mock_responses[1:2, ]) +test_that("survey items end up in surveys", { + expect_identical(split$survey, mock_responses[1:3, ]) }) test_that("practice quiz items end up in quizzes", { - expect_identical(split$quizzes, mock_responses[3:4, ]) + expect_identical(split$quizzes, mock_responses[4:5, ]) }) test_that("all other items end up in in_text", { - expect_identical(split$in_text, mock_responses[5:7, ]) + expect_identical(split$in_text, mock_responses[6:8, ]) }) test_that("all responses are accounted for", {