From de160953af7497393d32c0b58359ad78476fb271 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 15 Feb 2019 10:52:49 -0500 Subject: [PATCH 01/40] toggle state of field level selections --- .../modules/renderSettings/renderSettings.R | 100 ++++++++++-------- 1 file changed, 58 insertions(+), 42 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 3c6aa6d9..7908a4f3 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -5,6 +5,21 @@ source("modules/renderSettings/util/updateSettingStatus.R") renderSettings <- function(input, output, session, data, settings, status){ + # code for field level inputs + # toggleState(id = field_key, condition = ! input[field_column_key]=="") + observe({ + toggleState(id = "measure_values--ALT", condition = !input$measure_col=="") + toggleState(id = "measure_values--AST", condition = !input$measure_col=="") + toggleState(id = "measure_values--TB", condition = !input$measure_col=="") + toggleState(id = "measure_values--ALP", condition = !input$measure_col=="") + }) + observe({ + toggleState(id = "baseline--values", condition = !input$`baseline--value_col`=="") + }) + observe({ + toggleState(id = "analysisFlag--values", condition = !input$`analysisFlag--value_col`=="") + }) + #TODO: Save to separate file - probably needs to be a module. runCustomObserver<-function(name){ @@ -24,23 +39,15 @@ renderSettings <- function(input, output, session, data, settings, status){ updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) } else { choices_ast <- unique(data()[,input$measure_col]) @@ -49,39 +56,47 @@ renderSettings <- function(input, output, session, data, settings, status){ choices_alp <- unique(data()[,input$measure_col]) updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) + options = list(placeholder = "Please select a value", + onInitialize = I('function() { this.setValue(""); }'))) updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) + options = list(placeholder = "Please select a value", + onInitialize = I('function() { this.setValue(""); }'))) updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) + options = list(placeholder = "Please select a value", + onInitialize = I('function() { this.setValue(""); }'))) updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) + options = list(placeholder = "Please select a value", + onInitialize = I('function() { this.setValue(""); }'))) } } else { - updateSelectizeInput(session, "measure_values--ALT", choices = "") - updateSelectizeInput(session, "measure_values--AST", choices = "") - updateSelectizeInput(session, "measure_values--TB", choices = "") - updateSelectizeInput(session, "measure_values--ALP", choices = "") + updateSelectizeInput(session, "measure_values--ALT", choices = "", + options = list(placeholder = "Please select a measure column", + onInitialize = I('function() { + this.setValue(""); + }'))) + updateSelectizeInput(session, "measure_values--AST", choices = "", + options = list(placeholder = "Please select a measure column", + onInitialize = I('function() { + this.setValue(""); + }'))) + updateSelectizeInput(session, "measure_values--TB", choices = "", + options = list(placeholder = "Please select a measure column", + onInitialize = I('function() { + this.setValue(""); + }'))) + updateSelectizeInput(session, "measure_values--ALP", choices = "", + options = list(placeholder = "Please select a measure column", + onInitialize = I('function() { + this.setValue(""); + }'))) } }) @@ -101,8 +116,6 @@ renderSettings <- function(input, output, session, data, settings, status){ updateSelectizeInput(session, "baseline--values", choices = choices, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) } else { choices <- unique(data()[,input$`baseline--value_col`]) @@ -110,14 +123,17 @@ renderSettings <- function(input, output, session, data, settings, status){ updateSelectizeInput(session, "baseline--values", choices = choices, options = list( + placeholder = "Please select a value", onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) this.setValue(""); }'))) } } else { - updateSelectizeInput(session, "baseline--values", choices = "") + updateSelectizeInput(session, "baseline--values", choices = "", + options = list(placeholder = "Please select a baseline column", + onInitialize = I('function() { + this.setValue(""); + }'))) } }) } @@ -134,24 +150,25 @@ renderSettings <- function(input, output, session, data, settings, status){ if (!is.null(settings$analysisFlag$value_col) && input$`analysisFlag--value_col`==settings$analysisFlag$value_col){ choices <- unique(c(settings$analysisFlag$values, as.character(data()[,settings$analysisFlag$value_col]))) - updateSelectizeInput(session, "analysisFlag--values", choices = choices,, + updateSelectizeInput(session, "analysisFlag--values", choices = choices, options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) }'))) } else { choices <- unique(data()[,input$`analysisFlag--value_col`]) updateSelectizeInput(session, "analysisFlag--values", choices = choices, options = list( + placeholder = "Please select a value", onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) this.setValue(""); }'))) } } else { - updateSelectizeInput(session, "analysisFlag--values", choices = "") + updateSelectizeInput(session, "analysisFlag--values", choices = "", + options = list(placeholder = "Please select an analysis flag column", + onInitialize = I('function() { + this.setValue(""); + }'))) } }) @@ -242,7 +259,7 @@ renderSettings <- function(input, output, session, data, settings, status){ # NOTE: to prevent status updating as loop runs and fills in settings(), # require the very last updated input to be available <- can't do this b/c we will have lots of # null settings to start when no standard detected... - status_new <- reactive({ #eventReactive(settingsUI_list$settings,{ + status_new <- reactive({ req(data()) req(settings_new()) name <- rev(isolate(input_names()))[1] @@ -303,12 +320,11 @@ renderSettings <- function(input, output, session, data, settings, status){ # - dependent on: the new settings/status, which will update after every user selection - # observeEvent(data(), { observe({ req(colnames()) for (name in isolate(input_names())){ - #print(name) + setting_key <- as.list(strsplit(name,"\\-\\-")) setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings()) setting_label <- safetyGraphics:::getSettingsMetadata(charts="eDiSH", text_keys=name, cols="label") From 4bbfc4b8b17d10304c81d84491e32d8901824f42 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 14:56:02 -0500 Subject: [PATCH 02/40] rearrange rows, add setting_cat column --- data-raw/settingsMetadata.csv | 52 +++++++++++++++++----------------- data/settingsMetadata.rda | Bin 1952 -> 1983 bytes 2 files changed, 26 insertions(+), 26 deletions(-) diff --git a/data-raw/settingsMetadata.csv b/data-raw/settingsMetadata.csv index ce95c2f3..3854500d 100644 --- a/data-raw/settingsMetadata.csv +++ b/data-raw/settingsMetadata.csv @@ -1,26 +1,26 @@ -chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,adam,sdtm -TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,USUBJID,USUBJID -TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,AVAL,STRESN -TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,PARAM,TEST -TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1LO,STNRLO -TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1HI,STNRHI -TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,ADY,DY -TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,VISIT,VISIT -TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,VISITNUM,VISITNUM -TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE,,, -TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE,,, -TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)" -TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)" -TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Bilirubin (umol/L),Total Bilirubin -TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP) -TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE,,, -TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col,, -TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE,,, -TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col,, -TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,, -TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,, -TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE,,, -TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE,,, -TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE,,, -TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,, -TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",Character,FALSE,FALSE,NA,FALSE,,, \ No newline at end of file +chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,adam,sdtm,setting_cat +TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,USUBJID,USUBJID,data +TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,AVAL,STRESN,data +TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,PARAM,TEST,data +TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)",data +TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)",data +TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Bilirubin (umol/L),Total Bilirubin,data +TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP),data +TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1LO,STNRLO,data +TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1HI,STNRHI,data +TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,ADY,DY,data +TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,VISIT,VISIT,data +TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,VISITNUM,VISITNUM,data +TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE,,,,data +TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE,,,,data +TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE,,,,data +TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col,,,data +TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE,,,,data +TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col,,,data +TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,,measure +TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,,,measure +TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE,,,,appearance +TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE,,,,appearance +TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE,,,,appearance +TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,,,appearance +TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",character,FALSE,FALSE,NA,FALSE,,,,appearance diff --git a/data/settingsMetadata.rda b/data/settingsMetadata.rda index c70c9c65635c9e1653236e721fe5a9073d45f8ee..808037267608c3d6dd7d83ccec923c748afa3bd9 100644 GIT binary patch delta 1974 zcmV;n2TAy#55Et8LRx4!F+o`-Q(2@60aXA7vVZUY|Nr;s=dc^U_ut^Z|Nr2?5P(1c z2mk^Y004jh0pJLK8hv+eARCt3000000BEC40z=fCJ4Y20GOD8B0xmMm_)!N(da4aX|YX&L8b|#YBXdtXw%X(0R2-1_L4bRlVF&^ zYa$X?X<4LQf}28!oac<8z6PeoZ9vBL1CzW(*aVw3@1$DU&nrdsWhq5<;ejh%-HnWk zj-#SnyqRjf1+jm;w^M+ZGI3t@SWef2-Wg0~@5nPpD+kfU zu2#j6kz^9lSiHyjEu9q_D3stte8)=~ zi4^)pz=D4RlNCJa3s?g|0wBT0tnK+B4y4BKskRKiC;;){HC>6aaz^2cH51Z*;KTn zIfVvLgJ7V6dc0=o;8+bswi^i3ftO*ooWxWy6*kP~yjxxGN=Zvl#BAAJGAmkz(ve)8 z%0q2eNfNUb?T}n3Wi? z9Xx-Fg~6GP%58%pX_N>w5Q?B$u^^TXQo=+JM+&Q{@ZlS)G>PpK=2(dVVz|FpXiC0d zj_HLog$Sls40$T6=8Sk2Lpo_aMGP1!HRm-v?cC@L5<~)!SDeGtU28e$kSRq6@Ech@TnX)y6Ks*9LQ%DxreD(N8 zK)0+O;d9iqJ&wN4&d<~QH5-i6X5Vkk?a-)l_k}eloK#686&S(+7)&sy3UIU|l1F6M zWi~0HR28Zfi127~Aae24P%1*P)-)2_Qc|{6r~^$61nEcvSJu%!v9=Jx;UH2%0>3uEa?tJ&FI=JKa!FWe?1K zwK$Nxm;hBEej3SUF#NXEg!u1C8JvG12@o_5hLS9Iy?)*P>lLum8J-EK(|B;4`#3YB zq&C|teyC0xY&&6U%LGKGdc!QFKrmGtK-yxi zcK*ytQbPaQ>pelj&1KFIo1I7~a(4r`jmV*7wJpJgCRR%XY2Kk(&U_^1T&aH&#|Z~m z71l{Jatxh;h6Uzq9_$Juhvd}R?1ym4fc``s0dORPujYhuE^z!V$Y~os$U5XUfwVOu z65L&9=dsr7r!x;+9_SaL^#p-05!)bXZpJ}{ex-lV23XISU!a{!()N?GFL>#R~ zvchB%O74nAwyc#44O~Zul0wH6i!`e!gTn|#2E$iPvc=u*u-*l9Vr_IX4DM=Wq|WB5*9ZXJ8cjnz=9cn24e|z2e70B21xF8@Jxbn z;U+@uoJ`&i%5cdC-UxpnHbF@oB+l1B&Qf@ZIDrif3}Z}aZ4!b2>*ujTXAE(HAScKh z^A$%-U=2~e>h#u1=_{PKNFNK#k9}$~c2#A$F$t1n zWov9Mvah=^StQbt9Bi?>kInfWKx8Tg)~;O>1+>e&s)L9qO)-BO6Ebl$2aLqPi*DTD zZei1}l4zNEmz{>FJI*jq8yTsEL8W680OVm|tj~tf31VtdUPMs`GEIq$xkD1c(Bz2- z&tR6yLJt3;2Pu!`P?PX?+1`_Z(zZLLcfoH2{6A$ zxnL*Ua5NY=8s9Do6{Hv?$+VR`6e3&Vq^%HfjJjU%AK`)f#+PGA^&pTECI7|TkxmpO IDFT31KfuJ$~0MkGNKr#RT0fdPH0RaFAn?%W` zrpi4UYG`_xntGY2(-6?pXn-1ROV{_3T&zIaV-miykPV6&3)(@cro#GD2KZjDEJuT=t47=7<&BQjOB?PaC086fWG#mu786`p z@m)#?**$sV_n294z~qS~T{Y!PXJKA_b=FX!#jlb=iM}#O^&<8t-zgmN1ks+p9hvK@ z!dwyqhMdw2IB}NUMQNQCxAE|Xfy%-3aVw4%lVCR3j(`T2r1dd$PJ#p&q|zmS(!=GH zz%UB!8`h4n!Zwp#;PGm_nh1dqCYb^TU=c$o^Js9Yg=q`l5h3-u^1v2n4W(3wL()7} zlCj@ML~KL&#;C$s*#nj<61rbja-}@FzE6(~t*6g@*~Kj<^ip)jkb4rJJ0|qytqdQ; ztlgXxcLN;#WCA^4Z3(d^z!PbI2{9l`%iw|rgWqJB2`Qn8q@OcFIoNy8^DqO2q>>v$ zX#m&(dlCVECNI$bHXtSgNJ+E+Zsyo8Lp=fVZib5T4RLYHtW*{-`Il?$_Akw8Jc(XE ztji?uic{$e>pD_Qf2_R5vds0)p`YhVj`f+>&7rno8E!L_q77ZzOWJFH`)eSLE953z zYor5_xRu&X=lG3EuHjnMwRYQ$m|0Y`qdA2JP=jEgfqkAcbnh$%CAJ#~(_1cKx17LK zFcmh;=DIDa>#0d8Vlf*wS4@i5p>k3ylbJ|us_7zDV%@R~hNn*lf_P(a_Qx)F+Iq>) zBKcI|*RRKAV7Bs?CeEOL#PBm`hpJ*!V!U+lt_KEY7ZlqC`4mj3L7?Bv8}5Njrn!)5 zhZh3rt)YbD$l`_5;_51r%pj&GAbeRmQlNQR<07rMXnVnHmT7}A#F3uE&{2a0+1oYz zQ~j^b9wrHcTrZf!z4Z)oZp73Sd%tVx38iTpWWGX4iNz*`M}0$o@r!IAAOb^c&l2~5 zd_e*T{YA&8?6FTy?LFg!F9;W+0Jg*DufjS7yCLN+Jc`U<;aIU^kAp-)0y7Zk&(Ux& z96N()Sf^J|m@m?Bm^}k9Fd26=Mk&^<6>0JrS7{c79!Fsu{&O7^D6AJKq~#|Jk&9BN zZ=3c9T^<6s&_CpVdj=?pAy39$kDw0qX=Fj^YvD6Vg+AbCs6F<3fGCH7>nL)Cc3?I(+V~HZ6Tz6IwikuL97Oyff;DY8f><8e*ucz)`cEZJ z+3vz7j}~jxi6p17Hg?$|l04_#LwXmB{{U4We#K<67=D|7Vubjvq>j=U6}T^?%E?|W zJCrLq&w!kN%ZiaKFOYSCT||>NAj#MmUR^U__g+vqJovVIA=xruKR6uWa1ue+^1?Y6 zIDSWDG>xBZ9jOhVZ4F3)ZZ28*EOol+%)_=1bO*Y|`hq~0v~~y@Td*^Y=y zeY=?kC4=2H!33AD-A9mIqLFZlBS2!7#og37!NFkZGdAyMTLKdrLm+H|4-dpp=0!Zp zM^7=v7#e5_VH4?ccam#X23_~NQ;A_i`>cY??bK>P3L9vjy zrwXAmkU&X7Y#Ez6MipgiYwlTB%`jOc(vci&vAf*-?+`H*!(&z~iGtW;>#CsO3KL9! zMr6#KO(o(mFCyD^xEq*s>f@RwT{7v|YJ<9Qc<`~Bm{b~8Fjt2g3k_y`Hh@b56&2$O zAmvH1F_#oDEFA7gk_`a87zb91pwkbem;V=XML1B9{MQ)nWOID4 From 1aa07a388d25807d8735d6789cc078db7e2cdb08 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 16:22:18 -0500 Subject: [PATCH 03/40] create functions for making the UI --- .../renderSettings/util/createSettingsUI.R | 112 ++++++++++++++++++ 1 file changed, 112 insertions(+) create mode 100644 inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R new file mode 100644 index 00000000..83b87f15 --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R @@ -0,0 +1,112 @@ +createLabel <- function(key){ + sm <- getSettingsMetadata(text_keys=key) + setting_label <- sm$label + required <- sm$setting_required + + if (required){ + paste0(" ", setting_label, "*") + } else { + paste0(" ", setting_label) + } +} + +createDescription <- function(key){ + getSettingsMetadata(text_keys=key, cols="description") +} + +createControl <- function(key, metadata, data, settings, ns){ + sm_key <- filter(metadata, text_key==key) + + tt_msg <- paste0("tt_msg_", key) + msg <- paste0("msg_", key) + + setting_key <- as.list(strsplit(key,"\\-\\-")) + setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) + setting_label <- createLabel(key) + setting_description <- createDescription(key) + + field_column <- NULL + field_column_label <- NULL + if (!is.null(sm_key$field_column_key)){ + field_column <- safetyGraphics:::getSettingValue(key=list(sm_key$field_column_key), settings=settings) + field_column_label <- getSettingsMetadata(text_key = sm_key$field_column_key, cols = "label") + } + + + # get the choices for the option + value <- NULL + choices <- NULL + placeholder <- NULL + if(sm_key$column_mapping==TRUE){ + if(is.null(setting_value)){ + choices <- colnames(data) + placeholder <- list( + onInitialize = I('function() { + this.setValue("");}')) + } else{ + choices <- unique(c(setting_value, colnames(data))) + placeholder <- list (onInitialize = I('function() { }')) + } + } else if (sm_key$field_mapping==TRUE){ + if(is.null(field_column)){ ## if there is NOT a column specified in settings + placeholder <- list( + placeholder = paste0("Please select a ", field_column_label), + onInitialize = I('function() { + this.setValue("");}')) + } else{ ## if there is a column specified in settings + choices <- unique(c(setting_value, as.character(data[,field_column]))) %>% unlist + placeholder <- list (onInitialize = I('function() { }')) + } + } else if (sm_key$setting_type=="vector"){ + choices <- setting_value ### this is meant to cover the scenario for x_options/y_options. But we have + # nowhere to grab "choices" from. Here we are just saying that choices=selected=setting_value + } + + if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ + + multiple <- (sm_key$setting_type=="vector") + + div( + span(title = setting_description, tags$label(HTML(setting_label))), + span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), + selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) + ) + } else if (sm_key$setting_type=="vector"){ + + div( + span(title = setting_description, tags$label(HTML(setting_label))), + span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), + selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) + ) + + } else if (sm_key$setting_type=="numeric"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) + ) + } else if (sm_key$setting_type=="logical"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + checkboxInput(inputId = ns(key), label = NULL, value=setting_value) + ) + } else if (sm_key$setting_type=="character"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + textAreaInput(inputId = ns(key), label = NULL, value = setting_value) + ) + } +} + +createSettingsUI <- function(data, settings, setting_cat_val, charts, ns){ + + sm <- getSettingsMetadata(charts=charts) %>% + filter(setting_cat==setting_cat_val) + + lapply(sm$text_key, function(key){ + createControl(key, metadata = sm, data, settings, ns) + }) +} + + + + From 3b7c1fabc05056f149890ecb5ad5ca0a65a09ca6 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 16:22:34 -0500 Subject: [PATCH 04/40] switch to automated UI! --- .../modules/renderSettings/renderSettingsUI.R | 343 +++++++++--------- 1 file changed, 173 insertions(+), 170 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 0738d245..4101f68e 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -18,137 +18,138 @@ renderSettingsUI <- function(id){ fluidRow( column(4, wellPanel( - div( - span(id = ns("tt_lbl_id_col"), title = "", - tags$label(id = ns("lbl_id_col"), "")), - span(id = ns("tt_msg_id_col"), title = "", - tags$label(id = ns("msg_id_col"), "")), - selectizeInput(ns("id_col"),NULL, choices = NULL) - - ), - - div( - span(id = ns("tt_lbl_value_col"), title = "", - tags$label(id = ns("lbl_value_col"), "")), - span(id = ns("tt_msg_value_col"), title = "", - tags$label(id = ns("msg_value_col"), "")), - selectizeInput(ns("value_col"),NULL, choices = NULL) - - ), - - div( - span(id = ns("tt_lbl_measure_col"), title = "", - tags$label(id = ns("lbl_measure_col"), "")), - span(id = ns("tt_msg_measure_col"), title = "", - tags$label(id = ns("msg_measure_col"), "")), - selectizeInput(ns("measure_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--ALT"), title = "", - tags$label(id = ns("lbl_measure_values--ALT"), "")), - span(id = ns("tt_msg_measure_values--ALT"), title = "", - tags$label(id = ns("msg_measure_values--ALT"), "")), - selectizeInput(ns("measure_values--ALT"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--AST"), title = "", - tags$label(id = ns("lbl_measure_values--AST"), "")), - span(id = ns("tt_msg_measure_values--AST"), title = "", - tags$label(id = ns("msg_measure_values--AST"), "")), - selectizeInput(ns("measure_values--AST"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--TB"), title = "", - tags$label(id = ns("lbl_measure_values--TB"), "")), - span(id = ns("tt_msg_measure_values--TB"), title = "", - tags$label(id = ns("msg_measure_values--TB"), "")), - selectizeInput(ns("measure_values--TB"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_measure_values--ALP"), title = "", - tags$label(id = ns("lbl_measure_values--ALP"), "")), - span(id = ns("tt_msg_measure_values--ALP"), title = "", - tags$label(id = ns("msg_measure_values--ALP"), "")), - selectizeInput(ns("measure_values--ALP"),NULL, choices = NULL) - ), - # ), - div( - span(id = ns("tt_lbl_normal_col_low"), title = "", - tags$label(id = ns("lbl_normal_col_low"), "")), - span(id = ns("tt_msg_normal_col_low"), title = "", - tags$label(id = ns("msg_normal_col_low"), "")), - selectizeInput(ns("normal_col_low"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_normal_col_high"), title = "", - tags$label(id = ns("lbl_normal_col_high"), "")), - span(id = ns("tt_msg_normal_col_high"), title = "", - tags$label(id = ns("msg_normal_col_high"), "")), - selectizeInput(ns("normal_col_high"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_visit_col"), title = "", - tags$label(id = ns("lbl_visit_col"), "")), - span(id = ns("tt_msg_visit_col"), title = "", - tags$label(id = ns("msg_visit_col"), "")), - selectizeInput(ns("visit_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_visitn_col"), title = "", - tags$label(id = ns("lbl_visitn_col"), "")), - span(id = ns("tt_msg_visitn_col"), title = "", - tags$label(id = ns("msg_visitn_col"), "")), - selectizeInput(ns("visitn_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_studyday_col"), title = "", - tags$label(id = ns("lbl_studyday_col"), "")), - span(id = ns("tt_msg_studyday_col"), title = "", - tags$label(id = ns("msg_studyday_col"), "")), - selectizeInput(ns("studyday_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_baseline--value_col"), title = "", - tags$label(id = ns("lbl_baseline--value_col"), "")), - span(id = ns("tt_msg_baseline--value_col"), title = "", - tags$label(id = ns("msg_baseline--value_col"), "")), - selectizeInput(ns("baseline--value_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_baseline--values"), title = "", - tags$label(id = ns("lbl_baseline--values"), "")), - span(id = ns("tt_msg_baseline--values"), title = "", - tags$label(id = ns("msg_baseline--values"), "")), - selectizeInput(ns("baseline--values"),NULL, choices = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_filters"), title = "", - tags$label(id = ns("lbl_filters"), "")), - span(id = ns("tt_msg_filters"), title = "", - tags$label(id = ns("msg_filters"), "")), - selectInput(ns("filters"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_group_cols"), title = "", - tags$label(id = ns("lbl_group_cols"), "")), - span(id = ns("tt_msg_group_cols"), title = "", - tags$label(id = ns("msg_group_cols"), "")), - selectInput(ns("group_cols"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - ), - div( - span(id = ns("tt_lbl_analysisFlag--value_col"), title = "", - tags$label(id = ns("lbl_analysisFlag--value_col"), "")), - span(id = ns("tt_msg_analysisFlag--value_col"), title = "", - tags$label(id = ns("msg_analysisFlag--value_col"), "")), - selectizeInput(ns("analysisFlag--value_col"),NULL, choices = NULL) - ), - div( - span(id = ns("tt_lbl_analysisFlag--values"), title = "", - tags$label(id = ns("lbl_analysisFlag--values"), "")), - span(id = ns("tt_msg_analysisFlag--values"), title = "", - tags$label(id = ns("msg_analysisFlag--values"), "")), - selectizeInput(ns("analysisFlag--values"),NULL, choices = NULL, multiple = TRUE) - ) + uiOutput(ns("data_mapping_ui")) + # div( + # span(id = ns("tt_lbl_id_col"), title = "", + # tags$label(id = ns("lbl_id_col"), "")), + # span(id = ns("tt_msg_id_col"), title = "", + # tags$label(id = ns("msg_id_col"), "")), + # selectizeInput(ns("id_col"),NULL, choices = NULL) + # + # ), + # + # div( + # span(id = ns("tt_lbl_value_col"), title = "", + # tags$label(id = ns("lbl_value_col"), "")), + # span(id = ns("tt_msg_value_col"), title = "", + # tags$label(id = ns("msg_value_col"), "")), + # selectizeInput(ns("value_col"),NULL, choices = NULL) + # + # ), + # + # div( + # span(id = ns("tt_lbl_measure_col"), title = "", + # tags$label(id = ns("lbl_measure_col"), "")), + # span(id = ns("tt_msg_measure_col"), title = "", + # tags$label(id = ns("msg_measure_col"), "")), + # selectizeInput(ns("measure_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_measure_values--ALT"), title = "", + # tags$label(id = ns("lbl_measure_values--ALT"), "")), + # span(id = ns("tt_msg_measure_values--ALT"), title = "", + # tags$label(id = ns("msg_measure_values--ALT"), "")), + # selectizeInput(ns("measure_values--ALT"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_measure_values--AST"), title = "", + # tags$label(id = ns("lbl_measure_values--AST"), "")), + # span(id = ns("tt_msg_measure_values--AST"), title = "", + # tags$label(id = ns("msg_measure_values--AST"), "")), + # selectizeInput(ns("measure_values--AST"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_measure_values--TB"), title = "", + # tags$label(id = ns("lbl_measure_values--TB"), "")), + # span(id = ns("tt_msg_measure_values--TB"), title = "", + # tags$label(id = ns("msg_measure_values--TB"), "")), + # selectizeInput(ns("measure_values--TB"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_measure_values--ALP"), title = "", + # tags$label(id = ns("lbl_measure_values--ALP"), "")), + # span(id = ns("tt_msg_measure_values--ALP"), title = "", + # tags$label(id = ns("msg_measure_values--ALP"), "")), + # selectizeInput(ns("measure_values--ALP"),NULL, choices = NULL) + # ), + # # ), + # div( + # span(id = ns("tt_lbl_normal_col_low"), title = "", + # tags$label(id = ns("lbl_normal_col_low"), "")), + # span(id = ns("tt_msg_normal_col_low"), title = "", + # tags$label(id = ns("msg_normal_col_low"), "")), + # selectizeInput(ns("normal_col_low"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_normal_col_high"), title = "", + # tags$label(id = ns("lbl_normal_col_high"), "")), + # span(id = ns("tt_msg_normal_col_high"), title = "", + # tags$label(id = ns("msg_normal_col_high"), "")), + # selectizeInput(ns("normal_col_high"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_visit_col"), title = "", + # tags$label(id = ns("lbl_visit_col"), "")), + # span(id = ns("tt_msg_visit_col"), title = "", + # tags$label(id = ns("msg_visit_col"), "")), + # selectizeInput(ns("visit_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_visitn_col"), title = "", + # tags$label(id = ns("lbl_visitn_col"), "")), + # span(id = ns("tt_msg_visitn_col"), title = "", + # tags$label(id = ns("msg_visitn_col"), "")), + # selectizeInput(ns("visitn_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_studyday_col"), title = "", + # tags$label(id = ns("lbl_studyday_col"), "")), + # span(id = ns("tt_msg_studyday_col"), title = "", + # tags$label(id = ns("msg_studyday_col"), "")), + # selectizeInput(ns("studyday_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_baseline--value_col"), title = "", + # tags$label(id = ns("lbl_baseline--value_col"), "")), + # span(id = ns("tt_msg_baseline--value_col"), title = "", + # tags$label(id = ns("msg_baseline--value_col"), "")), + # selectizeInput(ns("baseline--value_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_baseline--values"), title = "", + # tags$label(id = ns("lbl_baseline--values"), "")), + # span(id = ns("tt_msg_baseline--values"), title = "", + # tags$label(id = ns("msg_baseline--values"), "")), + # selectizeInput(ns("baseline--values"),NULL, choices = NULL, multiple = TRUE) + # ), + # div( + # span(id = ns("tt_lbl_filters"), title = "", + # tags$label(id = ns("lbl_filters"), "")), + # span(id = ns("tt_msg_filters"), title = "", + # tags$label(id = ns("msg_filters"), "")), + # selectInput(ns("filters"),NULL, choices = NULL, selected = NULL, multiple = TRUE) + # ), + # div( + # span(id = ns("tt_lbl_group_cols"), title = "", + # tags$label(id = ns("lbl_group_cols"), "")), + # span(id = ns("tt_msg_group_cols"), title = "", + # tags$label(id = ns("msg_group_cols"), "")), + # selectInput(ns("group_cols"),NULL, choices = NULL, selected = NULL, multiple = TRUE) + # ), + # div( + # span(id = ns("tt_lbl_analysisFlag--value_col"), title = "", + # tags$label(id = ns("lbl_analysisFlag--value_col"), "")), + # span(id = ns("tt_msg_analysisFlag--value_col"), title = "", + # tags$label(id = ns("msg_analysisFlag--value_col"), "")), + # selectizeInput(ns("analysisFlag--value_col"),NULL, choices = NULL) + # ), + # div( + # span(id = ns("tt_lbl_analysisFlag--values"), title = "", + # tags$label(id = ns("lbl_analysisFlag--values"), "")), + # span(id = ns("tt_msg_analysisFlag--values"), title = "", + # tags$label(id = ns("msg_analysisFlag--values"), "")), + # selectizeInput(ns("analysisFlag--values"),NULL, choices = NULL, multiple = TRUE) + # ) )) ) @@ -166,16 +167,17 @@ renderSettingsUI <- function(id){ fluidRow( column(4, wellPanel( - div( - div(id = ns("tt_lbl_x_options"), title = "", - tags$label(id = ns("lbl_x_options"), "")), - selectizeInput(ns("x_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("ALT", "AST", "ALP"), multiple=TRUE) - ), - div( - div(id = ns("tt_lbl_y_options"), title = "", - tags$label(id = ns("lbl_y_options"), "")), - selectizeInput(ns("y_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("TB"), multiple = TRUE) - ) + uiOutput(ns("measure_settings_ui")) + # div( + # div(id = ns("tt_lbl_x_options"), title = "", + # tags$label(id = ns("lbl_x_options"), "")), + # selectizeInput(ns("x_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("ALT", "AST", "ALP"), multiple=TRUE) + # ), + # div( + # div(id = ns("tt_lbl_y_options"), title = "", + # tags$label(id = ns("lbl_y_options"), "")), + # selectizeInput(ns("y_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("TB"), multiple = TRUE) + # ) ) ) @@ -193,35 +195,36 @@ renderSettingsUI <- function(id){ fluidRow( column(4, wellPanel( - div( - div(id = ns("tt_lbl_visit_window"), title = "", - tags$label(id = ns("lbl_visit_window"), "")), - sliderInput(ns("visit_window"),NULL, value = 30, min=0, max=50) - ), - div( - div(id = ns("tt_lbl_r_ratio_filter"), title = "", - tags$label(id = ns("lbl_r_ratio_filter"), "")), - checkboxInput(ns("r_ratio_filter"),NULL, value = TRUE) - ), - conditionalPanel( - condition="input.r_ratio_filter==true", ns=ns, - div( - div(id = ns("tt_lbl_r_ratio_cut"), title = "", - tags$label(id = ns("lbl_r_ratio_cut"), "")), - sliderInput(ns("r_ratio_cut"),NULL, value = 0, min=0, max =1) - ) - ), - div( - div(id = ns("tt_lbl_showTitle"), title = "", - tags$label(id = ns("lbl_showTitle"), "")), - checkboxInput(ns("showTitle"),NULL, value = TRUE) - ), - div( - div(id = ns("tt_lbl_warningText"), title = "", - tags$label(id = ns("lbl_warningText"), "")), - textAreaInput (ns("warningText"),NULL, rows =4, - value = "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures.") - ) + uiOutput(ns("appearance_settings_ui")) + # div( + # div(id = ns("tt_lbl_visit_window"), title = "", + # tags$label(id = ns("lbl_visit_window"), "")), + # sliderInput(ns("visit_window"),NULL, value = 30, min=0, max=50) + # ), + # div( + # div(id = ns("tt_lbl_r_ratio_filter"), title = "", + # tags$label(id = ns("lbl_r_ratio_filter"), "")), + # checkboxInput(ns("r_ratio_filter"),NULL, value = TRUE) + # ), + # conditionalPanel( + # condition="input.r_ratio_filter==true", ns=ns, + # div( + # div(id = ns("tt_lbl_r_ratio_cut"), title = "", + # tags$label(id = ns("lbl_r_ratio_cut"), "")), + # sliderInput(ns("r_ratio_cut"),NULL, value = 0, min=0, max =1) + # ) + # ), + # div( + # div(id = ns("tt_lbl_showTitle"), title = "", + # tags$label(id = ns("lbl_showTitle"), "")), + # checkboxInput(ns("showTitle"),NULL, value = TRUE) + # ), + # div( + # div(id = ns("tt_lbl_warningText"), title = "", + # tags$label(id = ns("lbl_warningText"), "")), + # textAreaInput (ns("warningText"),NULL, rows =4, + # value = "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures.") + # ) ) ) ) From 2f281f9983d298d364b629cd7301f374ec9ee686 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 16:23:01 -0500 Subject: [PATCH 05/40] switch to automated UI generation/population --- .../modules/renderSettings/renderSettings.R | 386 ++++++------------ 1 file changed, 118 insertions(+), 268 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 7908a4f3..391d9cae 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -1,12 +1,45 @@ -source("modules/renderSettings/util/labelSetting.R") -source("modules/renderSettings/util/flagSetting.R") +source("modules/renderSettings/util/createSettingsUI.R") +# source("modules/renderSettings/util/labelSetting.R") +# source("modules/renderSettings/util/flagSetting.R") source("modules/renderSettings/util/updateSettingStatus.R") renderSettings <- function(input, output, session, data, settings, status){ + + ns <- session$ns + + #List of all inputs + input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts="eDiSH", cols="text_key")}) + + ###################################################################### + # create settings UI + # - chart selection -> gather all necessary UI elements + # - create elements based on metadata file + # - populate using data/settings + ###################################################################### + + output$data_mapping_ui <- renderUI({ + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts="edish", ns=ns)) + }) + outputOptions(output, "data_mapping_ui", suspendWhenHidden = FALSE) + + output$measure_settings_ui <- renderUI({ + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "measure", charts="edish", ns=ns)) + }) + outputOptions(output, "measure_settings_ui", suspendWhenHidden = FALSE) + + output$appearance_settings_ui <- renderUI({ + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "appearance", charts="edish", ns=ns)) + }) + outputOptions(output, "appearance_settings_ui", suspendWhenHidden = FALSE) + + + ###################################################################### + # Update field level settings if a column level setting is changed + # + # TO-do: make a function! + ###################################################################### - # code for field level inputs - # toggleState(id = field_key, condition = ! input[field_column_key]=="") observe({ toggleState(id = "measure_values--ALT", condition = !input$measure_col=="") toggleState(id = "measure_values--AST", condition = !input$measure_col=="") @@ -14,181 +47,70 @@ renderSettings <- function(input, output, session, data, settings, status){ toggleState(id = "measure_values--ALP", condition = !input$measure_col=="") }) observe({ - toggleState(id = "baseline--values", condition = !input$`baseline--value_col`=="") - }) - observe({ - toggleState(id = "analysisFlag--values", condition = !input$`analysisFlag--value_col`=="") - }) - - #TODO: Save to separate file - probably needs to be a module. - runCustomObserver<-function(name){ - - # Custom observer for measure_col - if(name=="measure_col"){ - observe({ - settings <- settings() - - req(input$measure_col) - - if (input$measure_col %in% colnames()){ - if (!is.null(settings$measure_col) && input$measure_col==settings$measure_col){ - choices_ast <- unique(c(settings$measure_values$AST, as.character(data()[,settings$measure_col]))) - choices_alt <- unique(c(settings$measure_values$ALT, as.character(data()[,settings$measure_col]))) - choices_tb <- unique(c(settings$measure_values$TB, as.character(data()[,settings$measure_col]))) - choices_alp <- unique(c(settings$measure_values$ALP, as.character(data()[,settings$measure_col]))) - - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list (onInitialize = I('function() { - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list (onInitialize = I('function() { - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list (onInitialize = I('function() { - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list (onInitialize = I('function() { - }'))) - } else { - choices_ast <- unique(data()[,input$measure_col]) - choices_alt <- unique(data()[,input$measure_col]) - choices_tb <- unique(data()[,input$measure_col]) - choices_alp <- unique(data()[,input$measure_col]) - - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); + req(input$measure_col) + if (! input$measure_col == isolate(settings()$measure_col)){ + choices_ast <- unique(data()[,input$measure_col]) + choices_alt <- unique(data()[,input$measure_col]) + choices_tb <- unique(data()[,input$measure_col]) + choices_alp <- unique(data()[,input$measure_col]) + + updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) + updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) + updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); }'))) - } - } else { - updateSelectizeInput(session, "measure_values--ALT", choices = "", - options = list(placeholder = "Please select a measure column", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = "", - options = list(placeholder = "Please select a measure column", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = "", - options = list(placeholder = "Please select a measure column", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = "", - options = list(placeholder = "Please select a measure column", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - - }) - } - - # Custom observer for baseline - if(name=="baseline--value_col"){ - observe({ - settings <- settings() - - req(input$`baseline--value_col`) - - if (input$`baseline--value_col` %in% colnames()){ - if (!is.null(settings$baseline$value_col) && input$`baseline--value_col`==settings$baseline$value_col){ - choices <- unique(c(settings$baseline$values, as.character(data()[,settings$baseline$value_col]))) - choices <- sort(choices) - - updateSelectizeInput(session, "baseline--values", choices = choices, - options = list (onInitialize = I('function() { - }'))) - } else { - choices <- unique(data()[,input$`baseline--value_col`]) - choices <- sort(choices) - - updateSelectizeInput(session, "baseline--values", choices = choices, - options = list( - placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - } else { - updateSelectizeInput(session, "baseline--values", choices = "", - options = list(placeholder = "Please select a baseline column", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - }) - } - - - # Custom observer for analysis population - if(name=="analysisFlag--value_col"){ - observe({ - settings <- settings() - - req(input$`analysisFlag--value_col`) - - if (input$`analysisFlag--value_col` %in% colnames()){ - if (!is.null(settings$analysisFlag$value_col) && input$`analysisFlag--value_col`==settings$analysisFlag$value_col){ - choices <- unique(c(settings$analysisFlag$values, as.character(data()[,settings$analysisFlag$value_col]))) - - updateSelectizeInput(session, "analysisFlag--values", choices = choices, - options = list (onInitialize = I('function() { - }'))) - } else { - choices <- unique(data()[,input$`analysisFlag--value_col`]) - - updateSelectizeInput(session, "analysisFlag--values", choices = choices, - options = list( - placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - } else { - updateSelectizeInput(session, "analysisFlag--values", choices = "", - options = list(placeholder = "Please select an analysis flag column", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - - }) + updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) } - } #end runCustomObserver() + }) - ########################### - # Make updates to the UI - ########################### - ns <- session$ns + observe({ + toggleState(id = "baseline--values", condition = !input$`baseline--value_col`=="") + }) + observe({ + req(input$`baseline--value_col`) + if (! input$`baseline--value_col` == isolate(settings()$`baseline--value_col`)){ + choices <- data()[,input$`baseline--value_col`] %>% unique %>% sort + + updateSelectizeInput(session, "baseline--values", choices = choices, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); }'))) + } + }) - #Columns in the data - colnames <- reactive({names(data())}) + observe({ + toggleState(id = "analysisFlag--values", condition = !input$`analysisFlag--value_col`=="") + }) + observe({ + req(input$`analysisFlag--value_col`) + if (! input$`analysisFlag--value_col` == isolate(settings()$`analysisFlag--value_col`)){ + choices <- data()[,input$`analysisFlag--value_col`] %>% unique %>% sort + + updateSelectizeInput(session, "analysisFlag--values", choices = choices, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); }'))) + } + }) + - #List of all inputs - #input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts="eDiSH", cols="text_key")}) - input_names <- reactive({names(lapply(reactiveValuesToList(input), unclass))}) - #observe({print(input_names())}) + ###################################################################### # Fill settings object based on selections # require that secondary inputs have been filled in before proceeding # update is triggered by any of the input selections changing @@ -197,10 +119,10 @@ renderSettings <- function(input, output, session, data, settings, status){ # Therefore, until the inputs are done updating based on new data, this object will be # partially representing the old data, and partially representing the new data. # not sure if this is the right place to do it...but can we clear out this object upon a data change and start over?? + ###################################################################### settings_new <- reactive({ - # print(input$id_col) settings <- list(id_col = input$id_col, value_col = input$value_col, @@ -253,12 +175,15 @@ renderSettings <- function(input, output, session, data, settings, status){ }) + ###################################################################### # validate new settings # the validation is run every time there is a change in data and/or settings. # # NOTE: to prevent status updating as loop runs and fills in settings(), # require the very last updated input to be available <- can't do this b/c we will have lots of # null settings to start when no standard detected... + ###################################################################### + status_new <- reactive({ req(data()) req(settings_new()) @@ -278,7 +203,9 @@ renderSettings <- function(input, output, session, data, settings, status){ }) - #Setting Status information (from failed checks only) + ###################################################################### + # Setting validation status information + ###################################################################### status_df <- reactive({ req(status_new()) @@ -295,103 +222,26 @@ renderSettings <- function(input, output, session, data, settings, status){ unique }) - + # for shiny tests exportTestValues(status_df = { status_df() }) - #List of required settings - req_settings <- safetyGraphics:::getSettingsMetadata() %>% - filter(chart_edish==TRUE & setting_required==TRUE) %>% - pull(text_key) - - #List of inputs with custom observers - custom_observer_settings <- c("measure_col", "baseline--value_col","analysisFlag--value_col") - - - #Establish observers to update settings UI for all inputs - # Different observers: - # (1a) update UI based on data selection & original settings object - # - dependent on: colnames() - # - populate all UI inputs - # - flag required settings - # (1b) Do 1a for the custom settings (e.g. measure_values options). These contained nested observers - # - dependent on: parent input$xxx - # (2) append status messages to UI - # - after UI is filled, we generate a NEW settings object & status - # - dependent on: the new settings/status, which will update after every user selection - - - observe({ - req(colnames()) - - for (name in isolate(input_names())){ + ###################################################################### + # print validation messages + ###################################################################### + observe({ + for (name in isolate(input_names())){ - setting_key <- as.list(strsplit(name,"\\-\\-")) - setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings()) - setting_label <- safetyGraphics:::getSettingsMetadata(charts="eDiSH", text_keys=name, cols="label") - setting_description <- safetyGraphics:::getSettingsMetadata(charts="eDiSH", text_keys=name, cols="description") - - - column_mapping_ids <- safetyGraphics:::getSettingsMetadata(charts="eDiSH") %>% filter(column_mapping==TRUE) %>% pull(text_key) - - - if (name %in% column_mapping_ids){ - sortedChoices<-NULL - if(is.null(setting_value)){ - sortedChoices<-colnames() - updateSelectizeInput(session, name, choices=sortedChoices, - options = list( - onInitialize = I('function() { - //console.log("initializing input w/o value") - //console.log(this) - this.setValue(""); - }') - )) - - - }else{ - sortedChoices<-unique(c(setting_value, colnames())) - updateSelectizeInput(session, name, choices=sortedChoices, - options = list (onInitialize = I('function() { - //console.log("initializing input with value") - //console.log(this) - }') - )) - - } - } - - # 2. Check for custom observers and initialize if needed - if(name %in% custom_observer_settings){ - runCustomObserver(name=name) - } - - # 3. label setting - labelSetting(ns=ns, name=name, label=setting_label, description=setting_description) - - # 4. Flag the input if it is required - if(name %in% req_settings){ - flagSetting(session=session, name=name, originalLabel=setting_label) - - } - } - }) - - - observe({ - for (name in isolate(input_names())){ - - # 5. Print a warning if the input failed a validation check - if(name %in% status_df()$text_key){ - - status_short <- status_df()[status_df()$text_key==name, "message_short"] - status_long <- status_df()[status_df()$text_key==name, "message_long"] - - updateSettingStatus(ns=ns, name=name, status_short=status_short, status_long=status_long) - } - - } - }) - + if(name %in% status_df()$text_key){ + + status_short <- status_df()[status_df()$text_key==name, "message_short"] + status_long <- status_df()[status_df()$text_key==name, "message_long"] + + updateSettingStatus(ns=ns, name=name, status_short=status_short, status_long=status_long) + } + + } + }) + ### return updated settings and status to global env. return(list(settings = reactive(settings_new()), status = reactive(status_new()))) From 5d7c82ff17cac91f3f88d6d84eb32fe1dd9fa044 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 16:23:40 -0500 Subject: [PATCH 06/40] little fixes in server.R --- inst/eDISH_app/server.R | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/inst/eDISH_app/server.R b/inst/eDISH_app/server.R index e18fc851..9ee0f420 100644 --- a/inst/eDISH_app/server.R +++ b/inst/eDISH_app/server.R @@ -9,7 +9,8 @@ function(input, output, session){ # add status to data panel nav bar # always OK for now, since example data is loaded by default output$data_tab_title = renderUI({ - HTML(paste("Data", icon("check", class="ok"))) + # HTML(paste("Data", icon("check", class="ok"))) + span(tagList("Data", icon("check", class="ok"))) }) # based on selected data set & generated/selected settings obj, generate settings page. @@ -20,7 +21,8 @@ function(input, output, session){ # # reutrns updated settings and validation status settings_new <- callModule(renderSettings, "settingsUI", - data = isolate(reactive(dataUpload_out$data_selected())), + # data = isolate(reactive(dataUpload_out$data_selected())), # this doesnt make sense + data = reactive(dataUpload_out$data_selected()), settings = reactive(dataUpload_out$settings()), status = reactive(dataUpload_out$status())) @@ -33,7 +35,7 @@ function(input, output, session){ HTML(paste("Settings", icon("times", class="notok"))) } }) - + # update charts navbar output$chart_tab_title = renderUI({ if (settings_new$status()$valid==TRUE){ @@ -42,8 +44,8 @@ function(input, output, session){ HTML(paste("Chart", icon("times", class="notok"))) } }) - - + + # module to render eDish chart callModule(renderEDishChart, "chartEDish", data = reactive(dataUpload_out$data_selected()), From 26056264514329fcc9d0c392aef121bea4ab6cc6 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 20 Feb 2019 16:33:39 -0500 Subject: [PATCH 07/40] delete old manual UI code --- .../modules/renderSettings/renderSettingsUI.R | 172 +----------------- 1 file changed, 1 insertion(+), 171 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 4101f68e..8eed9554 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -19,137 +19,6 @@ renderSettingsUI <- function(id){ column(4, wellPanel( uiOutput(ns("data_mapping_ui")) - # div( - # span(id = ns("tt_lbl_id_col"), title = "", - # tags$label(id = ns("lbl_id_col"), "")), - # span(id = ns("tt_msg_id_col"), title = "", - # tags$label(id = ns("msg_id_col"), "")), - # selectizeInput(ns("id_col"),NULL, choices = NULL) - # - # ), - # - # div( - # span(id = ns("tt_lbl_value_col"), title = "", - # tags$label(id = ns("lbl_value_col"), "")), - # span(id = ns("tt_msg_value_col"), title = "", - # tags$label(id = ns("msg_value_col"), "")), - # selectizeInput(ns("value_col"),NULL, choices = NULL) - # - # ), - # - # div( - # span(id = ns("tt_lbl_measure_col"), title = "", - # tags$label(id = ns("lbl_measure_col"), "")), - # span(id = ns("tt_msg_measure_col"), title = "", - # tags$label(id = ns("msg_measure_col"), "")), - # selectizeInput(ns("measure_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_measure_values--ALT"), title = "", - # tags$label(id = ns("lbl_measure_values--ALT"), "")), - # span(id = ns("tt_msg_measure_values--ALT"), title = "", - # tags$label(id = ns("msg_measure_values--ALT"), "")), - # selectizeInput(ns("measure_values--ALT"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_measure_values--AST"), title = "", - # tags$label(id = ns("lbl_measure_values--AST"), "")), - # span(id = ns("tt_msg_measure_values--AST"), title = "", - # tags$label(id = ns("msg_measure_values--AST"), "")), - # selectizeInput(ns("measure_values--AST"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_measure_values--TB"), title = "", - # tags$label(id = ns("lbl_measure_values--TB"), "")), - # span(id = ns("tt_msg_measure_values--TB"), title = "", - # tags$label(id = ns("msg_measure_values--TB"), "")), - # selectizeInput(ns("measure_values--TB"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_measure_values--ALP"), title = "", - # tags$label(id = ns("lbl_measure_values--ALP"), "")), - # span(id = ns("tt_msg_measure_values--ALP"), title = "", - # tags$label(id = ns("msg_measure_values--ALP"), "")), - # selectizeInput(ns("measure_values--ALP"),NULL, choices = NULL) - # ), - # # ), - # div( - # span(id = ns("tt_lbl_normal_col_low"), title = "", - # tags$label(id = ns("lbl_normal_col_low"), "")), - # span(id = ns("tt_msg_normal_col_low"), title = "", - # tags$label(id = ns("msg_normal_col_low"), "")), - # selectizeInput(ns("normal_col_low"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_normal_col_high"), title = "", - # tags$label(id = ns("lbl_normal_col_high"), "")), - # span(id = ns("tt_msg_normal_col_high"), title = "", - # tags$label(id = ns("msg_normal_col_high"), "")), - # selectizeInput(ns("normal_col_high"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_visit_col"), title = "", - # tags$label(id = ns("lbl_visit_col"), "")), - # span(id = ns("tt_msg_visit_col"), title = "", - # tags$label(id = ns("msg_visit_col"), "")), - # selectizeInput(ns("visit_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_visitn_col"), title = "", - # tags$label(id = ns("lbl_visitn_col"), "")), - # span(id = ns("tt_msg_visitn_col"), title = "", - # tags$label(id = ns("msg_visitn_col"), "")), - # selectizeInput(ns("visitn_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_studyday_col"), title = "", - # tags$label(id = ns("lbl_studyday_col"), "")), - # span(id = ns("tt_msg_studyday_col"), title = "", - # tags$label(id = ns("msg_studyday_col"), "")), - # selectizeInput(ns("studyday_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_baseline--value_col"), title = "", - # tags$label(id = ns("lbl_baseline--value_col"), "")), - # span(id = ns("tt_msg_baseline--value_col"), title = "", - # tags$label(id = ns("msg_baseline--value_col"), "")), - # selectizeInput(ns("baseline--value_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_baseline--values"), title = "", - # tags$label(id = ns("lbl_baseline--values"), "")), - # span(id = ns("tt_msg_baseline--values"), title = "", - # tags$label(id = ns("msg_baseline--values"), "")), - # selectizeInput(ns("baseline--values"),NULL, choices = NULL, multiple = TRUE) - # ), - # div( - # span(id = ns("tt_lbl_filters"), title = "", - # tags$label(id = ns("lbl_filters"), "")), - # span(id = ns("tt_msg_filters"), title = "", - # tags$label(id = ns("msg_filters"), "")), - # selectInput(ns("filters"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - # ), - # div( - # span(id = ns("tt_lbl_group_cols"), title = "", - # tags$label(id = ns("lbl_group_cols"), "")), - # span(id = ns("tt_msg_group_cols"), title = "", - # tags$label(id = ns("msg_group_cols"), "")), - # selectInput(ns("group_cols"),NULL, choices = NULL, selected = NULL, multiple = TRUE) - # ), - # div( - # span(id = ns("tt_lbl_analysisFlag--value_col"), title = "", - # tags$label(id = ns("lbl_analysisFlag--value_col"), "")), - # span(id = ns("tt_msg_analysisFlag--value_col"), title = "", - # tags$label(id = ns("msg_analysisFlag--value_col"), "")), - # selectizeInput(ns("analysisFlag--value_col"),NULL, choices = NULL) - # ), - # div( - # span(id = ns("tt_lbl_analysisFlag--values"), title = "", - # tags$label(id = ns("lbl_analysisFlag--values"), "")), - # span(id = ns("tt_msg_analysisFlag--values"), title = "", - # tags$label(id = ns("msg_analysisFlag--values"), "")), - # selectizeInput(ns("analysisFlag--values"),NULL, choices = NULL, multiple = TRUE) - # ) )) ) @@ -168,17 +37,7 @@ renderSettingsUI <- function(id){ column(4, wellPanel( uiOutput(ns("measure_settings_ui")) - # div( - # div(id = ns("tt_lbl_x_options"), title = "", - # tags$label(id = ns("lbl_x_options"), "")), - # selectizeInput(ns("x_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("ALT", "AST", "ALP"), multiple=TRUE) - # ), - # div( - # div(id = ns("tt_lbl_y_options"), title = "", - # tags$label(id = ns("lbl_y_options"), "")), - # selectizeInput(ns("y_options"),NULL, choices = c("ALT", "AST", "ALP","TB"), selected = c("TB"), multiple = TRUE) - # ) - + ) ) ) @@ -196,35 +55,6 @@ renderSettingsUI <- function(id){ column(4, wellPanel( uiOutput(ns("appearance_settings_ui")) - # div( - # div(id = ns("tt_lbl_visit_window"), title = "", - # tags$label(id = ns("lbl_visit_window"), "")), - # sliderInput(ns("visit_window"),NULL, value = 30, min=0, max=50) - # ), - # div( - # div(id = ns("tt_lbl_r_ratio_filter"), title = "", - # tags$label(id = ns("lbl_r_ratio_filter"), "")), - # checkboxInput(ns("r_ratio_filter"),NULL, value = TRUE) - # ), - # conditionalPanel( - # condition="input.r_ratio_filter==true", ns=ns, - # div( - # div(id = ns("tt_lbl_r_ratio_cut"), title = "", - # tags$label(id = ns("lbl_r_ratio_cut"), "")), - # sliderInput(ns("r_ratio_cut"),NULL, value = 0, min=0, max =1) - # ) - # ), - # div( - # div(id = ns("tt_lbl_showTitle"), title = "", - # tags$label(id = ns("lbl_showTitle"), "")), - # checkboxInput(ns("showTitle"),NULL, value = TRUE) - # ), - # div( - # div(id = ns("tt_lbl_warningText"), title = "", - # tags$label(id = ns("lbl_warningText"), "")), - # textAreaInput (ns("warningText"),NULL, rows =4, - # value = "Caution: This interactive graphic is not validated. Any clinical recommendations based on this tool should be confirmed using your organizations standard operating procedures.") - # ) ) ) ) From 6ad72d18891a4bc1912473d40101cea35c52c37d Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 21 Feb 2019 10:58:36 -0500 Subject: [PATCH 08/40] add chart selection --- .../modules/renderSettings/renderSettings.R | 13 +++++--- .../modules/renderSettings/renderSettingsUI.R | 32 +++++++++++++++---- 2 files changed, 35 insertions(+), 10 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 391d9cae..6e0c4ada 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -17,19 +17,22 @@ renderSettings <- function(input, output, session, data, settings, status){ # - create elements based on metadata file # - populate using data/settings ###################################################################### - + output$data_mapping_ui <- renderUI({ - tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts="edish", ns=ns)) + req(input$select_charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts=input$charts, ns=ns)) }) outputOptions(output, "data_mapping_ui", suspendWhenHidden = FALSE) output$measure_settings_ui <- renderUI({ - tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "measure", charts="edish", ns=ns)) + req(input$select_charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "measure", charts=input$charts, ns=ns)) }) outputOptions(output, "measure_settings_ui", suspendWhenHidden = FALSE) output$appearance_settings_ui <- renderUI({ - tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "appearance", charts="edish", ns=ns)) + req(input$select_charts) + tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "appearance", charts=input$charts, ns=ns)) }) outputOptions(output, "appearance_settings_ui", suspendWhenHidden = FALSE) @@ -40,6 +43,8 @@ renderSettings <- function(input, output, session, data, settings, status){ # TO-do: make a function! ###################################################################### + #field_keys <- getSettingsMetadata(chartcol="text_key") + observe({ toggleState(id = "measure_values--ALT", condition = !input$measure_col=="") toggleState(id = "measure_values--AST", condition = !input$measure_col=="") diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 8eed9554..1856685f 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -5,11 +5,31 @@ renderSettingsUI <- function(id){ tagList( verticalLayout( - fluidRow( - column(6, + column(4, + wellPanel( + div( + span(h2(tags$strong("Select Chart(s):"))), + checkboxGroupInput(ns("select_charts"),"", + choices = c("e-DISH" = "edish"), + selected="edish")) + ) + ) + ), + fluidRow( + column(4, + tags$hr() + ) + ), + fluidRow( + column(4, + h2(tags$strong("Customize Settings:")) + ) + ), + fluidRow( + column(4, div( - div(style="display: inline-block;", h3("Data Mapping")), + div(style="display: inline-block;", h3(tags$i("Data Mapping"))), div(style="display: inline-block;", checkboxInput(ns("show_data_mapping"), "show", TRUE)) ) ) @@ -25,9 +45,9 @@ renderSettingsUI <- function(id){ ), fluidRow( - column(6, + column(4, div( - div(style="display: inline-block;", h3("Measure Settings")), + div(style="display: inline-block;", h3(tags$i("Measure Settings"))), div(style="display: inline-block;", checkboxInput(ns("show_measure_settings"), "show", TRUE)) ) ) @@ -45,7 +65,7 @@ renderSettingsUI <- function(id){ fluidRow( column(6, div( - div(style="display: inline-block;", h3("Appearance Settings")), + div(style="display: inline-block;", h3(tags$i("Appearance Settings"))), div(style="display: inline-block;", checkboxInput(ns("show_appearance_settings"), "show", TRUE)) ) ) From 9841dbff43e64cbaf42430fdcbdd1a7508782cda Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 21 Feb 2019 11:50:28 -0500 Subject: [PATCH 09/40] toggle field-level inputs on and off --- .../modules/renderSettings/renderSettings.R | 103 ++++++++++-------- 1 file changed, 57 insertions(+), 46 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 6e0c4ada..4d49004e 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -43,74 +43,85 @@ renderSettings <- function(input, output, session, data, settings, status){ # TO-do: make a function! ###################################################################### - #field_keys <- getSettingsMetadata(chartcol="text_key") - + # Toggle field-level inputs: + # ON - if column-level input is selected) + # OFF - if column-level input is not yet selected observe({ - toggleState(id = "measure_values--ALT", condition = !input$measure_col=="") - toggleState(id = "measure_values--AST", condition = !input$measure_col=="") - toggleState(id = "measure_values--TB", condition = !input$measure_col=="") - toggleState(id = "measure_values--ALP", condition = !input$measure_col=="") + req(input$select_charts) + field_keys <- getSettingsMetadata(charts=input$select_charts, + cols=c("text_key", "field_column_key"), + filter_expr = field_mapping==TRUE) + + for (key in field_keys$text_key){ + + column_key <- filter(field_keys, text_key==key) %>% pull(field_column_key) + + toggleState(id = key, condition = !input[[column_key]]=="") + } }) - observe({ - req(input$measure_col) - if (! input$measure_col == isolate(settings()$measure_col)){ - choices_ast <- unique(data()[,input$measure_col]) - choices_alt <- unique(data()[,input$measure_col]) - choices_tb <- unique(data()[,input$measure_col]) - choices_alp <- unique(data()[,input$measure_col]) - - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) + + observeEvent(input$measure_col, { + if (is.null(isolate(settings()$measure_col)) || ! input$measure_col == isolate(settings()$measure_col)){ + if (input$measure_col %in% colnames(data())){ + choices_ast <- unique(data()[,input$measure_col]) + choices_alt <- unique(data()[,input$measure_col]) + choices_tb <- unique(data()[,input$measure_col]) + choices_alp <- unique(data()[,input$measure_col]) + + updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) + onInitialize = I('function() { + this.setValue(""); + }'))) updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) + onInitialize = I('function() { + this.setValue(""); + }'))) updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) + onInitialize = I('function() { + this.setValue(""); + }'))) + } } }) - - - observe({ - toggleState(id = "baseline--values", condition = !input$`baseline--value_col`=="") - }) - observe({ - req(input$`baseline--value_col`) - if (! input$`baseline--value_col` == isolate(settings()$`baseline--value_col`)){ + + observeEvent(input$`baseline--value_col`, { + + #req(input$`baseline--value_col`) + if (is.null(isolate(settings()$`baseline--value_col`)) || ! input$`baseline--value_col` == isolate(settings()$`baseline--value_col`)){ + if (input$`baseline--value_col` %in% colnames(data())){ + choices <- data()[,input$`baseline--value_col`] %>% unique %>% sort - + updateSelectizeInput(session, "baseline--values", choices = choices, options = list(placeholder = "Please select a value", onInitialize = I('function() { this.setValue(""); }'))) + } } }) - - observe({ - toggleState(id = "analysisFlag--values", condition = !input$`analysisFlag--value_col`=="") - }) - observe({ - req(input$`analysisFlag--value_col`) - if (! input$`analysisFlag--value_col` == isolate(settings()$`analysisFlag--value_col`)){ + + observeEvent(input$`analysisFlag--value_col`, { + # req(input$`analysisFlag--value_col`) + + if (is.null(isolate(settings()$`analysisFlag--value_col`)) || ! input$`analysisFlag--value_col` == isolate(settings()$`analysisFlag--value_col`)){ + if (input$`baseline--value_col` %in% colnames(data())){ + choices <- data()[,input$`analysisFlag--value_col`] %>% unique %>% sort - + updateSelectizeInput(session, "analysisFlag--values", choices = choices, options = list(placeholder = "Please select a value", onInitialize = I('function() { this.setValue(""); }'))) - } + } + } }) From b6dc7526fbcaa65eeabeb4307b318446ad275cba Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 21 Feb 2019 12:10:32 -0500 Subject: [PATCH 10/40] add some notes to self --- .../modules/renderSettings/renderSettings.R | 16 ++++++++++------ 1 file changed, 10 insertions(+), 6 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 4d49004e..20493ed7 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -39,8 +39,6 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### # Update field level settings if a column level setting is changed - # - # TO-do: make a function! ###################################################################### # Toggle field-level inputs: @@ -57,9 +55,13 @@ renderSettings <- function(input, output, session, data, settings, status){ column_key <- filter(field_keys, text_key==key) %>% pull(field_column_key) toggleState(id = key, condition = !input[[column_key]]=="") + } }) + + ### NOTE: i think the following 3 observers need to be in modules so we can + ### pass the column_key as a function param observeEvent(input$measure_col, { if (is.null(isolate(settings()$measure_col)) || ! input$measure_col == isolate(settings()$measure_col)){ if (input$measure_col %in% colnames(data())){ @@ -93,8 +95,7 @@ renderSettings <- function(input, output, session, data, settings, status){ }) observeEvent(input$`baseline--value_col`, { - - #req(input$`baseline--value_col`) + if (is.null(isolate(settings()$`baseline--value_col`)) || ! input$`baseline--value_col` == isolate(settings()$`baseline--value_col`)){ if (input$`baseline--value_col` %in% colnames(data())){ @@ -109,8 +110,7 @@ renderSettings <- function(input, output, session, data, settings, status){ }) observeEvent(input$`analysisFlag--value_col`, { - # req(input$`analysisFlag--value_col`) - + if (is.null(isolate(settings()$`analysisFlag--value_col`)) || ! input$`analysisFlag--value_col` == isolate(settings()$`analysisFlag--value_col`)){ if (input$`baseline--value_col` %in% colnames(data())){ @@ -243,6 +243,10 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### # print validation messages + # + # Right now we are re-printing ALL status messages upon validation update. + # if we make a module, we have the option of printing ONLY the + # message for input that changed. ###################################################################### observe({ for (name in isolate(input_names())){ From 535667a9fd838e8bae480d0d1d0fb4c6e6005db0 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 21 Feb 2019 12:13:38 -0500 Subject: [PATCH 11/40] add more notes to self re: modules --- inst/eDISH_app/modules/renderSettings/renderSettings.R | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 20493ed7..b7897210 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -38,7 +38,10 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### - # Update field level settings if a column level setting is changed + # Update field level inputs + # + # NOTE: i think the following 4 observers need to be in modules so we can + # pass the field_key or column_key as a function param ###################################################################### # Toggle field-level inputs: @@ -60,8 +63,8 @@ renderSettings <- function(input, output, session, data, settings, status){ }) - ### NOTE: i think the following 3 observers need to be in modules so we can - ### pass the column_key as a function param + # update field-level inputs if a column level setting changes + observeEvent(input$measure_col, { if (is.null(isolate(settings()$measure_col)) || ! input$measure_col == isolate(settings()$measure_col)){ if (input$measure_col %in% colnames(data())){ From 049d36de0335f6636e3a4abe5f63b6830e0a6d59 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 21 Feb 2019 15:53:00 -0500 Subject: [PATCH 12/40] dynamically update field-level inputs --- .../modules/renderSettings/renderSettings.R | 121 ++++++------------ 1 file changed, 40 insertions(+), 81 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index b7897210..175c0967 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -8,7 +8,7 @@ renderSettings <- function(input, output, session, data, settings, status){ ns <- session$ns #List of all inputs - input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts="eDiSH", cols="text_key")}) + input_names <- reactive({safetyGraphics:::getSettingsMetadata(charts=input$selected_charts, cols="text_key")}) ###################################################################### @@ -39,95 +39,54 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### # Update field level inputs - # - # NOTE: i think the following 4 observers need to be in modules so we can - # pass the field_key or column_key as a function param ###################################################################### - - # Toggle field-level inputs: - # ON - if column-level input is selected) - # OFF - if column-level input is not yet selected - observe({ - req(input$select_charts) - field_keys <- getSettingsMetadata(charts=input$select_charts, - cols=c("text_key", "field_column_key"), - filter_expr = field_mapping==TRUE) - for (key in field_keys$text_key){ - - column_key <- filter(field_keys, text_key==key) %>% pull(field_column_key) - - toggleState(id = key, condition = !input[[column_key]]=="") - - } - }) - # update field-level inputs if a column level setting changes - - observeEvent(input$measure_col, { - if (is.null(isolate(settings()$measure_col)) || ! input$measure_col == isolate(settings()$measure_col)){ - if (input$measure_col %in% colnames(data())){ - choices_ast <- unique(data()[,input$measure_col]) - choices_alt <- unique(data()[,input$measure_col]) - choices_tb <- unique(data()[,input$measure_col]) - choices_alp <- unique(data()[,input$measure_col]) + # dependent on change in data, chart selection, or column-level input + observe({ + + column_keys <- getSettingsMetadata(charts=input$select_charts, + filter_expr = field_mapping==TRUE) %>% + pull(field_column_key) %>% + unique %>% + as.list() + + lapply(column_keys, function(col){ + + col_quo <- enquo(col) + observeEvent(input[[col]],{ + + field_keys <- getSettingsMetadata(charts=input$select_charts, col = "text_key", + filter_expr = field_column_key==!!col) - updateSelectizeInput(session, "measure_values--ALT", choices = choices_alt, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--AST", choices = choices_ast, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--TB", choices = choices_tb, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - updateSelectizeInput(session, "measure_values--ALP", choices = choices_alp, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); - }'))) - } - } - }) - - observeEvent(input$`baseline--value_col`, { - - if (is.null(isolate(settings()$`baseline--value_col`)) || ! input$`baseline--value_col` == isolate(settings()$`baseline--value_col`)){ - if (input$`baseline--value_col` %in% colnames(data())){ - choices <- data()[,input$`baseline--value_col`] %>% unique %>% sort + # Toggle field-level inputs: + # ON - if column-level input is selected) + # OFF - if column-level input is not yet selected + for (fk in field_keys){ + toggleState(id = fk, condition = !input[[col]]=="") + } - updateSelectizeInput(session, "baseline--values", choices = choices, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); }'))) + if (is.null(isolate(settings()[[col]])) || ! input[[col]] == isolate(settings()[[col]])){ + if (input[[col]] %in% colnames(data())){ + + choices <- unique(data()[,input[[col]]]) + + for (key in field_keys){ + updateSelectizeInput(session, inputId = key, choices = choices, + options = list(placeholder = "Please select a value", + onInitialize = I('function() { + this.setValue(""); + }'))) + } + } + } } - } + ) }) - - observeEvent(input$`analysisFlag--value_col`, { - - if (is.null(isolate(settings()$`analysisFlag--value_col`)) || ! input$`analysisFlag--value_col` == isolate(settings()$`analysisFlag--value_col`)){ - if (input$`baseline--value_col` %in% colnames(data())){ - - choices <- data()[,input$`analysisFlag--value_col`] %>% unique %>% sort - - updateSelectizeInput(session, "analysisFlag--values", choices = choices, - options = list(placeholder = "Please select a value", - onInitialize = I('function() { - this.setValue(""); }'))) - } - } - }) - - + }) + ###################################################################### # Fill settings object based on selections From ca4561a39696e262c5853b78b379f15235329eed Mon Sep 17 00:00:00 2001 From: jwildfire Date: Thu, 21 Feb 2019 20:55:13 -0800 Subject: [PATCH 13/40] update version --- DESCRIPTION | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 8627616e..00b447c9 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -1,6 +1,6 @@ Package: safetyGraphics Title: Create Interactive Graphics Related to Clinical Trial Safety -Version: 0.8.1 +Version: 0.9.0 Authors@R: c( person("Jeremy", "Wildfire", email = "jeremy_wildfire@rhoworld.com", role = c("cre","aut")), person("Becca", "Krouse", role="aut"), From 81e7390ba36622e8abb4d04c36134307f6ea6bd0 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Fri, 22 Feb 2019 07:47:43 -0800 Subject: [PATCH 14/40] update data standard tracking --- R/detectStandard.R | 25 ++++++----- R/evaluateStandard.R | 3 +- R/getSettingsMetadata.R | 11 ++++- data-raw/csv_to_rda.R | 5 ++- data-raw/settingsMetadata.csv | 52 +++++++++++----------- data-raw/standardsMetadata.csv | 26 +++++++++++ data/settingsMetadata.rda | Bin 1952 -> 1773 bytes data/standardsMetadata.rda | Bin 0 -> 702 bytes tests/testthat/test_detectStandard.R | 48 ++++++++++---------- tests/testthat/test_getSettingsMetadata.R | 19 +++++--- 10 files changed, 118 insertions(+), 71 deletions(-) create mode 100644 data-raw/standardsMetadata.csv create mode 100644 data/standardsMetadata.rda diff --git a/R/detectStandard.R b/R/detectStandard.R index 6a7acf5a..412f4070 100644 --- a/R/detectStandard.R +++ b/R/detectStandard.R @@ -27,22 +27,25 @@ detectStandard <- function(data, includeFields=TRUE, domain="labs"){ # Create placeholder list, with Standard = None. + available_standards <- standardsMetadata %>% select(-text_key) %>% names standard_list <- list() standard_list[["details"]] = list() - standard_list[["details"]][["ADaM"]]<-evaluateStandard(data,standard="ADaM", includeFields=includeFields, domain=domain) - standard_list[["details"]][["SDTM"]]<-evaluateStandard(data,standard="SDTM", includeFields=includeFields, domain=domain) + for(standard in available_standards){ + standard_list[["details"]][[standard]]<-evaluateStandard(data,standard=standard, includeFields=includeFields, domain=domain) + } # Determine the final standard - if(standard_list[["details"]][["SDTM"]][["match"]] == "Full"){ - standard_list[["standard"]]<- "SDTM" - } else if(standard_list[["details"]][["ADaM"]][["match"]] == "Full"){ - standard_list[["standard"]]<- "ADaM" - } else if(standard_list[["details"]][["SDTM"]][["match"]] == "Partial" | - standard_list[["details"]][["ADaM"]][["match"]] == "Partial"){ + # TODO: write a general algorithm to do this ... + if(standard_list[["details"]][["sdtm"]][["match"]] == "Full"){ + standard_list[["standard"]]<- "sdtm" + } else if(standard_list[["details"]][["adam"]][["match"]] == "Full"){ + standard_list[["standard"]]<- "adam" + } else if(standard_list[["details"]][["sdtm"]][["match"]] == "Partial" | + standard_list[["details"]][["adam"]][["match"]] == "Partial"){ standard_list[["standard"]] <- ifelse( - length(standard_list[["details"]][["ADaM"]][["valid_count"]]) > - length(standard_list[["details"]][["SDTM"]][["valid_count"]]), - "ADaM" , "SDTM" #SDTM if they are equal + length(standard_list[["details"]][["adam"]][["valid_count"]]) > + length(standard_list[["details"]][["sdtm"]][["valid_count"]]), + "adam" , "sdtm" #SDTM if they are equal ) } else { diff --git a/R/evaluateStandard.R b/R/evaluateStandard.R index ae820df5..6bf954de 100644 --- a/R/evaluateStandard.R +++ b/R/evaluateStandard.R @@ -26,8 +26,7 @@ evaluateStandard <- function(data, standard, includeFields=TRUE, domain="labs"){ is.data.frame(data), is.character(standard), is.logical(includeFields), - is.character(domain), - tolower(standard) %in% c("adam","sdtm") + is.character(domain) ) standard<-tolower(standard) diff --git a/R/getSettingsMetadata.R b/R/getSettingsMetadata.R index 14257138..fed8578b 100644 --- a/R/getSettingsMetadata.R +++ b/R/getSettingsMetadata.R @@ -5,6 +5,7 @@ #' @param charts optional vector of chart names used to filter the metadata. Exact matches only (case-insensitive). All rows returned by default. #' @param text_keys optional vector of keys used to filter the metadata. Partial matches for any of the strings are returned (case-insensitive). All rows returned by default. #' @param filter_expr optional filter expression used to subset the data. +#' @param add_standards should data standard info stored in standardsMetadata be included #' @param cols optional vector of columns to return from the metadata. All columns returned by default. #' @param metadata metadata data frame to be queried #' @@ -27,9 +28,15 @@ #' #' @export -getSettingsMetadata<-function(charts=NULL, text_keys=NULL, cols=NULL, filter_expr=NULL, metadata = safetyGraphics::settingsMetadata){ +getSettingsMetadata<-function(charts=NULL, text_keys=NULL, cols=NULL, filter_expr=NULL, add_standards=TRUE, metadata = safetyGraphics::settingsMetadata){ - md <- metadata + md <- metadata %>% mutate(text_key=as.character(text_key)) + + if(add_standards){ + ms<-standardsMetadata %>% mutate(text_key=as.character(text_key)) + md<-md%>%left_join(ms, by="text_key") + } + all_columns <- names(md) #filter the metadata based on the charts option (if any) diff --git a/data-raw/csv_to_rda.R b/data-raw/csv_to_rda.R index 9449676f..de6c8b5f 100644 --- a/data-raw/csv_to_rda.R +++ b/data-raw/csv_to_rda.R @@ -3,5 +3,8 @@ library(usethis) ablbc <- read.csv("data-raw/adlbc.csv") usethis::use_data(adlbc, overwrite = TRUE) -settingsMetadata<- read.csv("data-raw/settingsMetadata.csv") +settingsMetadata <- read.csv("data-raw/settingsMetadata.csv") usethis::use_data(settingsMetadata, overwrite = TRUE) + +standardsMetadata <- read.csv("data-raw/standardsMetadata.csv") +usethis::use_data(standardsMetadata, overwrite = TRUE) \ No newline at end of file diff --git a/data-raw/settingsMetadata.csv b/data-raw/settingsMetadata.csv index ce95c2f3..e56da6c2 100644 --- a/data-raw/settingsMetadata.csv +++ b/data-raw/settingsMetadata.csv @@ -1,26 +1,26 @@ -chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key,adam,sdtm -TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE,,USUBJID,USUBJID -TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE,,AVAL,STRESN -TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE,,PARAM,TEST -TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1LO,STNRLO -TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE,,A1HI,STNRHI -TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE,,ADY,DY -TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE,,VISIT,VISIT -TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE,,VISITNUM,VISITNUM -TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE,,, -TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE,,, -TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)" -TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)" -TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Bilirubin (umol/L),Total Bilirubin -TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP) -TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE,,, -TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col,, -TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE,,, -TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col,, -TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,, -TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE,,, -TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE,,, -TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE,,, -TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE,,, -TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE,,, -TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",Character,FALSE,FALSE,NA,FALSE,,, \ No newline at end of file +chart_edish,text_key,label,description,setting_type,setting_required,column_mapping,column_type,field_mapping,field_column_key +TRUE,id_col,ID column,Unique subject identifier variable name.,character,TRUE,TRUE,character,FALSE, +TRUE,value_col,Value column,Lab result variable name.,character,TRUE,TRUE,numeric,FALSE, +TRUE,measure_col,Measure column,Lab measure variable name,character,TRUE,TRUE,character,FALSE, +TRUE,normal_col_low,Lower Limit of Normal column,Lower limit of normal variable name,character,TRUE,TRUE,numeric,FALSE, +TRUE,normal_col_high,Upper Limit of Normal column,Upper limit of normal variable name,character,TRUE,TRUE,numeric,FALSE, +TRUE,studyday_col,Study Day column,Visit day variable name,character,TRUE,TRUE,numeric,FALSE, +TRUE,visit_col,Visit column,Visit variable name,character,FALSE,TRUE,character,FALSE, +TRUE,visitn_col,Visit Number column,Visit number variable name,character,FALSE,TRUE,numeric,FALSE, +TRUE,filters,Filters columns,"An optional list of specifications for filters. Each filter is a nested, named list (containing the filter value column: 'value_col' and associated label: 'label') within the larger list.",vector,FALSE,TRUE,NA,FALSE, +TRUE,group_cols,Group columns,"An optional list of specifications for grouping columns. Each group column is a nested, named list (containing the group variable column: 'value_col' and associated label: 'label') within the larger list. ",vector,FALSE,TRUE,NA,FALSE, +TRUE,measure_values--ALT,Alanine Aminotransferase value,Value used for Alanine Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col +TRUE,measure_values--AST,Aspartate Aminotransferase value,Value used for Aspartate Aminotransferase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col +TRUE,measure_values--TB,Total Bilirubin value,Value used for Total Bilirubin in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col +TRUE,measure_values--ALP,Alkaline Phosphatase value,Value used for Alkaline Phosphatase in the specified measure column,character,TRUE,FALSE,NA,TRUE,measure_col +TRUE,baseline--value_col,Baseline column,An optional list defining which column represent the baseline visit(s) of the study.,character,FALSE,TRUE,NA,FALSE, +TRUE,baseline--values,Baseline values,An optional list defining which values (one or more) represent the baseline visit(s) of the study.,vector,FALSE,FALSE,NA,TRUE,baseline--value_col +TRUE,analysisFlag--value_col,Analysis Flag column,An optional list defining which column should be used in eDish and mDish analyses.,character,FALSE,TRUE,NA,FALSE, +TRUE,analysisFlag--values,Analysis Flag values,An optional list defining which values should be used in eDish and mDish analyses.,vector,FALSE,FALSE,NA,TRUE,analysisFlag--value_col +TRUE,x_options,X axis options,"Specifies variable options for the x-axis using the key values from measure_values (e.g. 'ALT'). When multiple options are specified, a control allowing the user to interactively change the x variable is shown. ",vector,FALSE,FALSE,NA,FALSE, +TRUE,y_options,Y axis options,"Specifies variable options for the y-axis using the key values from measure_values (e.g. 'TB'). When multiple options are specified, a control allowing the user to interactively change the y variable is shown. ",vector,FALSE,FALSE,NA,FALSE, +TRUE,visit_window,Default Visit Window in Days ,Default visit window used to highlight eDish points where x and y measures occurred within the specified number of days. Editable by user after render. ,numeric,FALSE,FALSE,NA,FALSE, +TRUE,r_ratio_filter,Show R Ratio Filter?,Specifies whether the R Ratio filter should be shown. R ratio is defined as: (ALT value/ULN for ALT) / (ALP value/ULN for ALP).,logical,FALSE,FALSE,NA,FALSE, +TRUE,r_ratio_cut,Default R Ratio Cut,Default cut point for R Ratio filter. Ignored when r_ratio_filter = FALSE. User can update this setting via the UI when r_ratio_filter = TRUE. ,numeric,FALSE,FALSE,NA,FALSE, +TRUE,showTitle,Show Chart Title? ,Specifies whether the title should be drawn above the controls.,logical,FALSE,FALSE,NA,FALSE, +TRUE,warningText,Warning text,"Informational text to be displayed near the top of the controls (beneath the title, if any). No warning is displayed if warningText = ''. ",Character,FALSE,FALSE,NA,FALSE, \ No newline at end of file diff --git a/data-raw/standardsMetadata.csv b/data-raw/standardsMetadata.csv new file mode 100644 index 00000000..6f0567ce --- /dev/null +++ b/data-raw/standardsMetadata.csv @@ -0,0 +1,26 @@ +text_key,adam,sdtm +id_col,USUBJID,USUBJID +value_col,AVAL,STRESN +measure_col,PARAM,TEST +normal_col_low,A1LO,STNRLO +normal_col_high,A1HI,STNRHI +studyday_col,ADY,DY +visit_col,VISIT,VISIT +visitn_col,VISITNUM,VISITNUM +filters,, +group_cols,, +measure_values--ALT,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)" +measure_values--AST,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)" +measure_values--TB,Bilirubin (umol/L),Total Bilirubin +measure_values--ALP,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP) +baseline--value_col,, +baseline--values,, +analysisFlag--value_col,, +analysisFlag--values,, +x_options,, +y_options,, +visit_window,, +r_ratio_filter,, +r_ratio_cut,, +showTitle,, +warningText,, \ No newline at end of file diff --git a/data/settingsMetadata.rda b/data/settingsMetadata.rda index c70c9c65635c9e1653236e721fe5a9073d45f8ee..828fbac52b60f34547fcf13deddec721ad53629a 100644 GIT binary patch literal 1773 zcmVYrqPrPfHE`y0BF-dG&IvksPzH0Jwt|o0BAHC z0|Wrj(@cP9Xwx7DAZP%|;7A$(0iXZ?00000XaE2X8UO*H&}a-014B(R0imNzfEa56L$A$>M; z&3S>;oPckqG=m-aOJ_xl@E?5HXNsOGrB9H7A;P{c4TT!8cH2pBg~8+erzqLST?DCxQqX4>Kgt zBuxzsA@Q&dMjxH~Z2&E;AR7c=(gYtn7wTu7h*J|t6KM%--NhxG88uiykVzsDUDHY7-QX6WzBudO%b-|cwbn*D- zj#nPY<LJZ@7C~dq7 zWi-r#HaquA`b#3Jmz^Nw#N^orUlDT}Ety(1eAM~TFjj}8bxaBrXr0*kg98T0P?@@+ zNyQ5GZpTnOP{VpbrXVSn8Ge$ZShxV>3l{wC%Y;e*$jF@?G!O;5W(g#dm%e*|H#0T5 zqN;_grB@XneST3zp%peV)|$~}*m+?SM~^!7sU)YZHg+;YBzh0J zhU72t_yAQPe$8aF3_TXfA@IER*>^WihPYBq-BHZpRC+hYP}3>94Dij1#kLdw!M_B_)ZZZr$gAnu#CE(bFm}I->NONT&CRGMZD0KNsrRr_@iI-irARKJk z_mx3@B_P;P(IGX?R69ePIOv48TemThVD}ABK_%>WBit7#q+CT2pctjCcWE5p;<3_a zHg0EQ0tPgOKtTtS(op6{#6i={afT+10H!h*S0&8_lI8Jg|;mS!6BAF5W5z{VXZgF&v!-N=C7vjRIvr^Dz<@ z78g5h5SOxo8LQdOFqcu-NFXyKzv0y~3CD<;3#{JF!}iEQ`Ga`_CkGL*=s3<&c!@ZK zn3@>In9$lK1Oegau|+eBj36h-8?&OrrZ5Iky6W`OO6e<{w@N{fW;%WLz3i}74Fqj` zIY$s{WG)khP?<;|B%wA8&d!mASz6l*tksaRNu>mEWlf&nq2d^dVX3PYM8Rr1N+8@! z&X|nk%+4l~@)(#AZF<}d%sMpinkHUl=V7W2^Na_LjO5CV7BN@{1{NC5el~zh6D1Yk z6hX+7Vq-2)#Ihj}mTN}bdqTVkZG5O5iEyyy@5G`(yO_$eYp Pzxcb7DZ+$>^&lR==-pa26v01XC)hJldv4FgRMG&D3c13+R1 zfXDy?O#lr5$N&HaIMC40&rBsMR(mYm@vEN5TY(x0QsKQy<1C}cix?fgu zr98U6Pmc_(r_X)a#VsfFQgp_UdlH{JCiLa43?Ia--JBG6104Ni0zF`D39%-?6KM%C zAWO^Of(C=%WS9vlp^2oQGeSAod(ZPQ1BIlL8$)RT*a3SI0e>bh(Ec_cCId)Gv;c1A z*e^pp0rGB!it-I{am%b!7BKmjYwh+g&1pP|UO%kMB=Cw;=?m*RQcQoWyvDN3_0FN6 z=Sz;jVt6PTx+BQk+_xGP3QQHO0MBr)wOopjhIZK~-aR$|?<42Gvq2ZDHGaQ4S8ciMW%&m#F$;n%OnWni}QmnP1j#PBm`hpJ*! zV!U+lt_KEY7ZlqC`4mj3L7?Bv8}5Njrn!)5hZh3rt)YbD$l`_5;_51r%pj&GAbeRm zQlNQR<07rMXnVnHmT7}A#F3uE&{2a0+1oYzQ~j^b9wrHcTrZf!z4Z)oZp73Sd%tVx z38iTpWWGX4iNz*`M}0%_i)`T!Hg2p6INw!`PI z!a4=JA>}SSip*f)Sg~S{gG53CGZ5&{(Qq&vJA-Lhr&myzFVb+BJp(W>8Fw^BDb}qO zY4RCYX%>YZM`0ZPa~%{YtQRPxMLIz)K@_6p9$3cz^3Ca)owaHa6P$50w+a zn54EBg~1#|{2_uhZ8(Bh9@*Hy%!v9=B~IDy!X}RvYt)G(r?ED6*&&iV=iNhk7mNP@ zRUm%FWU?53n_`6cuB499zz~rGK-g&_$FtRMWs0|Fe9rXLXSg?+<0mL>wobh;oHp2X z1*a6h% z?9^Ou3AxmQhZkf!DBOw`OBJ{;q{_)&EjyGeInRKc%ZiaKFOYSCT||>NAj#MmUR^U_ z_g+vqJovVIA=xruKR6uWa1ue+^1?Y6IDSWDG>xBZ9jOhVZ4F3)ZZ28*EOol+%)_=1 zbO*Y|`hq~0v~~y@Tdh#Ht%O!0uvfTAZ&sU55!RBMLfz!Pcgj3uaYKEW`JZ85T>JkS2ONwLJdiK)}(qle`IHOoAXH#}P>y*wgr!Q?M}{od-%r z!I`xKK$&1Y#v($(;d8dp2s_9jmv^%mOQ<^3fPl#!w{Kj?Cmr%+F2Tah;Qg`?egNSh zHbF@o1kQtuA96_;=xTgxCGLS$?LTnkEIz|;`YisUVSIsb4B+`)_Y_YrC z{O=Gk6vJayEQx~HW9zD*;0hB=Mr6#KO(o(mFCyD^xEq*s>f@RwT{7v|YJ<9Qc<`~B zm{b~8Fjt2g3k_y`Hh@b56&2$OAmvH1F_#oDEFA7gk_`a87zb91pwp4t6|EdT9amcX7VPiCW&WpEwzvrOC{!ZO3JP!T8@)0WTtBzq4&n7c#NZ< zQB>pK^hMsS=@;v$tt}8FfK(~z-?(_jZY$4#J=$0 zRmDw=p?>*L@4n3026OC@(K8>M@@^9mTs;EWR|r7^LP24EAg~stsmk{mFk&7sC1J!w zO1gSY94$K6tRsla#B&$VUZm`|kBgy+z-7uj`nBDoLInLu-e|W?Y{QT<%?eK#FvAf5 zP}7uw@l?uZHbf|w#*G=13yT?%3#hJoWwWXC@6%0QH!>?D3Ph5qNeCHBP%H@v@uvKB z_fs%a+07{=(_6ApThUUn(p5DLSjvF9Ay61ZPKs7m5?TVfsHQQSSs|IlB;`V@YPfk2 zeP|aQDcI5w)qsJ;6tTc54-fN#G2me+8S0EBB1z3cb_HvBG;5?gS0R>IbU9%FxW_UR z8>#w}n2l=Rg0oeSiH7vRkW+M$Lsg@4ZDc#uv6ahgy~~9!JPdA=!F8nqlr&~Q@x~}i kA1GuOJ{!{wa*UF#eW$l?(GQw9 Date: Fri, 22 Feb 2019 08:37:41 -0800 Subject: [PATCH 15/40] automate standard adjudication --- R/detectStandard.R | 46 ++++++++++++++++--------- R/evaluateStandard.R | 17 ++++----- data-raw/standardsMetadata.csv | 20 +++++------ data/standardsMetadata.rda | Bin 702 -> 696 bytes man/getSettingsMetadata.Rd | 5 ++- tests/testthat/test_detectStandard.R | 37 ++++++++++---------- tests/testthat/test_evaluateStandard.R | 10 +++--- 7 files changed, 77 insertions(+), 58 deletions(-) diff --git a/R/detectStandard.R b/R/detectStandard.R index 412f4070..357cfd77 100644 --- a/R/detectStandard.R +++ b/R/detectStandard.R @@ -26,31 +26,45 @@ detectStandard <- function(data, includeFields=TRUE, domain="labs"){ ) - # Create placeholder list, with Standard = None. + # Create placeholder list, with Standard = none. available_standards <- standardsMetadata %>% select(-text_key) %>% names standard_list <- list() standard_list[["details"]] = list() + standard_list[["standard"]] = "none" + standard_list[["standard_percent"]] = 0 + for(standard in available_standards){ + # evaluate the current standard and save the result standard_list[["details"]][[standard]]<-evaluateStandard(data,standard=standard, includeFields=includeFields, domain=domain) + + # if the current standard is a better match, use it as the overall standard + # if there is a tie, don't change the standard - this means the column order in standardMetadata breaks ties! + current_percent <- standard_list[["details"]][[standard]][["match_percent"]] + overall_percent <- standard_list[["standard_percent"]] + if(current_percent > overall_percent){ + standard_list[["standard"]] <- standard + standard_list[["standard_percent"]] <- current_percent + } } # Determine the final standard + # TODO: write a general algorithm to do this ... - if(standard_list[["details"]][["sdtm"]][["match"]] == "Full"){ - standard_list[["standard"]]<- "sdtm" - } else if(standard_list[["details"]][["adam"]][["match"]] == "Full"){ - standard_list[["standard"]]<- "adam" - } else if(standard_list[["details"]][["sdtm"]][["match"]] == "Partial" | - standard_list[["details"]][["adam"]][["match"]] == "Partial"){ - standard_list[["standard"]] <- ifelse( - length(standard_list[["details"]][["adam"]][["valid_count"]]) > - length(standard_list[["details"]][["sdtm"]][["valid_count"]]), - "adam" , "sdtm" #SDTM if they are equal - ) - - } else { - standard_list[["standard"]]<-"None" - } + # if(standard_list[["details"]][["sdtm"]][["match"]] == "Full"){ + # standard_list[["standard"]]<- "sdtm" + # } else if(standard_list[["details"]][["adam"]][["match"]] == "Full"){ + # standard_list[["standard"]]<- "adam" + # } else if(standard_list[["details"]][["sdtm"]][["match"]] == "Partial" | + # standard_list[["details"]][["adam"]][["match"]] == "Partial"){ + # standard_list[["standard"]] <- ifelse( + # length(standard_list[["details"]][["adam"]][["valid_count"]]) > + # length(standard_list[["details"]][["sdtm"]][["valid_count"]]), + # "adam" , "sdtm" #SDTM if they are equal + # ) + # + # } else { + # standard_list[["standard"]]<-"None" + # } return(standard_list) } diff --git a/R/evaluateStandard.R b/R/evaluateStandard.R index 6bf954de..fc778cf8 100644 --- a/R/evaluateStandard.R +++ b/R/evaluateStandard.R @@ -42,7 +42,8 @@ evaluateStandard <- function(data, standard, includeFields=TRUE, domain="labs"){ mutate(type = ifelse(.data$column_mapping, "column", "field")) %>% rowwise %>% mutate(field_column_name = ifelse(.data$field_mapping, getSettingsMetadata(cols=standard, text_keys=.data$field_column_key),"")) %>% - mutate(valid = ifelse(.data$column_mapping, + mutate( + valid = ifelse(.data$column_mapping, hasColumn(data=data, columnName=.data$standard_val), hasField(data=data, columnName=.data$field_column_name, fieldValue=.data$standard_val) )) %>% @@ -53,20 +54,20 @@ evaluateStandard <- function(data, standard, includeFields=TRUE, domain="labs"){ standardChecks <- standardChecks %>% filter(.data$type != "field") } - # compare_summary[["checks"]] <- split(standardChecks, seq(nrow(standardChecks)))%>%map(~as.list(.)) #coerce to list of lists? - compare_summary[["checks"]] <- standardChecks #or just keep the tibble ... + compare_summary[["checks"]] <- standardChecks # count valid/invalid data elements + compare_summary[["total_count"]] <- standardChecks %>% nrow() compare_summary[["valid_count"]] <- standardChecks %>% filter(.data$valid) %>% nrow() compare_summary[["invalid_count"]] <- standardChecks %>% filter(!.data$valid) %>% nrow() - - + compare_summary[["match_percent"]] <- compare_summary[["valid_count"]] / compare_summary[["total_count"]] + if (compare_summary[["invalid_count"]]==0) { - compare_summary[["match"]] <- "Full" + compare_summary[["match"]] <- "full" } else if(compare_summary[["valid_count"]]>0) { - compare_summary[["match"]] <- "Partial" + compare_summary[["match"]] <- "partial" } else { - compare_summary[["match"]] <- "None" + compare_summary[["match"]] <- "none" } return(compare_summary) diff --git a/data-raw/standardsMetadata.csv b/data-raw/standardsMetadata.csv index 6f0567ce..b51715e9 100644 --- a/data-raw/standardsMetadata.csv +++ b/data-raw/standardsMetadata.csv @@ -1,18 +1,18 @@ -text_key,adam,sdtm +text_key,sdtm,adam id_col,USUBJID,USUBJID -value_col,AVAL,STRESN -measure_col,PARAM,TEST -normal_col_low,A1LO,STNRLO -normal_col_high,A1HI,STNRHI -studyday_col,ADY,DY +value_col,STRESN,AVAL +measure_col,TEST,PARAM +normal_col_low,STNRLO,A1LO +normal_col_high,STNRHI,A1HI +studyday_col,DY,ADY visit_col,VISIT,VISIT visitn_col,VISITNUM,VISITNUM filters,, group_cols,, -measure_values--ALT,Alanine Aminotransferase (U/L),"Aminotransferase, alanine (ALT)" -measure_values--AST,Aspartate Aminotransferase (U/L),"Aminotransferase, aspartate (AST)" -measure_values--TB,Bilirubin (umol/L),Total Bilirubin -measure_values--ALP,Alkaline Phosphatase (U/L),Alkaline phosphatase (ALP) +measure_values--ALT,"Aminotransferase, alanine (ALT)",Alanine Aminotransferase (U/L) +measure_values--AST,"Aminotransferase, aspartate (AST)",Aspartate Aminotransferase (U/L) +measure_values--TB,Total Bilirubin,Bilirubin (umol/L) +measure_values--ALP,Alkaline phosphatase (ALP),Alkaline Phosphatase (U/L) baseline--value_col,, baseline--values,, analysisFlag--value_col,, diff --git a/data/standardsMetadata.rda b/data/standardsMetadata.rda index 3a5f3ecb83829670b99119275f241ee6a35a9dc3..4aaca682f6f4f6172187518a484082bcf6d37a7e 100644 GIT binary patch delta 623 zcmV-#0+9W_1-JzcLRx4!F+o`-Q&}`NRi=>+9yD3HI)W04WSSbDrqdxkC#Yl^4FEJ` z3{4Fh42DloN)SwndY)*M^*>5&Pf&V+>NL;*$N-UF9Dk}kA&?pX00000007Vc36(wI z7K&7$;`C8gqk3>@$(h*6(Il)Uc-Y}BwU8G>CFP8ijT|K!Zb=t1PP&{-`{P2$45Ma6 zQoD?-wN!;dMTWh0Nb*YqME=T?O|S@s0Z`a!iH$`_n`awrmyf0(0u$8%RS>3I?!4!7 z(=zD!=OI*_m#*FSdrZ*JwB?J}bJcl^wlnm;UgypJ_cv2EDw+|KBLO6T7V9952aws? zi418Hxak-!Wn17{)yV>$L{*5r=y)|G=r+uFfl8bDwmh{R*-OSbazTw-w<^NuxM zo3MBtPt=jeh440X6Ci1Sl%H_%_Mt>{Cu>AH(NxZ9Jqi=dBg4ZpdrV8A5b#Br$k$$1 zS;ajRbS`98MihY+P>K&Sj{qykiSeHlH1^W4r@5jc7~{9DPh0d~m#C^(EWlI+)Cz#Y zi6SXkSW@bNnN(A7+dtLd^I4G+ZkxygRj6&+)6n9u=}42!TG`-wDPMQ`@U(z2Ksl<6 zP_Z&O=1d#ie3}%{9gC35EH!U~!s8mykljDjTw*n=ehSS-LIxZ%0wFzwQT!H-%ej#5 zQl?iH)q9JDFFVX^C4%Wmgyv_h1H%X*9DHGrTAHAz9psB*`kh0WdB_Tfl8;VvSECTExEa;8n#j$kfWqe2AzN#1C;O>D!EGtGYrPZ%)65dcurl!5V7%4ar2D3`{K8Iuc(8IcR9 zu6kv&sq^pCOWn2KNzFob1#5XUYot3@A(mKlIbi^}$1)Qesrr+cjcVV5vsI9ZhV;OYQ*@F; zRikokWINTdmCJ0s%Y`pI3~rObb)^E7G-g2Y#wbf4C}bBt8`BMPjFPQ=r?+p>51KgR P|Ha&qP81|1!f(p};sqOO diff --git a/man/getSettingsMetadata.Rd b/man/getSettingsMetadata.Rd index 78809723..ac090a96 100644 --- a/man/getSettingsMetadata.Rd +++ b/man/getSettingsMetadata.Rd @@ -5,7 +5,8 @@ \title{Get metadata about chart settings} \usage{ getSettingsMetadata(charts = NULL, text_keys = NULL, cols = NULL, - filter_expr = NULL, metadata = safetyGraphics::settingsMetadata) + filter_expr = NULL, add_standards = TRUE, + metadata = safetyGraphics::settingsMetadata) } \arguments{ \item{charts}{optional vector of chart names used to filter the metadata. Exact matches only (case-insensitive). All rows returned by default.} @@ -16,6 +17,8 @@ getSettingsMetadata(charts = NULL, text_keys = NULL, cols = NULL, \item{filter_expr}{optional filter expression used to subset the data.} +\item{add_standards}{should data standard info stored in standardsMetadata be included} + \item{metadata}{metadata data frame to be queried} } \value{ diff --git a/tests/testthat/test_detectStandard.R b/tests/testthat/test_detectStandard.R index dfd75bae..931500b4 100644 --- a/tests/testthat/test_detectStandard.R +++ b/tests/testthat/test_detectStandard.R @@ -5,53 +5,54 @@ test_that("a list with the expected properties and structure is returned",{ a<- detectStandard(data.frame()) expect_is(a,"list") - expect_named(a,c("details","standard")) + expect_named(a,c("details","standard","standard_percent")) expect_is(a[["standard"]],"character") - expect_match(a[["standard"]],"sdtm|adam|None") + expect_match(a[["standard"]],"sdtm|adam|none") expect_is(a[["details"]],"list") - expect_named(a[["details"]],c("adam","sdtm")) + expect_named(a[["details"]],c("sdtm","adam")) + expect_equal(a[["standard_percent"]],0) }) test_that("correct standards are identified",{ expect_equal(detectStandard(adlbc)[["standard"]],"adam") - expect_equal(detectStandard(adlbc)[["details"]][["adam"]][["match"]], "Full") - expect_equal(detectStandard(adlbc)[["details"]][["sdtm"]][["match"]], "Partial") + expect_equal(detectStandard(adlbc)[["details"]][["adam"]][["match"]], "full") + expect_equal(detectStandard(adlbc)[["details"]][["sdtm"]][["match"]], "partial") adam_params <- c("Alanine Aminotransferase (U/L)","Aspartate Aminotransferase (U/L)","Bilirubin (umol/L)","Alkaline Phosphatase (U/L)") adam_test_data<-data.frame(USUBJID="001",AVAL=10,PARAM=adam_params, VISIT="Visit 1",VISITNUM=1,ADY=0,A1LO=0,A1HI=20) expect_equal(detectStandard(adam_test_data)[["standard"]],"adam") - expect_equal(detectStandard(adam_test_data)[["details"]][["adam"]][["match"]], "Full") - expect_equal(detectStandard(adam_test_data)[["details"]][["sdtm"]][["match"]], "Partial") + expect_equal(detectStandard(adam_test_data)[["details"]][["adam"]][["match"]], "full") + expect_equal(detectStandard(adam_test_data)[["details"]][["sdtm"]][["match"]], "partial") sdtm_params<-c("Aminotransferase, alanine (ALT)","Aminotransferase, aspartate (AST)","Total Bilirubin","Alkaline phosphatase (ALP)") sdtm_test_data<-data.frame(USUBJID="001",STRESN=10,TEST=sdtm_params,VISIT="Visit 1",VISITNUM=1,DY=0,STNRLO=0,STNRHI=20) expect_equal(detectStandard(sdtm_test_data)[["standard"]],"sdtm") - expect_equal(detectStandard(sdtm_test_data)[["details"]][["adam"]][["match"]], "Partial") - expect_equal(detectStandard(sdtm_test_data)[["details"]][["sdtm"]][["match"]], "Full") + expect_equal(detectStandard(sdtm_test_data)[["details"]][["adam"]][["match"]], "partial") + expect_equal(detectStandard(sdtm_test_data)[["details"]][["sdtm"]][["match"]], "full") empty_test_data<-data.frame("") - expect_equal(detectStandard(empty_test_data)[["standard"]],"None") - expect_equal(detectStandard(empty_test_data)[["details"]][["adam"]][["match"]], "None") - expect_equal(detectStandard(empty_test_data)[["details"]][["sdtm"]][["match"]], "None") + expect_equal(detectStandard(empty_test_data)[["standard"]],"none") + expect_equal(detectStandard(empty_test_data)[["details"]][["adam"]][["match"]], "none") + expect_equal(detectStandard(empty_test_data)[["details"]][["sdtm"]][["match"]], "none") case_sensitive_test_data<-data.frame(usubjid="001",AVAL=10,PARAM=adam_params, VISIT="Visit 1",VISITNUM=1,ADY=0,A1LO=0,A1HI=20) expect_equal(detectStandard(case_sensitive_test_data)[["standard"]],"adam") - expect_equal(detectStandard(case_sensitive_test_data)[["details"]][["adam"]][["match"]], "Full") - expect_equal(detectStandard(case_sensitive_test_data)[["details"]][["sdtm"]][["match"]], "Partial") + expect_equal(detectStandard(case_sensitive_test_data)[["details"]][["adam"]][["match"]], "full") + expect_equal(detectStandard(case_sensitive_test_data)[["details"]][["sdtm"]][["match"]], "partial") #NOTE: sdtm takes precedence over adam sdtm_and_adam_test_data<-cbind(adam_test_data,sdtm_test_data) expect_equal(detectStandard(sdtm_and_adam_test_data)[["standard"]],"sdtm") - expect_equal(detectStandard(sdtm_and_adam_test_data)[["details"]][["adam"]][["match"]], "Full") - expect_equal(detectStandard(sdtm_and_adam_test_data)[["details"]][["sdtm"]][["match"]], "Full") + expect_equal(detectStandard(sdtm_and_adam_test_data)[["details"]][["adam"]][["match"]], "full") + expect_equal(detectStandard(sdtm_and_adam_test_data)[["details"]][["sdtm"]][["match"]], "full") #NOTE: sdtm takes precedence over adam in partial matches as well sdtm_and_adam_partial_test_data<-data.frame(USUBJID="001",VISIT="Visit 1") expect_equal(detectStandard(sdtm_and_adam_partial_test_data)[["standard"]],"sdtm") - expect_equal(detectStandard(sdtm_and_adam_partial_test_data)[["details"]][["adam"]][["match"]],"Partial") - expect_equal(detectStandard(sdtm_and_adam_partial_test_data)[["details"]][["sdtm"]][["match"]],"Partial") + expect_equal(detectStandard(sdtm_and_adam_partial_test_data)[["details"]][["adam"]][["match"]],"partial") + expect_equal(detectStandard(sdtm_and_adam_partial_test_data)[["details"]][["sdtm"]][["match"]],"partial") }) diff --git a/tests/testthat/test_evaluateStandard.R b/tests/testthat/test_evaluateStandard.R index 72dd5ec8..09f337a1 100644 --- a/tests/testthat/test_evaluateStandard.R +++ b/tests/testthat/test_evaluateStandard.R @@ -2,16 +2,16 @@ context("Tests for the evaluateStandard() function") library(safetyGraphics) test_that("basic test cases evaluate as expected",{ - expect_equal(evaluateStandard(data=adlbc, standard="adam")[["match"]],"Full") - expect_equal(evaluateStandard(data=adlbc, standard="sdtm")[["match"]],"Partial") - expect_equal(evaluateStandard(data=data.frame(), standard="sdtm")[["match"]],"None") + expect_equal(evaluateStandard(data=adlbc, standard="adam")[["match"]],"full") + expect_equal(evaluateStandard(data=adlbc, standard="sdtm")[["match"]],"partial") + expect_equal(evaluateStandard(data=data.frame(), standard="sdtm")[["match"]],"none") }) test_that("a list with the expected properties and structure is returned",{ a<- evaluateStandard(data=data.frame(),standard="adam") expect_is(a,"list") - expect_named(a,c('standard', 'checks', 'valid_count', 'invalid_count', 'match')) + expect_named(a,c('standard', 'checks', 'total_count','valid_count', 'invalid_count','match_percent', 'match')) expect_is(a[["standard"]],"character") expect_is(a[["match"]],"character") expect_is(a[["checks"]],"tbl") @@ -34,7 +34,7 @@ test_that("expected number of checks (in)valid",{ test_that("field level data is ignored when useFields=false",{ noFields<-evaluateStandard(data=adlbc, standard="adam", includeFields=FALSE) - expect_equal(noFields[["match"]],"Full") + expect_equal(noFields[["match"]],"full") expect_equal(noFields[["valid_count"]],6) }) From bfa4aecbb986cbbdaf0ffd953a2dce6f18d08ee5 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Fri, 22 Feb 2019 08:43:15 -0800 Subject: [PATCH 16/40] a few more tests. change standard order. --- R/standardsMetadata.R | 12 ++++++++++++ man/standardsMetadata.Rd | 21 +++++++++++++++++++++ tests/testthat/test_evaluateStandard.R | 3 +++ 3 files changed, 36 insertions(+) create mode 100644 R/standardsMetadata.R create mode 100644 man/standardsMetadata.Rd diff --git a/R/standardsMetadata.R b/R/standardsMetadata.R new file mode 100644 index 00000000..b7ad331a --- /dev/null +++ b/R/standardsMetadata.R @@ -0,0 +1,12 @@ +#' Standards Metadata +#' +#' Metadata about the data standards used to configure safetyGraphics charts. SpecificOne record per unique setting +#' +#' @format A data frame with 25 rows and 10 columns +#' \describe{ +#' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} +#' \item{--standard names--}{additional columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards.} +#' } +#' +#' @source Created for this package +"standardsMetadata" \ No newline at end of file diff --git a/man/standardsMetadata.Rd b/man/standardsMetadata.Rd new file mode 100644 index 00000000..63a6f2ea --- /dev/null +++ b/man/standardsMetadata.Rd @@ -0,0 +1,21 @@ +% Generated by roxygen2: do not edit by hand +% Please edit documentation in R/standardsMetadata.R +\docType{data} +\name{standardsMetadata} +\alias{standardsMetadata} +\title{Standards Metadata} +\format{A data frame with 25 rows and 10 columns +\describe{ + \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} + \item{--standard names--}{additional columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards.} +}} +\source{ +Created for this package +} +\usage{ +standardsMetadata +} +\description{ +Metadata about the data standards used to configure safetyGraphics charts. SpecificOne record per unique setting +} +\keyword{datasets} diff --git a/tests/testthat/test_evaluateStandard.R b/tests/testthat/test_evaluateStandard.R index 09f337a1..352fe5e6 100644 --- a/tests/testthat/test_evaluateStandard.R +++ b/tests/testthat/test_evaluateStandard.R @@ -28,6 +28,8 @@ test_that("expected number of checks (in)valid",{ a<-evaluateStandard(data=adlbc_edit, standard="sdtm") expect_equal(a[["valid_count"]],2) expect_equal(a[["invalid_count"]],8) + expect_equal(a[["total_count"]],10) + expect_equal(a[["match_percent"]],.2) expect_true(a[["checks"]]%>%filter(text_key=="measure_col")%>%select(valid)%>%unlist) }) @@ -35,6 +37,7 @@ test_that("expected number of checks (in)valid",{ test_that("field level data is ignored when useFields=false",{ noFields<-evaluateStandard(data=adlbc, standard="adam", includeFields=FALSE) expect_equal(noFields[["match"]],"full") + expect_equal(noFields[["match_percent"]],1) expect_equal(noFields[["valid_count"]],6) }) From da434877dd9357fd13508150508f7f29b5b25099 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Fri, 22 Feb 2019 08:57:10 -0800 Subject: [PATCH 17/40] update docs --- R/detectStandard.R | 8 ++++---- R/evaluateStandard.R | 2 +- man/detectStandard.Rd | 8 ++++---- man/evaluateStandard.Rd | 2 +- 4 files changed, 10 insertions(+), 10 deletions(-) diff --git a/R/detectStandard.R b/R/detectStandard.R index 357cfd77..1370f7cb 100644 --- a/R/detectStandard.R +++ b/R/detectStandard.R @@ -1,16 +1,16 @@ #' Detect the data standard used for a data set #' -#' This function attempts to detect the data CDISC clinical standard used in a given R data frame. +#' This function attempts to detect the clinical data standard used in a given R data frame. #' -#' This function compares the columns in the provided \code{"data"} with the required columns for a given data standard/domain combination. The function is designed to work with the SDTM and AdAM CDISC() standards for clinical trial data. Currently, "labs" is the only domain supported. +#' This function compares the columns in the provided \code{"data"} with the required columns for a given data standard/domain combination. The function is designed to work with the SDTM and AdAM CDISC() standards for clinical trial data by default. Additional standards can be added by modifying the \code{"standardMetadata"} data set included as part of this package. Currently, "labs" is the only domain supported. #' #' @param data A data frame in which to detect the data standard #' @param includeFields specifies whether to check the data set for field level data in addition to columns. Default: \code{TRUE}. #' @param domain The data domain for the data set provided. Default: \code{"labs"}. -#' @return A list containing the matching \code{"standard"} ("ADaM", "SDTM" or "None") and a list of \code{"details"} describing each standard considered. +#' @return A list containing the matching \code{"standard"} from \code{"standardMetadata"} and a list of \code{"details"} describing each standard considered. #' @examples -#' detectStandard(adlbc)[["standard"]] #AdAM +#' detectStandard(adlbc)[["standard"]] #adam #' detectStandard(iris)[["standard"]] #none #' #' \dontrun{ diff --git a/R/evaluateStandard.R b/R/evaluateStandard.R index fc778cf8..ffe13068 100644 --- a/R/evaluateStandard.R +++ b/R/evaluateStandard.R @@ -7,7 +7,7 @@ #' @param includeFields should field level data be evaluated? #' @param domain data domain. "labs" only for now. #' -#' @return a list describing to what degree the data set matches the data standard. The "match" property describes compliance with the standard as "Full", "Partial" or "None". The "checks" property is a list of the data elements expected for the standard and whether they are "valid" in the given data set. "valid_checks" and "invalid_checks" provide counts of the specified checks. +#' @return a list describing to what degree the data set matches the data standard. The "match" property describes compliance with the standard as "full", "partial" or "none". The "checks" property is a list of the data elements expected for the standard and whether they are "valid" in the given data set. "total_checks", "valid_checks" and "invalid_checks" provide counts of the specified checks. "match_percent" is calculated as valid_checks/total_checks. #' #' @examples #' safetyGraphics:::evaluateStandard(data=adlbc, standard="adam") # Match is TRUE diff --git a/man/detectStandard.Rd b/man/detectStandard.Rd index 8536045e..ec561f35 100644 --- a/man/detectStandard.Rd +++ b/man/detectStandard.Rd @@ -14,16 +14,16 @@ detectStandard(data, includeFields = TRUE, domain = "labs") \item{domain}{The data domain for the data set provided. Default: \code{"labs"}.} } \value{ -A list containing the matching \code{"standard"} ("ADaM", "SDTM" or "None") and a list of \code{"details"} describing each standard considered. +A list containing the matching \code{"standard"} from \code{"standardMetadata"} and a list of \code{"details"} describing each standard considered. } \description{ -This function attempts to detect the data CDISC clinical standard used in a given R data frame. +This function attempts to detect the clinical data standard used in a given R data frame. } \details{ -This function compares the columns in the provided \code{"data"} with the required columns for a given data standard/domain combination. The function is designed to work with the SDTM and AdAM CDISC() standards for clinical trial data. Currently, "labs" is the only domain supported. +This function compares the columns in the provided \code{"data"} with the required columns for a given data standard/domain combination. The function is designed to work with the SDTM and AdAM CDISC() standards for clinical trial data by default. Additional standards can be added by modifying the \code{"standardMetadata"} data set included as part of this package. Currently, "labs" is the only domain supported. } \examples{ -detectStandard(adlbc)[["standard"]] #AdAM +detectStandard(adlbc)[["standard"]] #adam detectStandard(iris)[["standard"]] #none \dontrun{ diff --git a/man/evaluateStandard.Rd b/man/evaluateStandard.Rd index ac1a38ab..ecbcde34 100644 --- a/man/evaluateStandard.Rd +++ b/man/evaluateStandard.Rd @@ -16,7 +16,7 @@ evaluateStandard(data, standard, includeFields = TRUE, domain = "labs") \item{domain}{data domain. "labs" only for now.} } \value{ -a list describing to what degree the data set matches the data standard. The "match" property describes compliance with the standard as "Full", "Partial" or "None". The "checks" property is a list of the data elements expected for the standard and whether they are "valid" in the given data set. "valid_checks" and "invalid_checks" provide counts of the specified checks. +a list describing to what degree the data set matches the data standard. The "match" property describes compliance with the standard as "full", "partial" or "none". The "checks" property is a list of the data elements expected for the standard and whether they are "valid" in the given data set. "total_checks", "valid_checks" and "invalid_checks" provide counts of the specified checks. "match_percent" is calculated as valid_checks/total_checks. } \description{ Determines whether the required data elements in a data standard are found in a given data frame From 0e40f460bbbd36448a1ab616156c6e2ae101c02e Mon Sep 17 00:00:00 2001 From: jwildfire Date: Fri, 22 Feb 2019 09:06:12 -0800 Subject: [PATCH 18/40] clear checks --- R/detectStandard.R | 2 +- R/getSettingsMetadata.R | 4 ++-- R/settingsMetadata.R | 2 -- R/standardsMetadata.R | 7 ++++--- man/settingsMetadata.Rd | 2 -- man/standardsMetadata.Rd | 7 ++++--- 6 files changed, 11 insertions(+), 13 deletions(-) diff --git a/R/detectStandard.R b/R/detectStandard.R index 1370f7cb..da4a806c 100644 --- a/R/detectStandard.R +++ b/R/detectStandard.R @@ -27,7 +27,7 @@ detectStandard <- function(data, includeFields=TRUE, domain="labs"){ # Create placeholder list, with Standard = none. - available_standards <- standardsMetadata %>% select(-text_key) %>% names + available_standards <- safetyGraphics::standardsMetadata %>% select(-.data$text_key) %>% names standard_list <- list() standard_list[["details"]] = list() standard_list[["standard"]] = "none" diff --git a/R/getSettingsMetadata.R b/R/getSettingsMetadata.R index fed8578b..7ae8aec8 100644 --- a/R/getSettingsMetadata.R +++ b/R/getSettingsMetadata.R @@ -30,10 +30,10 @@ getSettingsMetadata<-function(charts=NULL, text_keys=NULL, cols=NULL, filter_expr=NULL, add_standards=TRUE, metadata = safetyGraphics::settingsMetadata){ - md <- metadata %>% mutate(text_key=as.character(text_key)) + md <- metadata %>% mutate(text_key=as.character(.data$text_key)) if(add_standards){ - ms<-standardsMetadata %>% mutate(text_key=as.character(text_key)) + ms<-safetyGraphics::standardsMetadata %>% mutate(text_key=as.character(.data$text_key)) md<-md%>%left_join(ms, by="text_key") } diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R index d74a076a..e1f9f500 100644 --- a/R/settingsMetadata.R +++ b/R/settingsMetadata.R @@ -14,8 +14,6 @@ #' \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} #' \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} #' \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} -#' \item{adam}{Settings values for the ADaM standard} -#' \item{sdtm}{Settings values for the SDTM standard} #' } #' #' @source Created for this package diff --git a/R/standardsMetadata.R b/R/standardsMetadata.R index b7ad331a..c1ffaac0 100644 --- a/R/standardsMetadata.R +++ b/R/standardsMetadata.R @@ -1,11 +1,12 @@ #' Standards Metadata #' -#' Metadata about the data standards used to configure safetyGraphics charts. SpecificOne record per unique setting +#' Metadata about the data standards used to configure safetyGraphics charts. One record per unique setting. Columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards. #' -#' @format A data frame with 25 rows and 10 columns +#' @format A data frame with 25 rows and 3 columns #' \describe{ #' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} -#' \item{--standard names--}{additional columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards.} +#' \item{adam}{Settings values for the ADaM standard} +#' \item{sdtm}{Settings values for the SDTM standard} #' } #' #' @source Created for this package diff --git a/man/settingsMetadata.Rd b/man/settingsMetadata.Rd index fa44dcd2..fb685da8 100644 --- a/man/settingsMetadata.Rd +++ b/man/settingsMetadata.Rd @@ -16,8 +16,6 @@ \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} - \item{adam}{Settings values for the ADaM standard} - \item{sdtm}{Settings values for the SDTM standard} }} \source{ Created for this package diff --git a/man/standardsMetadata.Rd b/man/standardsMetadata.Rd index 63a6f2ea..601a48c0 100644 --- a/man/standardsMetadata.Rd +++ b/man/standardsMetadata.Rd @@ -4,10 +4,11 @@ \name{standardsMetadata} \alias{standardsMetadata} \title{Standards Metadata} -\format{A data frame with 25 rows and 10 columns +\format{A data frame with 25 rows and 3 columns \describe{ \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} - \item{--standard names--}{additional columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards.} + \item{adam}{Settings values for the ADaM standard} + \item{sdtm}{Settings values for the SDTM standard} }} \source{ Created for this package @@ -16,6 +17,6 @@ Created for this package standardsMetadata } \description{ -Metadata about the data standards used to configure safetyGraphics charts. SpecificOne record per unique setting +Metadata about the data standards used to configure safetyGraphics charts. One record per unique setting. Columns contain default setting values for clinical data standards, like the CDISC "adam" and "sdtm" standards. } \keyword{datasets} From 1a54ee8e3484e2d0d30942013d16bef32f6d837e Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 22 Feb 2019 13:05:58 -0500 Subject: [PATCH 19/40] update comment for field-level stuff --- inst/eDISH_app/modules/renderSettings/renderSettings.R | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 175c0967..e1a33339 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -38,12 +38,12 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### - # Update field level inputs + # Update field level inputs + # + # update field-level inputs if a column level setting changes + # dependent on change in data, chart selection, or column-level input ###################################################################### - - # update field-level inputs if a column level setting changes - # dependent on change in data, chart selection, or column-level input observe({ column_keys <- getSettingsMetadata(charts=input$select_charts, From 700bc3516a108a379ae56777cc47633b63d5189e Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 22 Feb 2019 14:19:22 -0500 Subject: [PATCH 20/40] change input name --- .../modules/renderSettings/renderSettings.R | 17 +++++++---------- .../modules/renderSettings/renderSettingsUI.R | 2 +- .../renderSettings/util/createSettingsUI.R | 6 +----- 3 files changed, 9 insertions(+), 16 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 5748cb6d..1e970e0c 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -19,19 +19,19 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### output$data_mapping_ui <- renderUI({ - req(input$select_charts) + req(input$charts) tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "data", charts=input$charts, ns=ns)) }) outputOptions(output, "data_mapping_ui", suspendWhenHidden = FALSE) output$measure_settings_ui <- renderUI({ - req(input$select_charts) + req(input$charts) tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "measure", charts=input$charts, ns=ns)) }) outputOptions(output, "measure_settings_ui", suspendWhenHidden = FALSE) output$appearance_settings_ui <- renderUI({ - req(input$select_charts) + req(input$charts) tagList(createSettingsUI(data=data(), settings = settings(), setting_cat_val = "appearance", charts=input$charts, ns=ns)) }) outputOptions(output, "appearance_settings_ui", suspendWhenHidden = FALSE) @@ -46,7 +46,7 @@ renderSettings <- function(input, output, session, data, settings, status){ observe({ - column_keys <- getSettingsMetadata(charts=input$select_charts, + column_keys <- getSettingsMetadata(charts=input$charts, filter_expr = field_mapping==TRUE) %>% pull(field_column_key) %>% unique %>% @@ -57,7 +57,7 @@ renderSettings <- function(input, output, session, data, settings, status){ col_quo <- enquo(col) observeEvent(input[[col]],{ - field_keys <- getSettingsMetadata(charts=input$select_charts, col = "text_key", + field_keys <- getSettingsMetadata(charts=input$charts, col = "text_key", filter_expr = field_column_key==!!col) @@ -205,10 +205,6 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### # print validation messages - # - # Right now we are re-printing ALL status messages upon validation update. - # if we make a module, we have the option of printing ONLY the - # message for input that changed. ###################################################################### observe({ for (name in isolate(input_names())){ @@ -225,7 +221,8 @@ renderSettings <- function(input, output, session, data, settings, status){ }) ### return updated settings and status to global env. - return(list(settings = reactive(settings_new()), + return(list(charts = reactive(input$charts), + settings = reactive(settings_new()), status = reactive(status_new()))) } diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 1856685f..df8f910d 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -10,7 +10,7 @@ renderSettingsUI <- function(id){ wellPanel( div( span(h2(tags$strong("Select Chart(s):"))), - checkboxGroupInput(ns("select_charts"),"", + checkboxGroupInput(ns("charts"),"", choices = c("e-DISH" = "edish"), selected="edish")) ) diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R index 83b87f15..311258b5 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R @@ -10,10 +10,6 @@ createLabel <- function(key){ } } -createDescription <- function(key){ - getSettingsMetadata(text_keys=key, cols="description") -} - createControl <- function(key, metadata, data, settings, ns){ sm_key <- filter(metadata, text_key==key) @@ -23,7 +19,7 @@ createControl <- function(key, metadata, data, settings, ns){ setting_key <- as.list(strsplit(key,"\\-\\-")) setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) setting_label <- createLabel(key) - setting_description <- createDescription(key) + setting_description <- getSettingsMetadata(text_keys=key, cols="description") field_column <- NULL field_column_label <- NULL From ed4433452e6f1fabb126ed730047a461f48dc052 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 22 Feb 2019 14:29:26 -0500 Subject: [PATCH 21/40] separate functions into files --- .../modules/renderSettings/renderSettings.R | 4 +- .../renderSettings/util/createControl.R | 82 ++++++++++++++++ .../renderSettings/util/createSettingLabel.R | 11 +++ .../renderSettings/util/createSettingsUI.R | 95 ------------------- 4 files changed, 95 insertions(+), 97 deletions(-) create mode 100644 inst/eDISH_app/modules/renderSettings/util/createControl.R create mode 100644 inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 1e970e0c..999ee1a3 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -1,6 +1,6 @@ +source("modules/renderSettings/util/createSettingLabel.R") +source("modules/renderSettings/util/createControl.R") source("modules/renderSettings/util/createSettingsUI.R") -# source("modules/renderSettings/util/labelSetting.R") -# source("modules/renderSettings/util/flagSetting.R") source("modules/renderSettings/util/updateSettingStatus.R") renderSettings <- function(input, output, session, data, settings, status){ diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R new file mode 100644 index 00000000..8a4aa573 --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -0,0 +1,82 @@ +createControl <- function(key, metadata, data, settings, ns){ + sm_key <- filter(metadata, text_key==key) + + tt_msg <- paste0("tt_msg_", key) + msg <- paste0("msg_", key) + + setting_key <- as.list(strsplit(key,"\\-\\-")) + setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) + setting_label <- createSettingLabel(key) + setting_description <- getSettingsMetadata(text_keys=key, cols="description") + + field_column <- NULL + field_column_label <- NULL + if (!is.null(sm_key$field_column_key)){ + field_column <- safetyGraphics:::getSettingValue(key=list(sm_key$field_column_key), settings=settings) + field_column_label <- getSettingsMetadata(text_key = sm_key$field_column_key, cols = "label") + } + + + # get the choices for the option + value <- NULL + choices <- NULL + placeholder <- NULL + if(sm_key$column_mapping==TRUE){ + if(is.null(setting_value)){ + choices <- colnames(data) + placeholder <- list( + onInitialize = I('function() { + this.setValue("");}')) + } else{ + choices <- unique(c(setting_value, colnames(data))) + placeholder <- list (onInitialize = I('function() { }')) + } + } else if (sm_key$field_mapping==TRUE){ + if(is.null(field_column)){ ## if there is NOT a column specified in settings + placeholder <- list( + placeholder = paste0("Please select a ", field_column_label), + onInitialize = I('function() { + this.setValue("");}')) + } else{ ## if there is a column specified in settings + choices <- unique(c(setting_value, as.character(data[,field_column]))) %>% unlist + placeholder <- list (onInitialize = I('function() { }')) + } + } else if (sm_key$setting_type=="vector"){ + choices <- setting_value ### this is meant to cover the scenario for x_options/y_options. But we have + # nowhere to grab "choices" from. Here we are just saying that choices=selected=setting_value + } + + if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ + + multiple <- (sm_key$setting_type=="vector") + + div( + span(title = setting_description, tags$label(HTML(setting_label))), + span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), + selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) + ) + } else if (sm_key$setting_type=="vector"){ + + div( + span(title = setting_description, tags$label(HTML(setting_label))), + span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), + selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) + ) + + } else if (sm_key$setting_type=="numeric"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) + ) + } else if (sm_key$setting_type=="logical"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + checkboxInput(inputId = ns(key), label = NULL, value=setting_value) + ) + } else if (sm_key$setting_type=="character"){ + div( + div(title = setting_description, tags$label(HTML(setting_label))), + textAreaInput(inputId = ns(key), label = NULL, value = setting_value) + ) + } +} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R new file mode 100644 index 00000000..b127f9ec --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R @@ -0,0 +1,11 @@ +createSettingLabel <- function(key){ + sm <- getSettingsMetadata(text_keys=key) + setting_label <- sm$label + required <- sm$setting_required + + if (required){ + paste0(" ", setting_label, "*") + } else { + paste0(" ", setting_label) + } +} diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R index 311258b5..8a7e955e 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R @@ -1,98 +1,3 @@ -createLabel <- function(key){ - sm <- getSettingsMetadata(text_keys=key) - setting_label <- sm$label - required <- sm$setting_required - - if (required){ - paste0(" ", setting_label, "*") - } else { - paste0(" ", setting_label) - } -} - -createControl <- function(key, metadata, data, settings, ns){ - sm_key <- filter(metadata, text_key==key) - - tt_msg <- paste0("tt_msg_", key) - msg <- paste0("msg_", key) - - setting_key <- as.list(strsplit(key,"\\-\\-")) - setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) - setting_label <- createLabel(key) - setting_description <- getSettingsMetadata(text_keys=key, cols="description") - - field_column <- NULL - field_column_label <- NULL - if (!is.null(sm_key$field_column_key)){ - field_column <- safetyGraphics:::getSettingValue(key=list(sm_key$field_column_key), settings=settings) - field_column_label <- getSettingsMetadata(text_key = sm_key$field_column_key, cols = "label") - } - - - # get the choices for the option - value <- NULL - choices <- NULL - placeholder <- NULL - if(sm_key$column_mapping==TRUE){ - if(is.null(setting_value)){ - choices <- colnames(data) - placeholder <- list( - onInitialize = I('function() { - this.setValue("");}')) - } else{ - choices <- unique(c(setting_value, colnames(data))) - placeholder <- list (onInitialize = I('function() { }')) - } - } else if (sm_key$field_mapping==TRUE){ - if(is.null(field_column)){ ## if there is NOT a column specified in settings - placeholder <- list( - placeholder = paste0("Please select a ", field_column_label), - onInitialize = I('function() { - this.setValue("");}')) - } else{ ## if there is a column specified in settings - choices <- unique(c(setting_value, as.character(data[,field_column]))) %>% unlist - placeholder <- list (onInitialize = I('function() { }')) - } - } else if (sm_key$setting_type=="vector"){ - choices <- setting_value ### this is meant to cover the scenario for x_options/y_options. But we have - # nowhere to grab "choices" from. Here we are just saying that choices=selected=setting_value - } - - if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ - - multiple <- (sm_key$setting_type=="vector") - - div( - span(title = setting_description, tags$label(HTML(setting_label))), - span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), - selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) - ) - } else if (sm_key$setting_type=="vector"){ - - div( - span(title = setting_description, tags$label(HTML(setting_label))), - span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), - selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) - ) - - } else if (sm_key$setting_type=="numeric"){ - div( - div(title = setting_description, tags$label(HTML(setting_label))), - sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) - ) - } else if (sm_key$setting_type=="logical"){ - div( - div(title = setting_description, tags$label(HTML(setting_label))), - checkboxInput(inputId = ns(key), label = NULL, value=setting_value) - ) - } else if (sm_key$setting_type=="character"){ - div( - div(title = setting_description, tags$label(HTML(setting_label))), - textAreaInput(inputId = ns(key), label = NULL, value = setting_value) - ) - } -} - createSettingsUI <- function(data, settings, setting_cat_val, charts, ns){ sm <- getSettingsMetadata(charts=charts) %>% From cb6b41f7c8fda7b996f2c7c6c1bbcf6ab610c0b3 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 22 Feb 2019 14:40:16 -0500 Subject: [PATCH 22/40] add comments --- .../eDISH_app/modules/renderSettings/util/createControl.R | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index 8a4aa573..88108e44 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -1,14 +1,17 @@ createControl <- function(key, metadata, data, settings, ns){ + sm_key <- filter(metadata, text_key==key) tt_msg <- paste0("tt_msg_", key) msg <- paste0("msg_", key) + ### get metadata for the input setting_key <- as.list(strsplit(key,"\\-\\-")) setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) setting_label <- createSettingLabel(key) setting_description <- getSettingsMetadata(text_keys=key, cols="description") + ### if a field-level input, get metadata about the parent column-level input field_column <- NULL field_column_label <- NULL if (!is.null(sm_key$field_column_key)){ @@ -17,7 +20,7 @@ createControl <- function(key, metadata, data, settings, ns){ } - # get the choices for the option + ### get the choices for the selectors value <- NULL choices <- NULL placeholder <- NULL @@ -46,6 +49,9 @@ createControl <- function(key, metadata, data, settings, ns){ # nowhere to grab "choices" from. Here we are just saying that choices=selected=setting_value } + + + ### create code for the UI if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ multiple <- (sm_key$setting_type=="vector") From 0ac3beef723bd01f6d6a9cbf0e5c5304410acf0e Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Mon, 25 Feb 2019 11:30:17 -0500 Subject: [PATCH 23/40] clarify comment --- inst/eDISH_app/modules/renderSettings/util/createControl.R | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index 88108e44..b1af014d 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -45,8 +45,7 @@ createControl <- function(key, metadata, data, settings, ns){ placeholder <- list (onInitialize = I('function() { }')) } } else if (sm_key$setting_type=="vector"){ - choices <- setting_value ### this is meant to cover the scenario for x_options/y_options. But we have - # nowhere to grab "choices" from. Here we are just saying that choices=selected=setting_value + choices <- setting_value ### this is meant to cover the scenario for x_options/y_options } From bceb364bd7c0d58c42ee4fbc29350497b0a178c5 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Mon, 25 Feb 2019 11:34:39 -0500 Subject: [PATCH 24/40] removing some old comments.. --- inst/eDISH_app/modules/renderSettings/renderSettings.R | 10 +--------- 1 file changed, 1 insertion(+), 9 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 999ee1a3..0820440c 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -90,13 +90,8 @@ renderSettings <- function(input, output, session, data, settings, status){ ###################################################################### # Fill settings object based on selections - # require that secondary inputs have been filled in before proceeding + # # update is triggered by any of the input selections changing - # - # NOTE: when data selection changes, the inputs are updating 1 by 1 - # Therefore, until the inputs are done updating based on new data, this object will be - # partially representing the old data, and partially representing the new data. - # not sure if this is the right place to do it...but can we clear out this object upon a data change and start over?? ###################################################################### settings_new <- reactive({ @@ -157,9 +152,6 @@ renderSettings <- function(input, output, session, data, settings, status){ # validate new settings # the validation is run every time there is a change in data and/or settings. # - # NOTE: to prevent status updating as loop runs and fills in settings(), - # require the very last updated input to be available <- can't do this b/c we will have lots of - # null settings to start when no standard detected... ###################################################################### status_new <- reactive({ From afd37b23191c2bd0f1f3f44702966b0ff6009660 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Mon, 25 Feb 2019 12:41:32 -0500 Subject: [PATCH 25/40] add setting_cat --- R/settingsMetadata.R | 1 + 1 file changed, 1 insertion(+) diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R index d74a076a..5e8981f6 100644 --- a/R/settingsMetadata.R +++ b/R/settingsMetadata.R @@ -8,6 +8,7 @@ #' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} #' \item{label}{Label} #' \item{description}{Description} +#' \item{setting_cat}{Setting category (data, measure, appearance)} #' \item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"} #' \item{setting_required}{Flag indicating if the setting is required} #' \item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data} From b1f5a4b50a4844285ba3c4ee53022b5c29488910 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Mon, 25 Feb 2019 12:48:17 -0500 Subject: [PATCH 26/40] add setting_cat --- man/settingsMetadata.Rd | 1 + 1 file changed, 1 insertion(+) diff --git a/man/settingsMetadata.Rd b/man/settingsMetadata.Rd index fa44dcd2..1fd4c3d7 100644 --- a/man/settingsMetadata.Rd +++ b/man/settingsMetadata.Rd @@ -10,6 +10,7 @@ \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} \item{label}{Label} \item{description}{Description} + \item{setting_cat}{Setting category (data, measure, appearance)} \item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"} \item{setting_required}{Flag indicating if the setting is required} \item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data} From 0df1f6e3bab61e8b305e9de075e7b62f25a72af5 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Mon, 25 Feb 2019 10:52:35 -0800 Subject: [PATCH 27/40] fix test --- R/settingsMetadata.R | 2 ++ man/settingsMetadata.Rd | 1 + tests/testthat/test_getRequiredSettings.R | 8 ++++---- 3 files changed, 7 insertions(+), 4 deletions(-) diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R index 61ddd66a..c1d109b5 100644 --- a/R/settingsMetadata.R +++ b/R/settingsMetadata.R @@ -15,6 +15,8 @@ #' \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} #' \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} #' \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} +#' \item{setting_cat}{Category specifying where the setting should be located in shiny} + #' } #' #' @source Created for this package diff --git a/man/settingsMetadata.Rd b/man/settingsMetadata.Rd index 47dce006..ba3ab5ab 100644 --- a/man/settingsMetadata.Rd +++ b/man/settingsMetadata.Rd @@ -17,6 +17,7 @@ \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} + \item{setting_cat}{Category specifying where the setting should be located in shiny} }} \source{ Created for this package diff --git a/tests/testthat/test_getRequiredSettings.R b/tests/testthat/test_getRequiredSettings.R index b5d8ef11..b1d463cc 100644 --- a/tests/testthat/test_getRequiredSettings.R +++ b/tests/testthat/test_getRequiredSettings.R @@ -6,13 +6,13 @@ defaultRequiredSettings <- list( list("id_col"), list("value_col"), list("measure_col"), - list("normal_col_low"), - list("normal_col_high"), - list("studyday_col"), list("measure_values","ALT"), list("measure_values","AST"), list("measure_values","TB"), - list("measure_values","ALP") + list("measure_values","ALP"), + list("normal_col_low"), + list("normal_col_high"), + list("studyday_col") ) From f6a77a1d38bc8b834ab30518ecffebb0d3b68499 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Mon, 25 Feb 2019 11:07:12 -0800 Subject: [PATCH 28/40] sync data module with standard refactor --- .../eDISH_app/modules/dataUpload/dataUpload.R | 102 +++++++++--------- .../modules/dataUpload/dataUploadUI.R | 18 ++-- 2 files changed, 60 insertions(+), 60 deletions(-) diff --git a/inst/eDISH_app/modules/dataUpload/dataUpload.R b/inst/eDISH_app/modules/dataUpload/dataUpload.R index 57f4de9c..781b1410 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUpload.R +++ b/inst/eDISH_app/modules/dataUpload/dataUpload.R @@ -1,16 +1,16 @@ dataUpload <- function(input, output, session){ - + ns <- session$ns - + # initiate reactive values - list of uploaded data files # standard to imitate output of detectStandard.R - dd <- reactiveValues(data = list("Example data" = adlbc), current = 1, standard = list(list("standard" = "ADaM", "details" = list("ADaM"=list("match"="Full"))))) - + dd <- reactiveValues(data = list("Example data" = adlbc), current = 1, standard = list(list("standard" = "adam", "details" = list("adam"=list("match"="full"))))) + # modify reactive values when data is uploaded observeEvent(input$datafile,{ - + data_list <- list() - + ## data list for (i in 1:nrow(input$datafile)){ if (length(grep(".csv", input$datafile$name[i], ignore.case = TRUE)) > 0){ @@ -23,87 +23,87 @@ dataUpload <- function(input, output, session){ } # names names(data_list) <- input$datafile$name - + # append to existing reactiveValues list dd$data <- c(dd$data, data_list) - + # set dd$current to FALSE for previous & TRUE for current uploads dd$current <- c(rep(FALSE, length(dd$current)), rep(TRUE, length(data_list))) - + # run detectStandard on new data and save to dd$standard - + standard_list <- lapply(data_list, function(x){ detectStandard(x) }) - + #standard_list <- lapply(data_list, function(x){ detectStandard(x)$standard }) - + dd$standard <- c(dd$standard, standard_list) - + }) - - + + ### make a reactive combining dd$data & standard data_choices <- reactive({ - + req(dd$data) req(dd$standard) - + choices <- list() for (i in 1:length(dd$data)){ choices[[i]] <- names(dd$data)[i] } for (i in 1:length(dd$data)){ - + temp_standard <- dd$standard[[i]]$standard - - if(temp_standard == "None") { + standard_label <- ifelse(temp_standard=="adam","AdAM",ifelse(temp_standard=="sdtm","SDTM",temp_standard)) + if(temp_standard == "none") { names(choices)[i] <- paste0("

", names(dd$data)[i], " - No Standard Detected

") - } else if (dd$standard[[i]]$details[[temp_standard]]$match == "Full") { - names(choices)[i] <- paste0("

", names(dd$data)[i], " - ", dd$standard[[i]]$standard, "

") + } else if (dd$standard[[i]]$details[[temp_standard]]$match == "full") { + names(choices)[i] <- paste0("

", names(dd$data)[i], " - ", standard_label, "

") # If partial data spec match - give the fraction of variables matched } else { - + valid_count <- dd$standard[[i]]$details[[temp_standard]]$valid_count total_count <- dd$standard[[i]]$details[[temp_standard]]$invalid_count + valid_count - + fraction_cols <- paste0(valid_count, "/" ,total_count) names(choices)[i] <- paste0("

", names(dd$data)[i], " - ", "Partial ", - dd$standard[[i]]$standard, " (", fraction_cols, " data settings)", "

") + standard_label, " (", fraction_cols, " data settings)", "

") } } return(choices) }) - + # update radio buttons to display dataset names and standards for selection observeEvent(input$datafile, { req(data_choices()) vals <- data_choices() names(vals) <- NULL names <- lapply(names(data_choices()), HTML) - + prev_sel <- lapply(reactiveValuesToList(input), unclass)$select_file # retain previous selection - + updateRadioButtons(session, "select_file", choiceNames = names, choiceValues = vals, selected = prev_sel) - + }) - + # get selected dataset when selection changes data_selected <- eventReactive(input$select_file, { isolate({index <- which(names(dd$data)==input$select_file)[1]}) dd$data[[index]] }) - + # upon a dataset being uploaded and selected, generate data preview output$datapreview_header <- renderUI({ data_selected() isolate(data_name <- input$select_file) h3(paste("Data Preview for", data_name)) }) - + output$data_preview <- DT::renderDataTable({ DT::datatable(data = data_selected(), caption = isolate(input$select_file), @@ -112,54 +112,54 @@ dataUpload <- function(input, output, session){ class="compact", extensions = "Scroller", options = list(scrollY=400, scrollX=TRUE)) }) - - + + # upon a dataset being selected, grab its standard standard <- eventReactive(data_selected(), { index <- which(names(dd$data)==input$select_file)[1] dd$standard[[index]] }) - + # upon a dataset being selected, use generateSettings() to produce a settings obj settings <- eventReactive(c(data_selected(), standard()), { - + current_standard <- standard()$standard - - if (! current_standard=="None"){ - partial <- ifelse(standard()$details[[current_standard]]$match == "Partial", TRUE, FALSE) - + + if (! current_standard=="none"){ + partial <- ifelse(standard()$details[[current_standard]]$match == "partial", TRUE, FALSE) + if (partial) { - partial_keys <- standard()$details[[current_standard]]$checks %>% + partial_keys <- standard()$details[[current_standard]]$checks %>% filter(valid==TRUE) %>% - select(text_key) %>% + select(text_key) %>% pull() - + generateSettings(standard=current_standard, chart="eDish", partial=partial, partial_keys = partial_keys) - + } else { generateSettings(standard=current_standard, chart="eDish") - } + } } else { generateSettings(standard=current_standard, chart="eDish") } }) - + # run validateSettings(data, standard, settings) and return a status status <- reactive({ req(data_selected()) req(settings()) - validateSettings(data_selected(), + validateSettings(data_selected(), settings(), - chart="eDish") + chart="eDish") }) - + exportTestValues(status = { status() }) ### return selected data, settings, and status to server return(list(data_selected = reactive(data_selected()), settings = reactive(settings()), status = reactive(status()))) - -} \ No newline at end of file + +} diff --git a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R index e214b5b8..3b8683bd 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R +++ b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R @@ -1,21 +1,21 @@ dataUploadUI <- function(id){ - + ns <- NS(id) - - tagList( + + tagList( fluidRow( column(3, wellPanel( - h3("Data upload"), + h3("Data upload"), fileInput(ns("datafile"), "Upload a csv or sas7bdat file",accept = c(".sas7bdat", ".csv"), multiple = TRUE), - radioButtons(ns("select_file"),"Select file for eDISH chart", + radioButtons(ns("select_file"),"Select file for eDISH chart", choiceNames = list(HTML("

Example data - ADaM

")), choiceValues = "Example data") ) ), - column(6, + column(6, fluidRow( - wellPanel( + wellPanel( uiOutput(ns("datapreview_header")), div(DT::dataTableOutput(ns("data_preview")), style = "font-size: 75%") ) @@ -23,5 +23,5 @@ dataUploadUI <- function(id){ ) ) ) - -} \ No newline at end of file + +} From 67119379ddcee3c52612264065d32607b337f2f3 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Mon, 25 Feb 2019 11:15:01 -0800 Subject: [PATCH 29/40] clear check --- R/settingsMetadata.R | 4 +--- man/settingsMetadata.Rd | 3 +-- 2 files changed, 2 insertions(+), 5 deletions(-) diff --git a/R/settingsMetadata.R b/R/settingsMetadata.R index c1d109b5..92882d95 100644 --- a/R/settingsMetadata.R +++ b/R/settingsMetadata.R @@ -8,15 +8,13 @@ #' \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} #' \item{label}{Label} #' \item{description}{Description} -#' \item{setting_cat}{Setting category (data, measure, appearance)} #' \item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"} #' \item{setting_required}{Flag indicating if the setting is required} #' \item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data} #' \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} #' \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} #' \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} -#' \item{setting_cat}{Category specifying where the setting should be located in shiny} - +#' \item{setting_cat}{Setting category (data, measure, appearance)} #' } #' #' @source Created for this package diff --git a/man/settingsMetadata.Rd b/man/settingsMetadata.Rd index ba3ab5ab..7574fe69 100644 --- a/man/settingsMetadata.Rd +++ b/man/settingsMetadata.Rd @@ -10,14 +10,13 @@ \item{text_key}{Text key indicating the setting name. \code{'--'} delimiter indicates a nested setting} \item{label}{Label} \item{description}{Description} - \item{setting_cat}{Setting category (data, measure, appearance)} \item{setting_type}{Expected type for setting value. Should be "character", "vector", "numeric" or "logical"} \item{setting_required}{Flag indicating if the setting is required} \item{column_mapping}{Flag indicating if the setting corresponds to a column in the associated data} \item{column_type}{Expected type for the data column values. Should be "character","logical" or "numeric"} \item{field_mapping}{Flag indicating whether the setting corresponds to a field-level mapping in the data} \item{field_column_key}{Key for the column that provides options for the field-level mapping in the data} - \item{setting_cat}{Category specifying where the setting should be located in shiny} + \item{setting_cat}{Setting category (data, measure, appearance)} }} \source{ Created for this package From ef4a00c77aeb80f766aba30a9febfe7a9004d376 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Mon, 25 Feb 2019 14:00:07 -0800 Subject: [PATCH 30/40] start settings page refactor --- inst/eDISH_app/global.R | 1 + .../modules/renderSettings/renderSettingsUI.R | 120 ++++++++---------- inst/eDISH_app/ui.R | 6 +- inst/eDISH_app/www/index.css | 18 +++ 4 files changed, 76 insertions(+), 69 deletions(-) create mode 100644 inst/eDISH_app/www/index.css diff --git a/inst/eDISH_app/global.R b/inst/eDISH_app/global.R index 2d4f75f9..afd6781c 100644 --- a/inst/eDISH_app/global.R +++ b/inst/eDISH_app/global.R @@ -1,5 +1,6 @@ library(safetyGraphics) library(shiny) +library(shinyWidgets) library(shinyjs) library(dplyr) library(purrr) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index df8f910d..bceff350 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -5,79 +5,67 @@ renderSettingsUI <- function(id){ tagList( verticalLayout( - fluidRow( - column(4, - wellPanel( - div( - span(h2(tags$strong("Select Chart(s):"))), - checkboxGroupInput(ns("charts"),"", - choices = c("e-DISH" = "edish"), - selected="edish")) - ) + wellPanel( + class="chartSelect section", + h2("Select Chart(s):"), + checkboxGroupInput( + ns("charts"), + "", + choices = c("e-DISH" = "edish"), + selected="edish" ) ), - fluidRow( - column(4, - tags$hr() - ) + wellPanel( + class="dataMapping section", + h3( + materialSwitch( + ns("show_data_mapping"), + label = "Data Mapping", + right=TRUE, + value = TRUE, + status = "primary" + ) ), - fluidRow( - column(4, - h2(tags$strong("Customize Settings:")) - ) - ), - fluidRow( - column(4, - div( - div(style="display: inline-block;", h3(tags$i("Data Mapping"))), - div(style="display: inline-block;", checkboxInput(ns("show_data_mapping"), "show", TRUE)) - ) + conditionalPanel( + condition="input.show_data_mapping", + ns=ns, + uiOutput(ns("data_mapping_ui")) ) ), - conditionalPanel(condition="input.show_data_mapping", ns=ns, - fluidRow( - column(4, - wellPanel( - uiOutput(ns("data_mapping_ui")) - )) - - ) - ), - - fluidRow( - column(4, - div( - div(style="display: inline-block;", h3(tags$i("Measure Settings"))), - div(style="display: inline-block;", checkboxInput(ns("show_measure_settings"), "show", TRUE)) - ) + wellPanel( + class="measureSettings section", + h3( + materialSwitch( + ns("show_measure_settings"), + label = "Measure Settings", + right=TRUE, + value = TRUE, + status = "primary" + ) + ), + conditionalPanel( + condition="input.show_measure_settings", + ns=ns, + uiOutput(ns("measure_settings_ui")) ) ), - conditionalPanel(condition="input.show_measure_settings", ns=ns, - fluidRow( - column(4, - wellPanel( - uiOutput(ns("measure_settings_ui")) - - ) - ) - ) - ), - fluidRow( - column(6, - div( - div(style="display: inline-block;", h3(tags$i("Appearance Settings"))), - div(style="display: inline-block;", checkboxInput(ns("show_appearance_settings"), "show", TRUE)) - ) + wellPanel( + class="appearanceSettings section", + h3( + materialSwitch( + ns("show_appearance_settings"), + label = "Appearance Settings", + right=TRUE, + value = TRUE, + status = "primary" + ) + ), + conditionalPanel( + condition="input.show_appearance_settings", + ns=ns, + uiOutput(ns("appearance_settings_ui")) ) - ), - conditionalPanel(condition="input.show_appearance_settings", ns=ns, - fluidRow( - column(4, - wellPanel( - uiOutput(ns("appearance_settings_ui")) - ) - ) - ) ) - )) + ) + ) } diff --git a/inst/eDISH_app/ui.R b/inst/eDISH_app/ui.R index a6e2eea2..b1b8a7f3 100644 --- a/inst/eDISH_app/ui.R +++ b/inst/eDISH_app/ui.R @@ -1,8 +1,8 @@ tagList( useShinyjs(), - tags$style(HTML(" - .ok { color:#008000;} - .notok {color: #FF0000;}")), + tags$head( + tags$link(rel = "stylesheet", type = "text/css", href = "index.css") + ), navbarPage("eDISH Shiny app", tabPanel(title = htmlOutput("data_tab_title"), dataUploadUI("datatab") diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css new file mode 100644 index 00000000..57b86ee1 --- /dev/null +++ b/inst/eDISH_app/www/index.css @@ -0,0 +1,18 @@ + +.section h2 div { + display:inline-block; +} + + +/* Validation Coloring */ +.ok { + color:#008000; +} +.notok { + color: #FF0000; +} + +/* hide the chartSelect div until we're ready to implement multiple charts */ +.chartSelect{ + display:none; +} \ No newline at end of file From 097386c35ba5e8c920c04bd60a22c3133c0a1ba6 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Tue, 26 Feb 2019 11:46:49 -0500 Subject: [PATCH 31/40] document shiny app functions --- .../eDISH_app/modules/dataUpload/dataUpload.R | 29 +++++++++++ .../modules/dataUpload/dataUploadUI.R | 13 +++++ .../modules/renderChart/renderEDishChart.R | 16 ++++++ .../modules/renderChart/renderEDishChartUI.R | 8 +++ .../modules/renderSettings/renderSettings.R | 51 +++++++++++++++++-- .../modules/renderSettings/renderSettingsUI.R | 16 +++++- .../renderSettings/util/createControl.R | 18 +++++++ .../renderSettings/util/createSettingLabel.R | 7 +++ .../renderSettings/util/createSettingsUI.R | 9 ++++ .../modules/renderSettings/util/flagSetting.R | 8 --- .../renderSettings/util/labelSetting.R | 14 ----- .../renderSettings/util/updateSettingStatus.R | 17 +++++-- inst/eDISH_app/server.R | 7 +++ inst/eDISH_app/ui.R | 2 + 14 files changed, 184 insertions(+), 31 deletions(-) delete mode 100644 inst/eDISH_app/modules/renderSettings/util/flagSetting.R delete mode 100644 inst/eDISH_app/modules/renderSettings/util/labelSetting.R diff --git a/inst/eDISH_app/modules/dataUpload/dataUpload.R b/inst/eDISH_app/modules/dataUpload/dataUpload.R index 781b1410..82ee0633 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUpload.R +++ b/inst/eDISH_app/modules/dataUpload/dataUpload.R @@ -1,3 +1,32 @@ +#' Data upload module - server code +#' +#' This module creates the Data tab for the Shiny app. +#' +#' Workflow: +#' (1) A reactiveValues() list is created with example dataset as first entry. +#' The following information is included in list: +#' - dataset and name +#' - current (whether the dataset came from most recent upload) +#' - data standard / quality of match +#' (2) Upon user data upload: +#' - reactiveValues list is updated with information about new data. +#' - radio buttons are updated with new data choices +#' (3) When a new dataset is selected, the data preview output is invalidated +#' (4) When a new dataset is selected OR the standard changes (since these don't update at the same time), the +#' the settings object ("settings()") is invalidated. +#' (5) When a new dataset is selected OR the settings object is updated, the settings validation ("status()") is +#' invalidated. +#' +#' @param input Input objects from module namespace +#' @param output Output objects from module namespace +#' @param session An environment that can be used to access information and functionality relating to the session +#' +#' @return A list of reactive values, including: +#' \itemize{ +#' \item{"data_selected"}{A data frame selected by the user} +#' \item{"settings"}{Result from generateSettings() for data_selected} +#' \item{"status"}{Result from validateSettings() for data_selected and settings} +#' dataUpload <- function(input, output, session){ ns <- session$ns diff --git a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R index 3b8683bd..cb5b6ccb 100644 --- a/inst/eDISH_app/modules/dataUpload/dataUploadUI.R +++ b/inst/eDISH_app/modules/dataUpload/dataUploadUI.R @@ -1,3 +1,16 @@ +#' Data upload module - UI code +#' +#' This module creates the Data tab for the Shiny app. +#' +#' The UI contains: +#' - a file upload control +#' - radio buttons for selecting from the available datasets +#' - raw data preview. +#' +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Data tab +#' dataUploadUI <- function(id){ ns <- NS(id) diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChart.R b/inst/eDISH_app/modules/renderChart/renderEDishChart.R index 15470cca..b900e9bf 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChart.R +++ b/inst/eDISH_app/modules/renderChart/renderEDishChart.R @@ -1,3 +1,19 @@ +#' Render eDISH chart - server code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive eDISH graphic. +#' +#' Workflow: +#' (1) A change in `data`, `settings`, or `valid` invalidates the eDISH chart output +#' (2) Upon a change in `valid`, the export chart functionality is conditionally made available or unavailable to user +#' (3) If "export chart" button is pressed, data and settings are passed to the parameterized report, knitted using +#' Rmarkdown, and downloaded to user computer. +#' +#' @param input Input objects from module namespace +#' @param output Output objects from module namespace +#' @param session An environment that can be used to access information and functionality relating to the session +#' @param data A data frame +#' @param valid A logical indicating whether data/settings combination is valid for chart + renderEDishChart <- function(input, output, session, data, settings, valid){ ns <- session$ns diff --git a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R b/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R index 8751609c..62a8fe14 100644 --- a/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R +++ b/inst/eDISH_app/modules/renderChart/renderEDishChartUI.R @@ -1,3 +1,11 @@ +#' Render eDISH chart - UI code +#' +#' This module creates the Chart tab for the Shiny app, which contains the interactive eDISH graphic. + +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Chart tab +#' renderEDishChartUI <- function(id){ ns <- NS(id) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 0820440c..998cf506 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -1,8 +1,49 @@ +# Functions to include source("modules/renderSettings/util/createSettingLabel.R") source("modules/renderSettings/util/createControl.R") source("modules/renderSettings/util/createSettingsUI.R") source("modules/renderSettings/util/updateSettingStatus.R") +#' Render Settings module - Server code +#' +#' This module creates the Settings tab for the Shiny app. +#' +#' Workflow: +#' (1) Reactive input_names() contains names of settings related to selected charts. When a user changes +#' chart selections, input_names() is invalidated. +#' (2) A change in input_names(), `data`, or `settings` invalidates the following: +#' - renderUI associated with data mapping settings +#' - renderUI associated with measure settings +#' - renderUI associated with appearance settings +#' (3) These renderUI's call upon the createSettingsUI() function and will update +#' even when settings tab not in view. They will create and populate the UI for all related settings. +#' (4) Field-level inputs are updated upon any of the following events: +#' - a change in selected data +#' - change in selected chart(s) +#' - change in column-level input selection +#' update includes: +#' - Deactivate/activate field-level selector based on whether column-level input has been selected +#' - Data choices for field-level inputs based on selected column-level input +#' (5) A reactive representing the new settings object (settings_new()) is created based on UI selections. This object is invalidated +#' when ANY input changes. +#' (6) A reactive representing the new data/settings validation (status_new()) is created based on data and updated settings object. +#' A change in data OR updated settings object invalidated this reactive. +#' (7) Upon a change in the new validation (status_new() and derived status_df()), updated status messages are +#' printed on UI by calling updateSettingStatus(). ALL messages are re-printed at once. +#' +#' @param input Input objects from module namespace +#' @param output Output objects from module namespace +#' @param session An environment that can be used to access information and functionality relating to the session +#' @param data A data frame +#' @param settings Settings object that corresponds to data's standard - result of generateSettings(). +#' @param status A list describing the validation state for data/settings - result of validateSettings(). +#' +#' @return A list of reactive values, including: +#' \itemize{ +#' \item{"charts"}{A vector of chart(s) selected by the user} +#' \item{"settings"}{Upadted settings object based on UI/user selections} +#' \item{"status"}{Result from validateSettings() for originally selected data + updated settings object} +#' renderSettings <- function(input, output, session, data, settings, status){ ns <- session$ns @@ -199,14 +240,14 @@ renderSettings <- function(input, output, session, data, settings, status){ # print validation messages ###################################################################### observe({ - for (name in isolate(input_names())){ + for (key in isolate(input_names())){ - if(name %in% status_df()$text_key){ + if(key %in% status_df()$text_key){ - status_short <- status_df()[status_df()$text_key==name, "message_short"] - status_long <- status_df()[status_df()$text_key==name, "message_long"] + status_short <- status_df()[status_df()$text_key==key, "message_short"] + status_long <- status_df()[status_df()$text_key==key, "message_long"] - updateSettingStatus(ns=ns, name=name, status_short=status_short, status_long=status_long) + updateSettingStatus(ns=ns, key=key, status_short=status_short, status_long=status_long) } } diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index df8f910d..e2a34290 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -1,4 +1,18 @@ - +#' Render Settings module - UI code +#' +#' This module creates the Settings tab for the Shiny app. The UI is dynamically populated from the server side. +#' +#' The UI contains: +#' - Chart selector +#' - Settings customizations for the selected charts: +#' - Data mapping +#' - Measure settings +#' - Appearance settings +#' +#' @param id The module-specific ID that will get pre-pended to all element IDs +#' +#' @return The UI for the Settings tab +#' renderSettingsUI <- function(id){ ns <- NS(id) diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index b1af014d..b958f647 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -1,3 +1,21 @@ +#' Create setting control +#' +#' Workflow: +#' (1) Get setting label and description from metadata +#' (2) Get setting value from settings object +#' (3) Get choices and placeholder text for the selectors based on metadata, data, and settings +#' (4) Create HTML code for the selector based on the following metadata: +#' - whether the option is a column or field-level input +#' - data type of the setting (e.g. character/numeric/logical, vector of length 1 vs >1) +#' - label, description, choices, selected value, placeholder text +#' +#' @param key A character key representing the setting of interest +#' @param metadata Metadata data frame to be queried for information about the setting +#' @param data A data frame to be used to populate control options +#' @param settings A settings list to be used to populate control options +#' @param ns The namespace of the current module +#' +#' @return HTML code for the div containing the setting of interest createControl <- function(key, metadata, data, settings, ns){ sm_key <- filter(metadata, text_key==key) diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R index b127f9ec..c496ae53 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R @@ -1,3 +1,10 @@ +#' Create label for chart setting selector +#' +#' @param key A character key representing the setting of interest. +#' +#' @return A character string containing full HTML text to be used for input label. Contains info icon to +#' indicate that description is available upon mouseover, setting label, and asterisk if setting is required. +#' createSettingLabel <- function(key){ sm <- getSettingsMetadata(text_keys=key) setting_label <- sm$label diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R index 8a7e955e..086a5940 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsUI.R @@ -1,3 +1,12 @@ +#' Create UI for specified section of settings tab +#' +#' @param data A data frame to be used to populate control options +#' @param settings A settings list to be used to populate control options +#' @param setting_cat_val Settings category. One of "data","measure","appearance" +#' @param charts A character vector containing names of charts of interest +#' @param ns The namespace of the current module +#' +#' @return A list containing the UI code for all selectors in the specified settings category. createSettingsUI <- function(data, settings, setting_cat_val, charts, ns){ sm <- getSettingsMetadata(charts=charts) %>% diff --git a/inst/eDISH_app/modules/renderSettings/util/flagSetting.R b/inst/eDISH_app/modules/renderSettings/util/flagSetting.R deleted file mode 100644 index eb0b6542..00000000 --- a/inst/eDISH_app/modules/renderSettings/util/flagSetting.R +++ /dev/null @@ -1,8 +0,0 @@ -flagSetting<-function(session, name, originalLabel){ - - originalLabel <- paste("", originalLabel) - - shinyjs::html(id = paste0("lbl_", name), - html = paste0(originalLabel, "*"), - add = FALSE) -} diff --git a/inst/eDISH_app/modules/renderSettings/util/labelSetting.R b/inst/eDISH_app/modules/renderSettings/util/labelSetting.R deleted file mode 100644 index cf0f4cf7..00000000 --- a/inst/eDISH_app/modules/renderSettings/util/labelSetting.R +++ /dev/null @@ -1,14 +0,0 @@ -labelSetting<-function(ns, name, label, description){ - - - label <- paste("", label) - - label_id <- paste0("lbl_", name) - shinyjs::html(id = label_id, - html = label, - add = FALSE) - - tooltip_id <- paste0("tt_lbl_", name) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "', description, '")')) -} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R index c594d42b..ed3d49e2 100644 --- a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R +++ b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R @@ -1,7 +1,18 @@ -updateSettingStatus<-function(ns, name, status_short, status_long){ +#' Update setting validation status +#' +#' Workflow: +#' (1) Update abbreviated status for a given setting using green (valid) or red (invalid) text +#' (2) Update long status message for a given setting to be displayed upon mouseover +#' +#' @param ns The namespace of the current module +#' @param key A character key representing the setting of interest +#' @param status_short Abbreviated validation message +#' @param status_long Detailed validation message + +updateSettingStatus<-function(ns, key, status_short, status_long){ - msg_id <- paste0("msg_", name) - tooltip_id <- paste0("tt_msg_", name) + msg_id <- paste0("msg_", key) + tooltip_id <- paste0("tt_msg_", key) if (status_short=="OK"){ shinyjs::html(id = msg_id, diff --git a/inst/eDISH_app/server.R b/inst/eDISH_app/server.R index 9ee0f420..76dfae74 100644 --- a/inst/eDISH_app/server.R +++ b/inst/eDISH_app/server.R @@ -1,3 +1,10 @@ +# Server code for safetyGraphics App +# - calls dataUpload module (data tab) +# - calls renderSettings module (settings tab) +# - calls renderEDishChart (chart tab) +# - uses render UI to append a red X or green check on tab title, +# indicating whether user has satisfied requirements of that tab + function(input, output, session){ diff --git a/inst/eDISH_app/ui.R b/inst/eDISH_app/ui.R index a6e2eea2..35f49691 100644 --- a/inst/eDISH_app/ui.R +++ b/inst/eDISH_app/ui.R @@ -1,3 +1,5 @@ +# UI Code for safetyGraphics App + tagList( useShinyjs(), tags$style(HTML(" From 684050a25d347c325be418974e2711f4b0929d16 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Tue, 26 Feb 2019 12:32:16 -0800 Subject: [PATCH 32/40] more UI tweaks --- .../modules/renderSettings/renderSettingsUI.R | 7 +- .../renderSettings/util/createControl.R | 69 +++++++------------ inst/eDISH_app/www/index.css | 44 ++++++++++-- 3 files changed, 67 insertions(+), 53 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index bceff350..60ce67ef 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -17,14 +17,13 @@ renderSettingsUI <- function(id){ ), wellPanel( class="dataMapping section", - h3( - materialSwitch( + h3("Data Mapping"), + materialSwitch( ns("show_data_mapping"), - label = "Data Mapping", + label = "", right=TRUE, value = TRUE, status = "primary" - ) ), conditionalPanel( condition="input.show_data_mapping", diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index b1af014d..73573f72 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -19,69 +19,52 @@ createControl <- function(key, metadata, data, settings, ns){ field_column_label <- getSettingsMetadata(text_key = sm_key$field_column_key, cols = "label") } - ### get the choices for the selectors value <- NULL choices <- NULL placeholder <- NULL - if(sm_key$column_mapping==TRUE){ - if(is.null(setting_value)){ + + if(sm_key$column_mapping==TRUE & is.null(setting_value)){ #column mapping - no value specified choices <- colnames(data) - placeholder <- list( - onInitialize = I('function() { - this.setValue("");}')) - } else{ - choices <- unique(c(setting_value, colnames(data))) - placeholder <- list (onInitialize = I('function() { }')) - } - } else if (sm_key$field_mapping==TRUE){ - if(is.null(field_column)){ ## if there is NOT a column specified in settings + placeholder <- list(onInitialize = I('function() {this.setValue("");}')) + } else if(sm_key$column_mapping==TRUE & !is.null(setting_value)) { #column mapping - value specified + choices <- unique(c(setting_value, colnames(data))) + placeholder <- list (onInitialize = I('function() { }')) + } else if (sm_key$field_mapping==TRUE & is.null(field_column)){ ## if there is NOT a column specified in settings placeholder <- list( placeholder = paste0("Please select a ", field_column_label), onInitialize = I('function() { - this.setValue("");}')) - } else{ ## if there is a column specified in settings + this.setValue("");}') + ) + } else if (sm_key$field_mapping==TRUE & !is.null(field_column)){ ## if there is NOT a column specified in settings choices <- unique(c(setting_value, as.character(data[,field_column]))) %>% unlist placeholder <- list (onInitialize = I('function() { }')) - } } else if (sm_key$setting_type=="vector"){ choices <- setting_value ### this is meant to cover the scenario for x_options/y_options } - - ### create code for the UI + multiple <- (sm_key$setting_type=="vector") + if (sm_key$column_mapping==TRUE | sm_key$field_mapping==TRUE){ - - multiple <- (sm_key$setting_type=="vector") - - div( - span(title = setting_description, tags$label(HTML(setting_label))), - span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), - selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) - ) + input <- selectizeInput(inputId = ns(key), label = NULL, choices = choices, options = placeholder, multiple = multiple) } else if (sm_key$setting_type=="vector"){ - - div( - span(title = setting_description, tags$label(HTML(setting_label))), - span(id = ns(tt_msg), title = "", tags$label(id = ns(msg), "")), - selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) - ) - + input <- selectizeInput(inputId = ns(key), label = NULL, choices = choices, selected = choices, multiple = TRUE) } else if (sm_key$setting_type=="numeric"){ - div( - div(title = setting_description, tags$label(HTML(setting_label))), - sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) - ) + input <- sliderInput(inputId = ns(key), label = NULL, value=setting_value, min=0, max=50) } else if (sm_key$setting_type=="logical"){ - div( - div(title = setting_description, tags$label(HTML(setting_label))), - checkboxInput(inputId = ns(key), label = NULL, value=setting_value) - ) + input <- checkboxInput(inputId = ns(key), label = NULL, value=setting_value) } else if (sm_key$setting_type=="character"){ + input <-textAreaInput(inputId = ns(key), label = NULL, value = setting_value) + } + + div( + class="control-wrap", + span(title = setting_description, tags$label(HTML(setting_label))), div( - div(title = setting_description, tags$label(HTML(setting_label))), - textAreaInput(inputId = ns(key), label = NULL, value = setting_value) + class="select-wrap", + input, + div(id = ns(tt_msg), title = "", tags$label(id = ns(msg), ""), class="status") ) - } + ) } \ No newline at end of file diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css index 57b86ee1..a85599d2 100644 --- a/inst/eDISH_app/www/index.css +++ b/inst/eDISH_app/www/index.css @@ -1,18 +1,50 @@ +/* --- hide the chartSelect div until we're ready to implement multiple charts --- */ +.chartSelect{ + display:none; +} +/* ------------------------------------------------------------------------------- */ -.section h2 div { +.control-wrap .select-wrap .form-group{ + display:inline-block; +} + +.control-wrap .select-wrap .status{ display:inline-block; + margin-top:.5em; + vertical-align:top; + cursor:help; } +.control-wrap .select-wrap div .selectize-control{ + min-width:300px; +} /* Validation Coloring */ + +.control-wrap .select-wrap.valid .status{ + color:green; +} + +.control-wrap select-wrap.valid div .selectize-control .selectize-input{ + border-color:green; +} + +.control-wrap .select-wrap.invalid .status{ + color:red; +} + +.control-wrap .select-wrap.invalid div .selectize-control .selectize-input{ + border-color:red; +} + +.material-switch{ + float:right; +} + .ok { color:#008000; } + .notok { color: #FF0000; -} - -/* hide the chartSelect div until we're ready to implement multiple charts */ -.chartSelect{ - display:none; } \ No newline at end of file From 7774941bbade055b2727d98007763f6f3bb0380a Mon Sep 17 00:00:00 2001 From: jwildfire Date: Tue, 26 Feb 2019 14:04:14 -0800 Subject: [PATCH 33/40] add function for section render --- .../modules/renderSettings/renderSettingsUI.R | 106 ++++++------------ inst/eDISH_app/www/index.css | 19 +++- 2 files changed, 50 insertions(+), 75 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index 6dc187ed..c672fdb4 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -1,84 +1,46 @@ -#' Render Settings module - UI code -#' -#' This module creates the Settings tab for the Shiny app. The UI is dynamically populated from the server side. -#' -#' The UI contains: -#' - Chart selector -#' - Settings customizations for the selected charts: -#' - Data mapping -#' - Measure settings -#' - Appearance settings -#' -#' @param id The module-specific ID that will get pre-pended to all element IDs -#' -#' @return The UI for the Settings tab -#' + renderSettingsUI <- function(id){ - + makeSection <- function(class, label){ + section <- + column(6, + wellPanel( + class=paste0(class," section"), + h3( + label, + materialSwitch( + ns(paste0("show_",class)), + label = "", + right=TRUE, + value = TRUE, + status = "primary" + ) + ), + conditionalPanel( + condition=paste0("input.show_",class), + ns=ns, + uiOutput(ns(paste0(class,"_ui"))) + ) + ) + ) + return(section) + } ns <- NS(id) - - tagList( - verticalLayout( - wellPanel( + fluidPage( + fluidRow( + column(12, class="chartSelect section", - h2("Select Chart(s):"), checkboxGroupInput( ns("charts"), - "", + "Select Chart(s):", choices = c("e-DISH" = "edish"), selected="edish" ) - ), - wellPanel( - class="dataMapping section", - h3("Data Mapping"), - materialSwitch( - ns("show_data_mapping"), - label = "", - right=TRUE, - value = TRUE, - status = "primary" - ), - conditionalPanel( - condition="input.show_data_mapping", - ns=ns, - uiOutput(ns("data_mapping_ui")) - ) - ), - wellPanel( - class="measureSettings section", - h3( - materialSwitch( - ns("show_measure_settings"), - label = "Measure Settings", - right=TRUE, - value = TRUE, - status = "primary" - ) - ), - conditionalPanel( - condition="input.show_measure_settings", - ns=ns, - uiOutput(ns("measure_settings_ui")) - ) - ), - wellPanel( - class="appearanceSettings section", - h3( - materialSwitch( - ns("show_appearance_settings"), - label = "Appearance Settings", - right=TRUE, - value = TRUE, - status = "primary" - ) - ), - conditionalPanel( - condition="input.show_appearance_settings", - ns=ns, - uiOutput(ns("appearance_settings_ui")) - ) ) + ), + fluidRow( + makeSection("data_mapping", "Data Mappings"), + makeSection("measure_settings", "Measure Settings"), + makeSection("appearance_settings", "Appearance Settings") ) ) } diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css index a85599d2..a8c4f302 100644 --- a/inst/eDISH_app/www/index.css +++ b/inst/eDISH_app/www/index.css @@ -4,6 +4,9 @@ } /* ------------------------------------------------------------------------------- */ +.section{ + min-width:400px; +} .control-wrap .select-wrap .form-group{ display:inline-block; } @@ -15,8 +18,8 @@ cursor:help; } -.control-wrap .select-wrap div .selectize-control{ - min-width:300px; +.control-wrap .select-wrap .form-group{ + width:60%; } /* Validation Coloring */ @@ -37,10 +40,20 @@ border-color:red; } -.material-switch{ +/* Settings - header tweaks */ +.section h3 { + margin:0; +} + +.section h3 .form-group { + display:inline; +} + +.section h3 .form-group .material-switch{ float:right; } + .ok { color:#008000; } From 63865f61c572ae80496009fd679bd90418ede116 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Tue, 26 Feb 2019 15:12:23 -0800 Subject: [PATCH 34/40] more refactor --- .../modules/renderSettings/renderSettings.R | 1 + .../modules/renderSettings/renderSettingsUI.R | 33 +++---------------- .../renderSettings/util/createControl.R | 6 ++-- .../renderSettings/util/createSettingLabel.R | 7 +--- .../util/createSettingsSection.R | 24 ++++++++++++++ .../renderSettings/util/updateSettingStatus.R | 29 ++++++++-------- inst/eDISH_app/www/index.css | 29 ++++++++++++---- 7 files changed, 72 insertions(+), 57 deletions(-) create mode 100644 inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 998cf506..96a49ba9 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -1,4 +1,5 @@ # Functions to include +source("modules/renderSettings/util/createSettingsSection.R") source("modules/renderSettings/util/createSettingLabel.R") source("modules/renderSettings/util/createControl.R") source("modules/renderSettings/util/createSettingsUI.R") diff --git a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R index c672fdb4..83a3f4c3 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettingsUI.R @@ -1,31 +1,7 @@ renderSettingsUI <- function(id){ - makeSection <- function(class, label){ - section <- - column(6, - wellPanel( - class=paste0(class," section"), - h3( - label, - materialSwitch( - ns(paste0("show_",class)), - label = "", - right=TRUE, - value = TRUE, - status = "primary" - ) - ), - conditionalPanel( - condition=paste0("input.show_",class), - ns=ns, - uiOutput(ns(paste0(class,"_ui"))) - ) - ) - ) - return(section) - } ns <- NS(id) - fluidPage( + tagList( fluidRow( column(12, class="chartSelect section", @@ -37,10 +13,11 @@ renderSettingsUI <- function(id){ ) ) ), + #TODO - make this a loop based on metadata fluidRow( - makeSection("data_mapping", "Data Mappings"), - makeSection("measure_settings", "Measure Settings"), - makeSection("appearance_settings", "Appearance Settings") + createSettingsSection("data_mapping", "Data Mappings",6,ns), + createSettingsSection("measure_settings", "Measure Settings",6,ns), + createSettingsSection("appearance_settings", "Appearance Settings",6,ns) ) ) } diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index b2c55933..bd29f55a 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -19,7 +19,7 @@ createControl <- function(key, metadata, data, settings, ns){ sm_key <- filter(metadata, text_key==key) - + ctl_id <- paste0("ctl_", key) tt_msg <- paste0("tt_msg_", key) msg <- paste0("msg_", key) @@ -28,6 +28,7 @@ createControl <- function(key, metadata, data, settings, ns){ setting_value <- safetyGraphics:::getSettingValue(key=setting_key, settings=settings) setting_label <- createSettingLabel(key) setting_description <- getSettingsMetadata(text_keys=key, cols="description") + setting_required <- ifelse(getSettingsMetadata(text_keys=key, cols="setting_required"),"\nSetting Required","\nSetting Optional") ### if a field-level input, get metadata about the parent column-level input field_column <- NULL @@ -78,7 +79,8 @@ createControl <- function(key, metadata, data, settings, ns){ div( class="control-wrap", - span(title = setting_description, tags$label(HTML(setting_label))), + id=ctl_id, + span(title = paste0(setting_description," ",setting_required), tags$label(HTML(setting_label))), div( class="select-wrap", input, diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R index c496ae53..5f162221 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingLabel.R @@ -9,10 +9,5 @@ createSettingLabel <- function(key){ sm <- getSettingsMetadata(text_keys=key) setting_label <- sm$label required <- sm$setting_required - - if (required){ - paste0(" ", setting_label, "*") - } else { - paste0(" ", setting_label) - } + paste0(setting_label)#, " " ) } diff --git a/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R b/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R new file mode 100644 index 00000000..eca0959e --- /dev/null +++ b/inst/eDISH_app/modules/renderSettings/util/createSettingsSection.R @@ -0,0 +1,24 @@ +createSettingsSection <- function(class, label,cols,ns){ + section <- + column(cols, + wellPanel( + class=paste0(class," section"), + h3( + label, + materialSwitch( + ns(paste0("show_",class)), + label = "", + right=TRUE, + value = TRUE, + status = "primary" + ) + ), + conditionalPanel( + condition=paste0("input.show_",class), + ns=ns, + uiOutput(ns(paste0(class,"_ui"))) + ) + ) + ) + return(section) +} \ No newline at end of file diff --git a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R index ed3d49e2..f4ece651 100644 --- a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R +++ b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R @@ -11,22 +11,21 @@ updateSettingStatus<-function(ns, key, status_short, status_long){ + ctl_id<-paste0("#ctl_", key," .select-wrap") + print(ctl_id) + #TODO: get msg_ and tooltip_ selectors using relative position to control id msg_id <- paste0("msg_", key) tooltip_id <- paste0("tt_msg_", key) - - if (status_short=="OK"){ - shinyjs::html(id = msg_id, - html = paste(" ", status_short,"", - "")) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "Selection is valid")')) - - } else { - shinyjs::html(id = msg_id, - html = paste(" ", status_short,"", - "")) - - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "', status_long, '")')) + if(status_short=="OK"){ + print("adding valid classes") + shinyjs::addClass(id=msg_id, class="valid") + shinyjs::removeClass(id=msg_id, class="invalid") + }else{ + print("adding invalid classes") + shinyjs::removeClass(id=msg_id, class="valid") + shinyjs::addClass(id=msg_id, class="invalid") } - + + shinyjs::html(id = msg_id, html = paste(status_short)) + shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "',status_long,'")')) } diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css index a8c4f302..d830402a 100644 --- a/inst/eDISH_app/www/index.css +++ b/inst/eDISH_app/www/index.css @@ -7,8 +7,24 @@ .section{ min-width:400px; } + +.control-wrap{ + margin-top:1em; +} + +.control-wrap span label{ + font-weight:normal; + color:#444; + cursor:help; +} + .control-wrap .select-wrap .form-group{ - display:inline-block; + display:inline-block; + margin-bottom:0; +} + +.control-wrap .select-wrap .form-group .form-control{ + margin-bottom:0; } .control-wrap .select-wrap .status{ @@ -19,24 +35,25 @@ } .control-wrap .select-wrap .form-group{ - width:60%; + min-width:70%; /* TODO: don't love this ... update eventually */ + } /* Validation Coloring */ -.control-wrap .select-wrap.valid .status{ +.control-wrap.valid .select-wrap .status{ color:green; } -.control-wrap select-wrap.valid div .selectize-control .selectize-input{ +.control-wrap.valid .select-wrap div .selectize-control .selectize-input{ border-color:green; } -.control-wrap .select-wrap.invalid .status{ +.control-wrap.invalid .select-wrap .status{ color:red; } -.control-wrap .select-wrap.invalid div .selectize-control .selectize-input{ +.control-wrap.invalid .select-wrap div .selectize-control .selectize-input{ border-color:red; } From 375cba32edd1a450582b5c8ce8ce031613ac275b Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Wed, 27 Feb 2019 12:12:52 -0500 Subject: [PATCH 35/40] import haven::read_sas --- DESCRIPTION | 3 ++- NAMESPACE | 1 + R/safetyGraphicsApp.R | 1 + inst/eDISH_app/global.R | 4 ++++ 4 files changed, 8 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 00b447c9..5c86e2fb 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -35,5 +35,6 @@ Imports: rmarkdown, rlang, tibble, - utils + utils, + haven VignetteBuilder: knitr diff --git a/NAMESPACE b/NAMESPACE index cb58fb76..0f21478b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -16,6 +16,7 @@ import(rmarkdown) import(shinyjs) importFrom(dplyr,"filter") importFrom(dplyr,filter) +importFrom(haven,read_sas) importFrom(magrittr,"%>%") importFrom(purrr,keep) importFrom(purrr,map) diff --git a/R/safetyGraphicsApp.R b/R/safetyGraphicsApp.R index 4b29d35b..e62a7731 100644 --- a/R/safetyGraphicsApp.R +++ b/R/safetyGraphicsApp.R @@ -9,6 +9,7 @@ #' @importFrom purrr map keep #' @importFrom magrittr "%>%" #' @import rmarkdown +#' @importFrom haven read_sas #' #' @export #' diff --git a/inst/eDISH_app/global.R b/inst/eDISH_app/global.R index 2d4f75f9..d528f75d 100644 --- a/inst/eDISH_app/global.R +++ b/inst/eDISH_app/global.R @@ -1,3 +1,6 @@ +# global.R code for safetyGraphics app +# - load all required libraries +# - source module functions library(safetyGraphics) library(shiny) library(shinyjs) @@ -5,6 +8,7 @@ library(dplyr) library(purrr) library(stringr) library(DT) +library(haven) ## source modules source('modules/renderSettings/renderSettingsUI.R') From 009de03d0bf6e1cd90f4d395db8b8631c8051d54 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Wed, 27 Feb 2019 10:19:48 -0800 Subject: [PATCH 36/40] update validation styles --- .../modules/renderSettings/renderSettings.R | 7 +++--- .../renderSettings/util/createControl.R | 2 +- .../renderSettings/util/updateSettingStatus.R | 22 +++++++++---------- inst/eDISH_app/www/index.css | 9 ++++---- 4 files changed, 20 insertions(+), 20 deletions(-) diff --git a/inst/eDISH_app/modules/renderSettings/renderSettings.R b/inst/eDISH_app/modules/renderSettings/renderSettings.R index 96a49ba9..014d686c 100644 --- a/inst/eDISH_app/modules/renderSettings/renderSettings.R +++ b/inst/eDISH_app/modules/renderSettings/renderSettings.R @@ -224,13 +224,14 @@ renderSettings <- function(input, output, session, data, settings, status){ status_new()$checks %>% group_by(text_key) %>% mutate(num_fail = sum(valid==FALSE)) %>% + mutate(icon = ifelse(num_fail==0, "",""))%>% mutate(message_long = paste(message, collapse = " ") %>% trimws(), message_short = case_when( num_fail==0 ~ "OK", num_fail==1 ~ "1 failed check.", TRUE ~ paste(num_fail, "failed checks.") )) %>% - select(text_key, message_long, message_short, num_fail) %>% + select(text_key, icon, message_long, message_short, num_fail) %>% unique }) @@ -247,8 +248,8 @@ renderSettings <- function(input, output, session, data, settings, status){ status_short <- status_df()[status_df()$text_key==key, "message_short"] status_long <- status_df()[status_df()$text_key==key, "message_long"] - - updateSettingStatus(ns=ns, key=key, status_short=status_short, status_long=status_long) + icon <- status_df()[status_df()$text_key==key, "icon"] + updateSettingStatus(ns=ns, key=key, status_short=status_short, status_long=status_long, icon=icon) } } diff --git a/inst/eDISH_app/modules/renderSettings/util/createControl.R b/inst/eDISH_app/modules/renderSettings/util/createControl.R index bd29f55a..11b418a2 100644 --- a/inst/eDISH_app/modules/renderSettings/util/createControl.R +++ b/inst/eDISH_app/modules/renderSettings/util/createControl.R @@ -79,7 +79,7 @@ createControl <- function(key, metadata, data, settings, ns){ div( class="control-wrap", - id=ctl_id, + id=ns(ctl_id), span(title = paste0(setting_description," ",setting_required), tags$label(HTML(setting_label))), div( class="select-wrap", diff --git a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R index f4ece651..a3003b57 100644 --- a/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R +++ b/inst/eDISH_app/modules/renderSettings/util/updateSettingStatus.R @@ -9,23 +9,21 @@ #' @param status_short Abbreviated validation message #' @param status_long Detailed validation message -updateSettingStatus<-function(ns, key, status_short, status_long){ +updateSettingStatus<-function(ns, key, status_short, status_long, icon){ - ctl_id<-paste0("#ctl_", key," .select-wrap") - print(ctl_id) + ctl_id<-paste0("ctl_", key) #TODO: get msg_ and tooltip_ selectors using relative position to control id msg_id <- paste0("msg_", key) tooltip_id <- paste0("tt_msg_", key) if(status_short=="OK"){ - print("adding valid classes") - shinyjs::addClass(id=msg_id, class="valid") - shinyjs::removeClass(id=msg_id, class="invalid") + shinyjs::addClass(id=ctl_id, class="valid") + shinyjs::removeClass(id=ctl_id, class="invalid") }else{ - print("adding invalid classes") - shinyjs::removeClass(id=msg_id, class="valid") - shinyjs::addClass(id=msg_id, class="invalid") + shinyjs::removeClass(id=ctl_id, class="valid") + shinyjs::addClass(id=ctl_id, class="invalid") + } + shinyjs::html(id = msg_id, html = paste(icon)) + if(nchar(status_long)>0){ + shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "',status_long,'").addClass("details")')) } - - shinyjs::html(id = msg_id, html = paste(status_short)) - shinyjs::runjs(paste0('$("#',ns(tooltip_id), '").attr("title", "',status_long,'")')) } diff --git a/inst/eDISH_app/www/index.css b/inst/eDISH_app/www/index.css index d830402a..1f292331 100644 --- a/inst/eDISH_app/www/index.css +++ b/inst/eDISH_app/www/index.css @@ -19,6 +19,7 @@ } .control-wrap .select-wrap .form-group{ + width:90%; /* TODO: don't love this ... update eventually */ display:inline-block; margin-bottom:0; } @@ -30,15 +31,15 @@ .control-wrap .select-wrap .status{ display:inline-block; margin-top:.5em; + padding-left:0.5em; vertical-align:top; - cursor:help; } -.control-wrap .select-wrap .form-group{ - min-width:70%; /* TODO: don't love this ... update eventually */ - +.control-wrap .select-wrap .status.details label i { + cursor:help; } + /* Validation Coloring */ .control-wrap.valid .select-wrap .status{ From e53dad9570d9f96bfef5272d9b19797b5683093c Mon Sep 17 00:00:00 2001 From: jwildfire Date: Thu, 28 Feb 2019 09:44:58 -0800 Subject: [PATCH 37/40] tweak size option. fix #203 --- R/safetyGraphicsApp.R | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/R/safetyGraphicsApp.R b/R/safetyGraphicsApp.R index e62a7731..7cd9301a 100644 --- a/R/safetyGraphicsApp.R +++ b/R/safetyGraphicsApp.R @@ -13,9 +13,11 @@ #' #' @export #' -safetyGraphicsApp <- function(maxFileSize = 20) { +safetyGraphicsApp <- function(maxFileSize = NULL) { #increase maximum file upload limit - options(shiny.maxRequestSize=(maxFileSize*1024^2)) + if(!is.null(maxFileSize)){ + options(shiny.maxRequestSize=(maxFileSize*1024^2)) + } path <- system.file("eDISH_app", package = "safetyGraphics") shiny::runApp(path, launch.browser = TRUE) From 26ee995317bfd72f6986502c1b9b27ace620bc17 Mon Sep 17 00:00:00 2001 From: jwildfire Date: Thu, 28 Feb 2019 10:06:33 -0800 Subject: [PATCH 38/40] update docs --- man/safetyGraphicsApp.Rd | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/man/safetyGraphicsApp.Rd b/man/safetyGraphicsApp.Rd index 6f75fba1..f6ed62e0 100644 --- a/man/safetyGraphicsApp.Rd +++ b/man/safetyGraphicsApp.Rd @@ -4,7 +4,7 @@ \alias{safetyGraphicsApp} \title{Run the interactive safety graphics builder} \usage{ -safetyGraphicsApp(maxFileSize = 20) +safetyGraphicsApp(maxFileSize = NULL) } \arguments{ \item{maxFileSize}{maximum file size in MB allowed for file upload.} From e39bc2eca1000e9e8bd8d5d76ba51e4b983a6b62 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Thu, 28 Feb 2019 16:10:07 -0500 Subject: [PATCH 39/40] import shinywidgets::materialSwitch() --- NAMESPACE | 1 + R/safetyGraphicsApp.R | 1 + 2 files changed, 2 insertions(+) diff --git a/NAMESPACE b/NAMESPACE index 0f21478b..3acbd77b 100644 --- a/NAMESPACE +++ b/NAMESPACE @@ -26,6 +26,7 @@ importFrom(purrr,map_lgl) importFrom(rlang,.data) importFrom(rlang,parse_expr) importFrom(shiny,runApp) +importFrom(shinyWidgets,materialSwitch) importFrom(stringr,str_detect) importFrom(stringr,str_split) importFrom(stringr,str_subset) diff --git a/R/safetyGraphicsApp.R b/R/safetyGraphicsApp.R index 7cd9301a..3190583c 100644 --- a/R/safetyGraphicsApp.R +++ b/R/safetyGraphicsApp.R @@ -10,6 +10,7 @@ #' @importFrom magrittr "%>%" #' @import rmarkdown #' @importFrom haven read_sas +#' @importFrom shinyWidgets materialSwitch #' #' @export #' From 8f273ec019839edbf4913e5c881cebbf951dd0c8 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 1 Mar 2019 08:24:49 -0500 Subject: [PATCH 40/40] import shinyWidgets --- DESCRIPTION | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/DESCRIPTION b/DESCRIPTION index 5c86e2fb..b41d8a9b 100644 --- a/DESCRIPTION +++ b/DESCRIPTION @@ -36,5 +36,6 @@ Imports: rlang, tibble, utils, - haven + haven, + shinyWidgets VignetteBuilder: knitr