From 1231822367d1330a4488f8cdf5dcd980255c143a Mon Sep 17 00:00:00 2001 From: Konrad1991 Date: Wed, 20 Nov 2024 13:35:27 +0100 Subject: [PATCH] results are now displayed as list with remove buttons --- Direct_Test_App.R | 32 ++++++++ Rplots.pdf | Bin 0 -> 7694 bytes bs/.development/remove_buttons.R | 55 +++++++++++++ bs/DESCRIPTION | 1 - bs/R/DoseResponse.R | 60 ++------------ bs/R/MainApp.R | 135 +++++++++++++++++++++++++++++-- bs/R/OperationsModule.R | 74 +++++------------ bs/R/assumption.R | 117 +++++++-------------------- bs/R/check_ast.R | 2 +- bs/R/correlation.R | 85 ++----------------- bs/R/statisticalTests.R | 81 ++++--------------- bs/R/utils.R | 40 ++++++++- bs/R/visualisation.R | 74 +---------------- glm/DESCRIPTION | 14 ++++ glm/NAMESPACE | 0 glm/R/CheckAssumptions.R | 0 glm/R/CreateModel.R | 4 + glm/R/Tests.R | 0 18 files changed, 354 insertions(+), 420 deletions(-) create mode 100644 Direct_Test_App.R create mode 100644 Rplots.pdf create mode 100644 bs/.development/remove_buttons.R create mode 100644 glm/DESCRIPTION create mode 100644 glm/NAMESPACE create mode 100644 glm/R/CheckAssumptions.R create mode 100644 glm/R/CreateModel.R create mode 100644 glm/R/Tests.R diff --git a/Direct_Test_App.R b/Direct_Test_App.R new file mode 100644 index 0000000..6abc64e --- /dev/null +++ b/Direct_Test_App.R @@ -0,0 +1,32 @@ +library(shiny) +library(DT) +library(bslib) +library(broom) +library(ggplot2) +library(base64enc) +library(shinyjs) +library(mgcv) +library(RColorBrewer) +library(tidyr) +library(purrr) +library(agricolae) +library(drc) +library(cowplot) +library(MASS) +library(Matrix) +library(shinyjs) +library(equatiomatic) +library(openxlsx) +library(car) +library(cowplot) +library(COMELN) +library(httr) +library(jose) +library(openssl) +Sys.setenv(RUN_MODE = "BROWSER") +setwd("bs/R") +files <- list.files(".") +lapply(files, source) +app <- app() +shiny::shinyApp(app$ui, app$server) + diff --git a/Rplots.pdf b/Rplots.pdf new file mode 100644 index 0000000000000000000000000000000000000000..ea3bb1c6cdaf096915f3667b496a0248a10b47ea GIT binary patch literal 7694 zcmZ{J2{@GP_x~V-B7`Pkl0A$Wdt}L;%Dykr7)-{@WM*VHmJqU(Pzoiqys~E(A!J{R zBq2nWEZOsWW>CG~_y3>ka=GTr{hZ}GI7qzt2A&}h(DP)AUYtp_6v zA_c)-xyq=l%m~%+KspjoSd6A40SOV&JOh`4%fMhTMHpNLE+Z|<2)&4P`v3lBiXxza zr;H&w9*#Iy6ao)1AQEsy0`Qoj2iA#*KzfjWm64Q@gaa~)Ei73i%BZ5kh{QONy@3Dr z1_Cwp#vvh44M&0_8tVdq8alcl@epZXfidLI1M>fQfV_^p+5?Fp>@A0CU@-*XD;}ai zc^qnt#AAsb2tc3A|L7wx*oWf+65~Q}g-FZG%0i&pC^P|x0IH1!z|lk^uue#_-*^Im znLDG`gPaEjv9sE&4Xdjry=jWT^$^(C`dL z85N!N#^2l-DEU+v`%6=`(zDB5@W6B+f@^-1Z+V-s)?Kms$OHAK%~hvu6sET0-<5ss zT>dzg(sJbS$Myxd?FKSJ5q&KXEV&JTa*BEcRVs66xS?&H>x=K5B$lw6aM|+gFSj3_ zEU(O5ma#367AV24`yH1Y059`x3?hf8%g=JI^Dol#)eZ3!J+BBc-%8ZK-uZkk=B7(` zui4Y%bSi#m_e~qK*A^wn|pGA{l~8nbh>>NtAF93@~^lvDvtPJKi8o1Rc9A(+NFqm-J%batedD{34Nz8 z_H*zgk!o%2!>3niQejP0RkukE&g!Bms`s^?l{E6M>0V0kWH#KWd~!utgu$haSKi`C z=d(zU*I*Ix5G-e=*W{|i_&wux10z#=<9zl6yb|+ZY>v|b!t=*NSk43llW(EO%Fhu4 zPZ9RahcpQ)&}ScD?^toD25cRa9HB@heNR z&-6PfqnfBmP-cg|m}l_qR|P%Z=;o8@CLCV_qz&66HfPAj0zP-cOx~@FMgjnM1{+I7 zi&F8yn5Rs&%07#WJgAn5GRDS^;&Qo9&z?wM_SS2NF*;vA_2@(?&o#Ad0f&6B$T9nR zXF!jN`+BnI*R7*kUjc{I6>*tAW5St*`F*S$&FN~Jk7dZ-Nv!M<)~+#m)8Rv-zxxU^?=7dxk>JQfy95kI zJCkZMUM*>J?;JEVgWPeXYg+P95i^>&zpLq>LxjyWgOo1NU1B+l<@k``2P*QQBN-?-JkkARdndPQ-pXbh4`iQg})bO|MW zpUQZs^7S7@&N6qm=5XHvg>#@anVHl=hdff+TtO#XO^01)cO7a4dHXd^uC&)d*GI&5 z0oQDNIsmx+y-VXSx839mS1j~qju*W;=r94c@FHFX4pO-#f%!^C?5(YizJKH@&D`NIxf4y-uyFyS8)< zZ`Y0TuHVr+%e>gS_sWhgZ#Vc0Q<|~>)C!%$WxyJ0Qwl-NsY~ zGPwI~u5=1covQEO?kxh1uCu4T7wl_)-7o9v&RTOS-K`I;O(W7W_PDJ77ghR8fJlcH z>UH~)f|-s6`%r?%H3p&OGN=s4*WcT^?QK4_7o9EQhfHU4mDV?M{3D_)dH{@c3a5mI zf!OFt1&35h|t~p$Djiu!)F#$q*pI)3vom!d72r~4nN@>!6|9+OK`>I%KL3o^8Fq{pIm2m zj&_=ox2+T#zjH!apT%kq0jWn6b0caj-+{f|r9br)kG0du)MO=(xNZ)d`!kZTk3F!t zG+w-K61o34KFF5#UKIT`j>7*a&;}`$3_*G{?+1Xkzw!1{T^L`BX6xOf32&u5u)88t zL4Z&DIim3ap7vfjDS`gDwM9*_7AQoc;{}qLcrxc2Pn%jlVYlbFp*_hB*gD+f zzmw#Ahs1ZPv=`UA%c)-ix$U6)0j({qcE}anR{UcZCufqf&A2N4u(P5dg-iS-zv78c zC_qzD2EFGW#Fe}FnUwq9oc4aQTT5up<~jrUcDt_S;_tm`yVp@*}gSlz(l^KOq9f4&YXw_K*{$*>@73vrVIBM=s0hw!!=cLE}MT{gi~0 zrZ50>sZ}4l&p06x{f=s7^gN7l6q0#*WYCzZC9wx6$}|hJVtn$0Yr922x+a>_s=ifY zH@%}ky!ipo(t!%t8N-zikaxdyYuOL6bRPz)JH>6@DQ|M3;La?EP3$XTuaSPN#p#`1 z-2yWI##s95AmlT46{vy7)fmp^0XetlHzd|{y>bE^tlZhTL2YX-=AcbRlCI_^jX$ut z2cC)n=|nYNA;8jrNGQqstTzLwGF9`w@SaQ*hN+;xhys=eO*Bh{*@};$Kuv2+cWnF$B{=V7Sg2H z|8e|T(^&rrfjxq&IM(+9)~3`}{=np*9wojg1x?-0OX2D(on!|;muo|EcOffAYBaBJnyw|(p&!|~G&@|8}TS3w<^W(#bi)tFXg@WO-7?zygO(m6+`wd09CO9WvN4;Xm zCSe!u$9RgVUPVz< zszE7A1$i}px^`!F-q{Q%)1r9qrPbNPZzYb;4AIdfb8{KzmFqj1;PD5 z^P;Kv-Mm0^%n}8m>cN25FG+6tw8~veSLHIm4yy%44W_?O9Lcz(3v0*Yc0=Q&8k)Jn zl>~ULH#7dnn25fH0Pn*SaFQ8?+9NTPf=ddfWYTVV6C#C+AB(?Ib2%l1Yz@e_f@!Tn z0BjviN`c>N-ld2q_q`0`#zS5#Q%*{uGy?!b{@nz;-i@*`tQwY;hyd{?GK!pbk^yp( zG?_5>=bV(>$*-@+8+dAuY1#jzbdh=euS%M5L&TUldHeO9-AZ!Zwv|llqeaobdzTPN z%O0-hx1@puy&#vr19?ryxyf~FA-VL4(q3xQeQ$d2oS)yZzCNn)dc=ZYIX$yt(=V{; z4l&@X&R(>=d?Daw{m17Y7^1UODtn+q&~J5(jaU`k;R-eAbz(;eor(l2c+r4K%O$OG z;$WL<{#6eT3}o5Myzg|8zoL!d`83V6e=bi*C1FkzS7to>h_!hu>nqS=%zL-ZB?+ox zH1OX|Y9M#;#%$WA{Ek%w@kg%V^xfx|kNsoA@Q=GWQwWhMsCf3OT^@!f@0FbdQ@;dF z|Em{fwHq1>(gtp+vI=1dNaKJ(R9m3?g6b*Nouao&VhS=HogJztaA<`yTAO; zTL7|%Y|jR&r=fAq5s!3&$dOms?Y~zbf7_2yojk~6$VQ-=NKX_3NmdHI1iUMN?oIq~ zSw*@3=fqF;>G#C{F!8#n$pB|~N0oe);q4=l37u}P#?-opt90Wf#b69a&ez0&_~kTB zahgW)SqI@FBcu$C_xxTRHfd~%uh z?=J_%ZH3UjxnRjaI`qi$=$FZch+9!E4)j!q7CfO1xHe!5=4w_rYw5%d zJNQL$8^53TkSvNz@K9xN3%-36xiCH?Ja$WwtvWj10n9adaIFkpErbXm=!L1h#g6BL z{VvIYL~ajBPT)la_Zu8}ZZm4Bz2YU-kLwl>WB%45X1X#${B<$85 z_NXr%9Tz8~8d{~8@^2o)v%U=SVm~5)kPu>Tyubp1Rsr~(u8mwB^9S1 zO9;+!5PnKWOlOq|k;5G$1R+Lb6zC;`S{x1xQ5j1yr;0<#_>MkD~r^P&u+3gN~fg-GrW+%^p20?#^~e3N9K>@ zGM*dJ8$Nuh(reZ$a+Ps~^`f@hB$DG)*Y4ESM`q_#zRN+-`$;S}q#!UhLj$Rk8F zEaq6?g%d&?h17-MLhhaz#T($a(T-X9mj9gTKQR+|xWOau3L5r`(f5cin=h?WjDN_f zQ3CFj!ev|KOA)8*%|@(o!Z-^Ydnve*ZTQH1G)u$MLdy^2nzkQHz(LiRw38z2(F`v` zbv=La6+(J&`8%=Ku$DB;H3M>S>cEL zpZKdFcbc`GSUi-iE)1W;2&J9;Ed1IiUCdJKfXKp8^V7W|1TkA9udE0Q8PjD`+kcXC zEgyMlUeo>YjLp7T_hwGLk#(kN2Ep`OSa%WJY(QJlR8hmb&?9P*_N&fO@rH;|jW0%# zBAX&EA_&va=LSfVvR-1Z_O#Ws!eI^REZRf17W!*PSSp=2guW?)u5Ez~F1clvp5-^5ezr$746_YU@H_YOak?)C5O=`DG7 z{n_UpHB>Sx)NTCg_b!DOKM2h3F)b(N9^6(8pB(BBm2HzbC1c?_*K?xtL4SAuV$Zwo z=iO&AR!mb~&OUnhyh>v;^yd?1v&M@$>4h4TPudY-jCFV7+n+iu!?Fmn#BHKr`AT_6 zxwOw)A0wX|KC?cn%M2Uh+XCA>8&w-7bZ6*J($Ui8(3Kqi5hh-Dw9YPUJ1qBB^sOt= za>t0^vv6~1W~p|0jBK^rIk{`{R?giH9&JYv@8B1uKe_u19Fi-P*N44;al^ygcv@*E zD%!#&Iyo3WZ9kX2nDp%M$GBh`OFkm5_oQCsyYjlW`u(qvkc^O~ zM{SPXT{W<-{Qe(wQEwR$?#>UdpHuQy%<()kvD`mUYxUjl!#WpNmi~SHsFn=xw@YhF z$0u)dKl7XEq7dzyNWeKI&Q*dM24TyFGgOlZ_aV_&`vHt?MT2 zro_#8#YYe5+LyaYnZ^3qrRX`yIrda~EIs!2{5$BRfk2tiUE#CmJueQYD&HGTHI832 zt>H9fO3mKL?$4~g#B}jv+E3B5LRDvJlH!xEnd-7;F>Jz%rI+C0g{_5=g-==@B+c5& z2{N+DA~go03Mv|820D64^_m6t@cUzlCU=&EmziBd8_%C{+W+MB|IV)k{wXKkGus{czT3Rb4-#_()UV3M+>8ps671weQU7o zfF07XxOm#1cz#9qmc>Qi9Ov1r!S@y36}jJkeCRRHHnXr^#pF87xB0x@Xs62vi}X+S zSKQ>4)0Y1k*tSt#rkC-o=v!UDmw<0U5j6g7F>P%U_a%@yxED`|iwAG4=jnn-(~a+f&$?b~<{qDtRq{=v<&_#9{@b^+Zv zur%q{@$lQ~cUAAjw$XS)?vu73@YD1I|L;1q0$erbY%BhpNE=Z3qw`y*Sxm$ z`tRJ!ZcshFW4qZpK5+fD*A`rgLrM0R?ebPnZp!7SuRrW`&mrdtAC|W*z`4%$NtH%{ z_z{U2_nnI5>+I5H^ZE0qRg(jz){ia!n9GhfNDH7@4PDy&&rw_P_c4@l?|MrM1KcE` zFu?s5`PlmBn*|D^j=`h$1&mNll(RDuxYHtETG>EkWTEaT3=t1el!IO)VhKnz(wV>r zlaYZsVS#HnJRSvsx_CHx0%u%D1d)8yMW8$oM0aO2(hCA5pwLc$$lVd)fyF?eS3Hp9 zg}{@J2n29V#t3yn0jBUMJOnCFZd{v0Mvwdg+RIQBMX5MxA}1>=Eemmm{FcFiTTk)_g840j z$pLfFzh%JPC!qd+WWb&1e`L}yVBqgx9042NF;0cZ%1PU_p(u#77f`VEG H+Km4PxO;zx literal 0 HcmV?d00001 diff --git a/bs/.development/remove_buttons.R b/bs/.development/remove_buttons.R new file mode 100644 index 0000000..c62235b --- /dev/null +++ b/bs/.development/remove_buttons.R @@ -0,0 +1,55 @@ +library(shiny) + +ui <- fluidPage( + titlePanel("Dynamic List with Remove Buttons"), + sidebarLayout( + sidebarPanel( + numericInput("num_input", "Enter a number:", value = 0), + actionButton("add_btn", "Add to List") + ), + mainPanel( + uiOutput("dynamic_list") + ) + ) +) + +server <- function(input, output, session) { + listValues <- reactiveVal(list()) + observeEvent(input$add_btn, { + current_list <- listValues() + new_item_name <- paste0("item_", length(current_list) + 1) + current_list[[new_item_name]] <- input$num_input + listValues(current_list) + }) + + # Dynamically render the list UI + output$dynamic_list <- renderUI({ + current_list <- listValues() + if (length(current_list) == 0) { + return("No items in the list.") + } + # Create UI elements for each item in the list + tagList(lapply(names(current_list), function(name) { + div( + style = "margin-bottom: 10px;", + span(paste(name, ":", current_list[[name]]), style = "margin-right: 10px;"), + actionButton(name, "Remove", class = "btn-danger btn-sm") + ) + })) + }) + + # Observe and handle remove buttons dynamically + observe({ + current_list <- listValues() + lapply(names(current_list), function(name) { + observeEvent(input[[name]], { + current_list <- listValues() + current_list[[name]] <- NULL # Remove the item + listValues(current_list) + }, ignoreInit = TRUE) + }) + }) +} + +shinyApp(ui, server) + diff --git a/bs/DESCRIPTION b/bs/DESCRIPTION index 6c2b5a6..ba9a74e 100644 --- a/bs/DESCRIPTION +++ b/bs/DESCRIPTION @@ -29,7 +29,6 @@ Imports: equatiomatic, openxlsx, car, - cowplot, COMELN, httr, jose, diff --git a/bs/R/DoseResponse.R b/bs/R/DoseResponse.R index 415a871..e1ec8d5 100644 --- a/bs/R/DoseResponse.R +++ b/bs/R/DoseResponse.R @@ -28,17 +28,6 @@ DoseResponseSidebarUI <- function(id) { DoseResponseUI <- function(id) { fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - actionButton(NS(id, "dr_save"), "Add output to result-file"), - actionButton(NS(id, "download_dr"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), tabsetPanel( id = NS(id, "results_tabs"), tabPanel( @@ -58,8 +47,7 @@ DoseResponseUI <- function(id) { actionButton(NS(id, "previousPage"), "Previous plot"), actionButton(NS(id, "nextPage"), "Next plot") ) - ), - verbatimTextOutput(NS(id, "dr_error")) + ) ) } @@ -218,7 +206,6 @@ DoseResponseServer <- function(id, data, listResults) { }) drFct <- function() { - output$dr_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(input$substanceNames) @@ -270,11 +257,15 @@ DoseResponseServer <- function(id, data, listResults) { }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$dr_error <- renderText(err) + print_noti(FALSE, err) } else { listResults$curr_data <- new("doseResponse", df = resDF, p = resPlot) listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted dose response analysis") output$dr_result <- renderTable(resDF, digits = 6) + + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("DoseResponseNr", listResults$counter) + listResults$all_data[[new_result_name]] <- new("doseResponse", df = resDF, p = resPlot) } } @@ -357,45 +348,6 @@ DoseResponseServer <- function(id, data, listResults) { } }) - # Download results - observeEvent(input$dr_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_dr, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) }) return(listResults) diff --git a/bs/R/MainApp.R b/bs/R/MainApp.R index 90f5af4..8cb3d1d 100644 --- a/bs/R/MainApp.R +++ b/bs/R/MainApp.R @@ -3,6 +3,11 @@ app <- function() { ui <- fluidPage( useShinyjs(), includeScript(system.file("www/download.js", package = "bs")), + tags$head( + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), + tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js") + ), sidebarLayout( sidebarPanel( div( @@ -124,7 +129,8 @@ app <- function() { DoseResponseUI("DOSERESPONSE") ), id = "conditionedPanels" - ) + ), + uiOutput("Results") ) ) ) @@ -135,6 +141,12 @@ app <- function() { backup_df = NULL, filter_col = NULL, filter_group = NULL ) + listResults <- reactiveValues( + curr_data = NULL, curr_name = NULL, + all_data = list(), all_names = list(), + counter = 0 + ) + # docu data observeEvent(input[["data_docu"]], { showModal(modalDialog( @@ -303,10 +315,6 @@ app <- function() { ) }) - listResults <- reactiveValues( - curr_data = NULL, curr_name = NULL, - all_data = list(), all_names = list() - ) OperationEditorServer("OP", dataSet, listResults) corrServer("CORR", dataSet, listResults) visServer("VIS", dataSet, listResults) @@ -315,6 +323,123 @@ app <- function() { DoseResponseServer("DOSERESPONSE", dataSet, listResults) FormulaEditorServer("FO", dataSet) SplitByGroupServer("SG", dataSet) + + # Render results list + output$Results <- renderUI({ + if(input$conditionedPanels == "DataWrangling" || input$conditionedPanels == "Dose Response analysis") return() + res <- listResults$all_data |> rev() + if (length(res) == 0) return() + res_ui_list <- lapply(names(res), function(name) { + temp <- res[[name]] + if (is.vector(temp)) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + verbatimTextOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else if (is.data.frame(temp)) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + DTOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else if (inherits(temp, "plot")) { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + plotOutput(paste0("res_", name), width = "100%", height = "800px"), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } else { + div( + class = "var-box-output", + div( + class = "var-box-name", + name + ), + verbatimTextOutput(paste0("res_", name)), + actionButton(paste0("remove_res_", name), "Remove", class = "btn-danger") + ) + } + }) + download_stuff <- div( + br(), + h4("Results"), + actionButton("download", "Save and exit"), + textInput("user_filename", "Set filename", value = "") + ) + + do.call(tagList, list(download_stuff, res_ui_list)) + }) + + # Show results + observe({ + res <- listResults$all_data + res_ui_list <- lapply(names(res), function(name) { + observeEvent(res[[name]], { + temp <- res[[name]] + if (is.vector(temp)) { + output[[paste0("res_", name)]] <- renderPrint(temp) + } else if (is.data.frame(temp)) { + output[[paste0("res_", name)]] <- renderDT(temp) + } else if (inherits(temp, "plot")) { + output[[paste0("res_", name)]] <- renderPlot(temp@p) + } else if (inherits(temp, "doseResponse")) { + message <- "Dose Response Analysis. Too large to display." + output[[paste0("res_", name)]] <- renderPrint(message) + } else { + output[[paste0("res_", name)]] <- renderPrint(temp) + } + }) + }) + do.call(tagList, res_ui_list) + }) + + # Observe remove buttons + observe({ + current_list <- listResults$all_data + lapply(names(current_list), function(name) { + observeEvent(input[[paste0("remove_res_", name)]], { + current_list <- listResults$all_data + current_list[[name]] <- NULL + listResults$all_data <- current_list + }, ignoreInit = TRUE) + }) + }) + + observeEvent(input$download, { + print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") + print_noti(length(listResults$all_data) > 0, "No results to save") + l <- listResults$all_data + if (Sys.getenv("RUN_MODE") == "SERVER") { + print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") + excelFile <- createExcelFile(l) + upload(session, excelFile, new_name = input$user_filename) + } else { + print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") + jsString <- createJSString(l) + session$sendCustomMessage( + type = "downloadZip", + list( + numberOfResults = length(jsString), + FileContent = jsString, + Filename = input$user_filename + ) + ) + } + }) + } return(list(ui = ui, server = server)) diff --git a/bs/R/OperationsModule.R b/bs/R/OperationsModule.R index 4ea6be8..71fd431 100644 --- a/bs/R/OperationsModule.R +++ b/bs/R/OperationsModule.R @@ -1,6 +1,3 @@ - -# TODO: store original dataset. Add option to reset dataset - OperatorEditorSidebar <- function(id) { ui <- fluidPage( tags$head( @@ -92,6 +89,8 @@ OperatorEditorSidebar <- function(id) { actionButton(NS(id, "min"), "Min", class = "add-button", title = "Find the smallest number (e.g., Min(c(1, 2, 3)) gives 1)"), actionButton(NS(id, "max"), "Max", class = "add-button", title = "Find the largest number (e.g., Max(c(1, 2, 3)) gives 3)"), actionButton(NS(id, "c"), "concatenate", class = "add-button", title = "Combine values into a list (e.g., c(1, 2, 3) gives [1, 2, 3])"), + actionButton(NS(id, "seq"), "sequence", class = "add-button", title = "Create a sequence of elements (e.g. seq(1, 10, 0.1) which creates a sequence starting from 1 to 10 in steps of 0.1)."), + actionButton(NS(id, "df"), "DataFrame", class = "add-button", title = "Create a table (e.g. DataFrame(Variable1, Variable2))"), actionButton(NS(id, "get_elem"), "get one element", class = "add-button", title = "Extract one element from a variable. This can either be ColName or a tabular dataset. In case it is a ColName the syntax is get_elem(ColName, idx) where idx is an integer number e.g. 1. In case one specific element of a dataset should be retrieved the syntax is get_elem(df, idx_row, idx_col). Again idx_row and idx_col have to be integers. The first one specifies the row number and the second one the column number."), actionButton(NS(id, "get_rows"), "get_rows", class = "add-button", @@ -103,8 +102,8 @@ OperatorEditorSidebar <- function(id) { ), div( h3("String Functions"), - actionButton(NS(id, "paste"), "paste", class = "add-button", title = "Join pieces of text (e.g., paste('Hello', 'World') gives 'Hello World')"), - actionButton(NS(id, "paste0"), "paste0", class = "add-button", title = "Join pieces of text without spaces (e.g., paste0('Hello', 'World') gives 'HelloWorld')"), + actionButton(NS(id, "paste"), "paste", class = "add-button", title = "Join pieces of text (e.g., paste('Hello', 'World') gives 'Hello World')."), + actionButton(NS(id, "paste0"), "paste0", class = "add-button", title = "Join pieces of text without spaces (e.g., paste0('Hello', 'World') gives 'HelloWorld'). This is very practical if you want to join two columns e.g. paste0(ColName1, ColName2)"), actionButton(NS(id, "tolower"), "tolower", class = "add-button", title = "Convert text to lowercase (e.g., tolower('Hello') gives 'hello')"), actionButton(NS(id, "toupper"), "toupper", class = "add-button", title = "Convert text to uppercase (e.g., toupper('hello') gives 'HELLO')"), class = "boxed-output" @@ -243,10 +242,6 @@ OperatorEditorUI <- function(id) { ) ), uiOutput(NS(id, "head")), - actionButton(NS(id, "save"), "Add output to result-file"), - actionButton(NS(id, "download"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), uiOutput(NS(id, "intermediate_results")) ) } @@ -462,6 +457,9 @@ OperationEditorServer <- function(id, data, listResults) { exportTestValues( iv_list = r_vals$intermediate_vars ) + listResults$counter <- listResults$counter + 1 + new_name <- paste0(var_name, listResults$counter) + listResults$all_data[[new_name]] <- new } }) @@ -516,12 +514,9 @@ OperationEditorServer <- function(id, data, listResults) { output$head <- renderTable(head(r_vals$df, 10)) r_vals$counter_id <- r_vals$counter_id + 1 - listResults$curr_data <- data$df - listResults$curr_name <- paste( - "Dataset Changes Nr", - length(listResults$all_names) + 1, - "Conducted test: ", input$editable_code - ) + listResults$counter <- listResults$counter + 1 + new_name <- paste0("Dataset", listResults$counter) + listResults$all_data[[new_name]] <- data$df }) observeEvent(input$add, { @@ -759,6 +754,16 @@ OperationEditorServer <- function(id, data, listResults) { updated_text <- paste(current_text, "c(", sep = " ") updateTextAreaInput(session, "editable_code", value = updated_text) }) + observeEvent(input$seq, { + current_text <- input$editable_code + updated_text <- paste(current_text, "seq(", sep = " ") + updateTextAreaInput(session, "editable_code", value = updated_text) + }) + observeEvent(input$df, { + current_text <- input$editable_code + updated_text <- paste(current_text, "DataFrame(", sep = " ") + updateTextAreaInput(session, "editable_code", value = updated_text) + }) observeEvent(input$as_char, { current_text <- input$editable_code updated_text <- paste(current_text, "as.char(", sep = " ") @@ -855,44 +860,5 @@ OperationEditorServer <- function(id, data, listResults) { updateTextAreaInput(session, "editable_code", value = updated_text) }) - observeEvent(input$save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) - }) } diff --git a/bs/R/assumption.R b/bs/R/assumption.R index cc21e10..634d6f1 100644 --- a/bs/R/assumption.R +++ b/bs/R/assumption.R @@ -56,22 +56,7 @@ assSidebarUI <- function(id) { } assUI <- function(id) { - fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - verbatimTextOutput(NS(id, "ass_error")), - actionButton(NS(id, "ass_save"), "Add output to result-file"), - actionButton(NS(id, "download_ass"), "Save and exit"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), - tableOutput(NS(id, "ass_result")), - plotOutput(NS(id, "DiagnosticPlotRes"), width = "100%", height = "1000px") - ) + fluidRow() } assServer <- function(id, data, listResults) { @@ -127,7 +112,7 @@ assServer <- function(id, data, listResults) { data$filter_group <- NULL }) - output$open_formula_editor_corr <- renderUI({ # TODO: change to unique identifier probably via [["open_formula_editor"]] + output$open_formula_editor_corr <- renderUI({ actionButton(NS(id, "open_formula_editor"), "Open formula editor", title = "Open the formula editor to create or modify a formula", @@ -154,7 +139,6 @@ assServer <- function(id, data, listResults) { }) runShapiro <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -177,18 +161,20 @@ assServer <- function(id, data, listResults) { } } res <- do.call(rbind, res) - }) + }, silent = TRUE) if (!inherits(e, "try-error")) { exportTestValues( assumption_res = res ) - listResults$curr_data <- res - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") - output$curr_result <- renderTable(res, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "ShapiroDataNr", listResults$counter + ) + listResults$all_data[[new_name]] <- res output$curr_error <- renderText(err) } else { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } } } @@ -197,7 +183,6 @@ assServer <- function(id, data, listResults) { }) runShapiroResiduals <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -209,18 +194,20 @@ assServer <- function(id, data, listResults) { r <- resid(fit) res <- broom::tidy(shapiro.test(r)) res$`Residuals normal distributed` <- res$p.value > 0.05 - }) + }, silent = TRUE) if (!inherits(e, "try-error")) { exportTestValues( assumption_res = res ) - listResults$curr_data <- res - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted shapiro test") - output$curr_result <- renderTable(res, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "ShaprioResidualsNr", listResults$counter + ) + listResults$all_data[[new_name]] <- res output$curr_error <- renderText(err) } else { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } } observeEvent(input$shapiroResiduals, { @@ -228,7 +215,6 @@ assServer <- function(id, data, listResults) { }) runLevene <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -238,17 +224,19 @@ assServer <- function(id, data, listResults) { e <- try({ fit <- broom::tidy(car::leveneTest(formula, data = df, center = input$center)) fit$`Variance homogenity` <- fit$p.value > 0.05 - }) + }, silent = TRUE) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } else { exportTestValues( assumption_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "variance homogenity (levene)") - output$curr_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "LeveneTestNr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit output$curr_error <- renderText(err) } } @@ -256,18 +244,7 @@ assServer <- function(id, data, listResults) { runLevene() }) - output$ass_result <- renderTable( - { - if (!inherits(listResults$curr_data, "plot")) { - return(listResults$curr_data) - } - return(NULL) - }, - digits = 6 - ) - runDiagnosticPlot <- function() { - output$ass_error <- renderText(NULL) df <- data$df req(is.data.frame(df)) req(!is.null(data$formula)) @@ -276,16 +253,18 @@ assServer <- function(id, data, listResults) { p <- NULL e <- try({ p <- diagnosticPlots(df, formula) - }) + }, silent = TRUE) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$ass_error <- renderText(err) + print_noti(FALSE, err) } else { exportTestValues( assumption_res = p ) - listResults$curr_data <- new("plot", p = p, width = 15, height = 15, resolution = 600) - listResults$curr_name <- paste("Plot Nr", length(listResults$all_names) + 1, "diagnostic plots") + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("DiagnosticPlotNr", listResults$counter) + listResults$all_data[[new_result_name]] <- + new("plot", p = p, width = 15, height = 15, resolution = 600) output$DiagnosticPlotRes <- renderPlot(p) output$curr_error <- renderText(err) } @@ -294,44 +273,6 @@ assServer <- function(id, data, listResults) { runDiagnosticPlot() }) - observeEvent(input$ass_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_ass, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) }) return(listResults) diff --git a/bs/R/check_ast.R b/bs/R/check_ast.R index ebbda38..6f01938 100644 --- a/bs/R/check_ast.R +++ b/bs/R/check_ast.R @@ -12,7 +12,7 @@ allowed_fcts <- function() { "ppois", "rpois", "dunif", "punif", "qunif", "runif", "Mean", "SD", "Median", "quantile", "range", "Sum", "diff", "Min", "Max", "scale", - "c", "vector", "length", "matrix", "~", + "c", "seq", "DataFrame", "vector", "length", "matrix", "~", "get_rows", "get_cols", "get_elem", "as.char", "as.int", "as.real", "as.fact" ) diff --git a/bs/R/correlation.R b/bs/R/correlation.R index cb17eb3..2ee0c9b 100644 --- a/bs/R/correlation.R +++ b/bs/R/correlation.R @@ -38,21 +38,7 @@ corrSidebarUI <- function(id) { } corrUI <- function(id) { - fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js") - ), - h4(strong("Results of test:")), - tableOutput(NS(id, "corr_result")), - verbatimTextOutput(NS(id, "corr_error")), - actionButton(NS(id, "corr_save"), "Add output to result-file"), - actionButton(NS(id, "download_corr"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) - ) + fluidRow() } corrServer <- function(id, data, listResults) { @@ -138,14 +124,13 @@ corrServer <- function(id, data, listResults) { }) corr_fct <- function(method) { - output$corr_error <- renderText(NULL) req(is.data.frame(data$df)) req(!is.null(data$formula)) f <- as.character(data$formula) dep <- f[2] indep <- f[3] d <- data$df - e <- tryCatch({ + tryCatch({ check_ast(str2lang(indep), colnames(df)) # NOTE: check_ast throws error check_ast(str2lang(dep), colnames(df)) fit <- withCallingHandlers( @@ -164,14 +149,16 @@ corrServer <- function(id, data, listResults) { exportTestValues( correlation_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted test: ", method) - output$corr_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "Correlation", method, "NR", listResults$counter + ) + listResults$all_data[[new_name]] <- fit }, error = function(err) { err <- err$message showNotification(err) - output$corr_error <- renderText(err) + print_noti(FALSE, err) } ) } @@ -179,71 +166,15 @@ corrServer <- function(id, data, listResults) { observeEvent(input$pear, { corr_fct("pearson") }) - output$cor_result <- renderTable( - { - listResults$curr_data - }, - digits = 6 - ) observeEvent(input$spear, { corr_fct("spearman") }) - output$cor_result <- renderTable( - { - listResults$curr_data - }, - digits = 6 - ) observeEvent(input$kendall, { corr_fct("kendall") }) - output$cor_result <- renderTable( - { # issue: check whether this is required - listResults$curr_data - }, - digits = 6 - ) - - observeEvent(input$corr_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - observeEvent(input$download_corr, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) }) return(listResults) diff --git a/bs/R/statisticalTests.R b/bs/R/statisticalTests.R index 3553bc6..cc6b821 100644 --- a/bs/R/statisticalTests.R +++ b/bs/R/statisticalTests.R @@ -71,12 +71,6 @@ testsSidebarUI <- function(id) { testsUI <- function(id) { fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js") - ), tabsetPanel( tabPanel( "Two groups", @@ -91,14 +85,7 @@ testsUI <- function(id) { br(), ), id = "TestsConditionedPanels" - ), - h4(strong("Results of test:")), - tableOutput(NS(id, "test_result")), - verbatimTextOutput(NS(id, "test_error")), - actionButton(NS(id, "test_save"), "Add output to result-file"), - actionButton(NS(id, "download_test"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = ""), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL) + ) ) } @@ -205,7 +192,6 @@ testsServer <- function(id, data, listResults) { }) tTest <- function() { - output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(!is.null(data$formula)) @@ -224,14 +210,16 @@ testsServer <- function(id, data, listResults) { }) if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) - output$test_error <- renderText(err) + print_noti(FALSE, err) } else { - listResults$curr_data <- fit + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "TTestNr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit exportTestValues( tests_res = fit ) - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted t-test") - output$test_result <- renderTable(fit, digits = 6) } } @@ -240,7 +228,6 @@ testsServer <- function(id, data, listResults) { }) conductTests <- function(method) { - output$test_error <- renderText(NULL) req(is.data.frame(data$df)) df <- data$df req(!is.null(data$formula)) @@ -311,19 +298,21 @@ testsServer <- function(id, data, listResults) { if (inherits(e, "try-error")) { err <- conditionMessage(attr(e, "condition")) err <- paste0(err, "\n", "Test did not run successfully") - output$test_error <- renderText(err) + print_noti(FALSE, err) } else if (is.null(fit)) { err <- paste0(err, "\n", "Test did not run successfully") - output$test_error <- renderText("Result is NULL") + print_noti(FALSE, err) } else { fit <- cbind(fit, row.names(fit)) names(fit)[ncol(fit)] <- paste0(indep, collapse = ".") exportTestValues( tests_res = fit ) - listResults$curr_data <- fit - listResults$curr_name <- paste("Test Nr", length(listResults$all_names) + 1, "Conducted: ", method) - output$test_result <- renderTable(fit, digits = 6) + listResults$counter <- listResults$counter + 1 + new_name <- paste0( + "Test_", method, "Nr", listResults$counter + ) + listResults$all_data[[new_name]] <- fit } } } @@ -336,52 +325,10 @@ testsServer <- function(id, data, listResults) { conductTests("kruskal") }) - observeEvent(input$kruskalTest, { - conductTests("kruskal") - }) - observeEvent(input$PostHocTest, { conductTests(input$PostHocTests) }) - observeEvent(input$test_save, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$download_test, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) }) return(listResults) diff --git a/bs/R/utils.R b/bs/R/utils.R index 5e261d1..420277c 100644 --- a/bs/R/utils.R +++ b/bs/R/utils.R @@ -190,8 +190,12 @@ createJSString <- function(l) { } else if (inherits(l[[i]], "doseResponse")) { p <- l[[i]]@p fn <- tempfile(fileext = ".png") - ggsave(plot = p, filename = fn) - jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + for (idx in seq_len(length(p))) { + fn <- tempfile(fileext = ".png") + ggsave(plot = p[[idx]], filename = fn) + jsString <- c(jsString, paste0("data:image/png;base64,", base64enc::base64encode(fn))) + unlink(fn) + } unlink(fn) jsString <- c(jsString, DF2String(l[[i]]@df)) } else if (inherits(l[[i]], "data.frame")) { @@ -508,3 +512,35 @@ create_plot_pages <- function(plotList) { cowplot::plot_grid(plotlist = x) }) } + +# internal dataframe function +elongate_col <- function(col, l) { + times <- l / length(col) + if (floor(times) == times) { + return(rep(col, times)) + } else { + res <- rep(col, floor(times)) + remaining_elems <- l %% length(col) + res <- c(res, col[1:remaining_elems]) + return(res) + } +} + +DataFrame <- function(...) { + columns <- list(...) + s <- substitute(list(...)) + args <- as.list(s[-1]) + args <- lapply(args, function(x) { + make.names(deparse(x)) + }) + sapply(columns, function(x) { + if (length(x) == 0) stop("Found empty column") + }) + rows <- max(sapply(columns, length)) + columns <- lapply(columns, function(col) { + elongate_col(col, rows) + }) + df <- do.call(cbind, columns) |> as.data.frame() + names(df) <- args + return(df) +} diff --git a/bs/R/visualisation.R b/bs/R/visualisation.R index 3a89cef..a4bdff4 100644 --- a/bs/R/visualisation.R +++ b/bs/R/visualisation.R @@ -75,12 +75,6 @@ visSidebarUI <- function(id) { visUI <- function(id) { fluidRow( - tags$head( - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/jszip/3.7.1/jszip.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/FileSaver.js/2.0.5/FileSaver.min.js"), - tags$script(src = "https://cdnjs.cloudflare.com/ajax/libs/html2canvas/0.4.1/html2canvas.min.js"), - tags$script(src = "download.js"), - ), br(), tabsetPanel( tabPanel( @@ -100,8 +94,6 @@ visUI <- function(id) { ), id = "VisConditionedPanels" ), - actionButton(NS(id, "plotSave"), "Add output to result-file"), - checkboxGroupInput(NS(id, "TableSaved"), "Saved results to file", NULL), fluidRow( column( 4, @@ -115,16 +107,6 @@ visUI <- function(id) { 4, numericInput(NS(id, "resPlot"), "Resolution of plot", value = 300) ), - ), - fluidRow( - column( - 12, - actionButton(NS(id, "downloadViss"), "Save results"), - textInput(NS(id, "user_filename"), "Set filename", value = "") - ) - ), - plotOutput( - NS(id, "plotResult") ) ) } @@ -484,75 +466,25 @@ visServer <- function(id, data, listResults) { exportTestValues( plot = p ) - output$plotResult <- renderPlot(p) - listResults$curr_data <- new("plot", p = p, width = width, height = height, resolution = resolution) - listResults$curr_name <- paste( - "Plot Nr", - length(listResults$all_names) + 1, paste("Type: ", method) - ) + listResults$counter <- listResults$counter + 1 + new_result_name <- paste0("PlotNr", listResults$counter) + listResults$all_data[[new_result_name]] <- new("plot", p = p, width = width, height = height, resolution = resolution) } observeEvent(input$CreatePlotBox, { req(is.data.frame(data$df)) plotFct("box") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) observeEvent(input$CreatePlotScatter, { req(is.data.frame(data$df)) plotFct("dot") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) observeEvent(input$CreatePlotLine, { req(is.data.frame(data$df)) plotFct("line") }) - output$plotResult <- renderPlot({ - renderPlot(listResults$curr_data) - }) - observeEvent(input$plotSave, { - if (is.null(listResults$curr_name)) { - return(NULL) - } - if (!(listResults$curr_name %in% unlist(listResults$all_names))) { - listResults$all_data[[length(listResults$all_data) + 1]] <- listResults$curr_data - listResults$all_names[[length(listResults$all_names) + 1]] <- listResults$curr_name - } - updateCheckboxGroupInput(session, "TableSaved", - choices = listResults$all_names - ) - }) - - observeEvent(input$downloadViss, { - print_noti(is_valid_filename(input$user_filename), "Defined filename is not valid") - lr <- unlist(listResults$all_names) - indices <- sapply(input$TableSaved, function(x) { - which(x == lr) - }) - req(length(indices) >= 1) - l <- listResults$all_data[indices] - if (Sys.getenv("RUN_MODE") == "SERVER") { - print_noti(check_filename_for_server(input$user_filename), "Defined filename does not have xlsx as extension") - excelFile <- createExcelFile(l) - upload(session, excelFile, new_name = input$user_filename) - } else { - print_noti(check_filename_for_serverless(input$user_filename), "Defined filename does not have zip as extension") - jsString <- createJSString(l) - session$sendCustomMessage( - type = "downloadZip", - list( - numberOfResults = length(jsString), - FileContent = jsString, - Filename = input$user_filename - ) - ) - } - }) }) } diff --git a/glm/DESCRIPTION b/glm/DESCRIPTION new file mode 100644 index 0000000..cd440cb --- /dev/null +++ b/glm/DESCRIPTION @@ -0,0 +1,14 @@ +Package: glm +Type: Package +Title: biostats +Version: 1.0 +Date: 2022-03-24 +Author: Konrad Krämer +Maintainer: +Description: Offers the backend for generalized linear models used in Biostats shiny app. +License: GPL-3 +Imports: + broom, + ggplot2 +Encoding: UTF-8 + diff --git a/glm/NAMESPACE b/glm/NAMESPACE new file mode 100644 index 0000000..e69de29 diff --git a/glm/R/CheckAssumptions.R b/glm/R/CheckAssumptions.R new file mode 100644 index 0000000..e69de29 diff --git a/glm/R/CreateModel.R b/glm/R/CreateModel.R new file mode 100644 index 0000000..5f26592 --- /dev/null +++ b/glm/R/CreateModel.R @@ -0,0 +1,4 @@ +glm_internal <- function(formula, family, data) { + +} + diff --git a/glm/R/Tests.R b/glm/R/Tests.R new file mode 100644 index 0000000..e69de29