From de160953af7497393d32c0b58359ad78476fb271 Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 15 Feb 2019 10:52:49 -0500 Subject: [PATCH 01/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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/20] 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 1a54ee8e3484e2d0d30942013d16bef32f6d837e Mon Sep 17 00:00:00 2001 From: bzkrouse Date: Fri, 22 Feb 2019 13:05:58 -0500 Subject: [PATCH 13/20] 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 14/20] 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 15/20] 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 16/20] 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 17/20] 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 18/20] 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 19/20] 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 20/20] 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}