knitr-knit2html

Here are the examples of the r api knitr-knit2html taken from open source projects. By voting up you can indicate which examples are most useful and appropriate.

9 Examples 7

 test_that("writeCatSumReport", { 

     cat.sum.task = makeCatSumTask(id = "test.report", data = Arthritis,  

         target = "Improved") 

     cat.sum = makeCatSum(cat.sum.task) 

     cat.sum.report = makeReport(cat.sum) 

     temp.wd = getwd() 

     expect_file((rmd.file = writeReport(cat.sum.report, save.mode = FALSE,  

         override = TRUE)), extension = "rmd") 

     expect_file(x = paste0("Data_Report/", cat.sum.report$report.id,  

         ".rds")) 

     expectIdentical(getwd(), temp.wd) 

     rds.obj = readRDS(paste0("Data_Report/", cat.sum.report$report.id,  

         ".rds")) 

     expectIdentical(rds.obj$cat.sum[!names(rds.obj$cat.sum) %in%  

         "plot.list"], cat.sum.report$cat.sum[!names(cat.sum.report$cat.sum) %in%  

         "plot.list"]) 

     expect_error(writeReport(cat.sum.report)) 

     expectIdentical(getwd(), temp.wd) 

     setwd(paste0(temp.wd, "/Data_Report")) 

     knitr::knit2html(gsub("Data_Report/", "", rmd.file), quiet = TRUE) 

     setwd(temp.wd) 

     unlink("Data_Report", recursive = TRUE) 

 }) 

 test_that("writeClusterAnalysisReport", { 

     temp.wd = getwd() 

     expect_file((rmd.file = writeReport(cluster.report, save.mode = FALSE,  

         override = TRUE)), extension = "rmd") 

     expect_file(x = paste0("Data_Report/", cluster.report$report.id,  

         ".rds")) 

     expectIdentical(getwd(), temp.wd) 

     rds.obj = readRDS(paste0("Data_Report/", cluster.report$report.id,  

         ".rds")) 

     expectIdentical(rds.obj$cluster.analysis$cluster.all$cluster.res,  

         cluster.report$cluster.analysis$cluster.all$cluster.res) 

     expectIdentical(rds.obj$cluster.analysis$comb.cluster.list[[1]]$cluster.res,  

         cluster.report$cluster.analysis$comb.cluster.list[[1]]$cluster.res) 

     expectIdentical(rds.obj$cluster.analysis$comb.cluster.list[[2]]$cluster.res,  

         cluster.report$cluster.analysis$comb.cluster.list[[2]]$cluster.res) 

     expectIdentical(rds.obj$cluster.analysis$comb.cluster.list[[3]]$cluster.res,  

         cluster.report$cluster.analysis$comb.cluster.list[[3]]$cluster.res) 

     expect_error(writeReport(cluster.report)) 

     expectIdentical(getwd(), temp.wd) 

     setwd(paste0(temp.wd, "/Data_Report")) 

     knitr::knit2html(gsub("Data_Report/", "", rmd.file), quiet = TRUE) 

     setwd(temp.wd) 

     unlink("Data_Report", recursive = TRUE) 

 }) 

 test_that("writeClusterAnalysisReport", { 

     temp.wd = getwd() 

     expect_file((rmd.file = writeReport(corr.report, save.mode = FALSE,  

         override = TRUE)), extension = "rmd") 

     expect_file(x = paste0("Data_Report/", corr.report$report.id,  

         ".rds")) 

     expectIdentical(getwd(), temp.wd) 

     rds.obj = readRDS(paste0("Data_Report/", corr.report$report.id,  

         ".rds")) 

     expectIdentical(rds.obj$corr.matrix, corr.report$corr.matrix) 

     expectIdentical(rds.obj$method, corr.report$method) 

     expect_error(writeReport(corr.report)) 

     expectIdentical(getwd(), temp.wd) 

     setwd(paste0(temp.wd, "/Data_Report")) 

     knitr::knit2html(gsub("Data_Report/", "", rmd.file), quiet = TRUE) 

     setwd(temp.wd) 

     unlink("Data_Report", recursive = TRUE) 

 }) 

 test_that("writeFAReport", { 

     temp.wd = getwd() 

     expect_file((rmd.file = writeReport(fa.report, save.mode = FALSE,  

         override = TRUE)), extension = "rmd") 

     expect_file(x = paste0("Data_Report/", fa.report$report.id,  

         ".rds")) 

     expect_identical(getwd(), temp.wd) 

     rds.obj = readRDS(paste0("Data_Report/", fa.report$report.id,  

         ".rds")) 

     expect_equal(rds.obj$task, fa.report$task) 

     expect_identical(rds.obj$report.id, rds.obj$report.id) 

     expect_equal(class(rds.obj), class(fa.report)) 

     expect_error(writeReport(fa.report)) 

     expect_identical(getwd(), temp.wd) 

     setwd(paste0(temp.wd, "/Data_Report")) 

     knitr::knit2html(gsub("Data_Report/", "", rmd.file), quiet = TRUE) 

     setwd(temp.wd) 

     unlink("Data_Report", recursive = TRUE) 

 }) 

 test_that("writePCAReport", { 

     temp.wd = getwd() 

     expect_file((rmd.file = writeReport(pca.report, save.mode = FALSE,  

         override = TRUE)), extension = "rmd") 

     expect_file(x = paste0("Data_Report/", pca.report$report.id,  

         ".rds")) 

     expect_identical(getwd(), temp.wd) 

     rds.obj = readRDS(paste0("Data_Report/", pca.report$report.id,  

         ".rds")) 

     expect_equal(rds.obj$task, pca.report$task) 

     expect_identical(pca.report$report.id, rds.obj$report.id) 

     expect_equal(class(rds.obj), class(pca.report)) 

     expect_error(writeReport(pca.report)) 

     expect_identical(getwd(), temp.wd) 

     setwd(paste0(temp.wd, "/Data_Report")) 

     knitr::knit2html(gsub("Data_Report/", "", rmd.file), quiet = TRUE) 

     setwd(temp.wd) 

     unlink("Data_Report", recursive = TRUE) 

 }) 

19 File: splayer.R, author: fkeck, license: GNU General Public License v3.0

 spLayer.SpatialPoints  < - function(x, name = NULL, png = NULL,  

     size = 5, png.width = 15, png.height = 15, stroke = TRUE,  

     stroke.col = 1, stroke.lwd = 1, stroke.lty = -1, stroke.alpha = 1,  

     fill = TRUE, fill.col = 2, fill.alpha = 0.5, label = NULL,  

     popup = "", popup.rmd = FALSE, legend = NULL, ...) { 

     if (is.null(png)) { 

         if (!inherits(x, "SpatialPoints"))  

             stop("x must be an object of class SpatialPoints or SpatialPointsDataFrame") 

         spLayerControl(name = name, size = size, legend = legend,  

             stroke = stroke, stroke.col = stroke.col, stroke.lwd = stroke.lwd,  

             stroke.lty = stroke.lty, stroke.alpha = stroke.alpha,  

             fill = fill, fill.col = fill.col, fill.alpha = fill.alpha) 

         tested.index  < - !sapply(list(size, stroke, stroke.col,  

             stroke.lwd, stroke.lty, stroke.alpha, fill, fill.col,  

             fill.alpha, label, popup), is.null) 

         stroke.logical  < - stroke 

         fill.logical  < - fill 

         stroke  < - paste("\"", tolower(as.character(stroke)),  

             "\"", sep = "") 

         fill  < - paste("\"", tolower(as.character(fill)), "\"",  

             sep = "") 

         stroke.lty  < - paste("\"", as.character(stroke.lty), "\"",  

             sep = "") 

         tab.max  < - length(x) 

         tab  < - list(size, stroke, stroke.col, stroke.lwd, stroke.lty,  

             stroke.alpha, fill, fill.col, fill.alpha, label,  

             popup)[tested.index] 

         tab  < - lapply(tab, rep, length.out = tab.max) 

         tested.names  < - c("size", "stroke", "strokeCol", "strokeLwd",  

             "strokeLty", "strokeAlpha", "fill", "fillCol", "fillAlpha",  

             "label", "popup")[tested.index] 

         names(tab)  < - tested.names 

         legend$layer  < - name 

         tab$name  < - name 

         tab$legend  < - legend 

         tab$coords  < - coordinates(x) 

         tab$strokeCol[!stroke.logical]  < - tab$strokeLwd[!stroke.logical]  < - tab$strokeLty[!stroke.logical]  < - 1 

         tab$strokeAlpha[!stroke.logical]  < - 0 

         tab$strokeCol  < - col2hexa(tab$strokeCol) 

         tab$fillCol[!fill.logical]  < - 1 

         tab$fillAlpha[!fill.logical]  < - 0 

         tab$fillCol  < - col2hexa(tab$fillCol) 

         if (any(as.numeric(tab$strokeAlpha)  <  0) || any(as.numeric(tab$strokeAlpha) >  

             1))  

             stop("stroke.alpha must be comprise between 0 and 1") 

         if (any(as.numeric(tab$strokeLwd)  <  0))  

             stop("stroke.lwd must be positive") 

         if (any(as.numeric(tab$fillAlpha)  <  0) || any(as.numeric(tab$fillAlpha) >  

             1))  

             stop("fill.alpha must be comprise between 0 and 1") 

         if ("label" %in% tested.names)  

             tab$label  < - paste("\"", as.character(tab$label),  

                 "\"", sep = "") 

         if ("popup" %in% tested.names) { 

             if (popup.rmd) { 

                 tab$popup  < - sapply(as.vector(tab$popup), function(x) knitr::knit2html(output = NULL,  

                   text = x, options = c("fragment_only", "base64_images"))) 

                 tab$popup  < - gsub("\\n", " < br>", tab$popup) 

                 tab$popup  < - gsub("\"", "\\\\\"", tab$popup) 

             } 

             tab$popup  < - paste("\"", as.character(tab$popup),  

                 "\"", sep = "") 

         } 

         class(tab)  < - c("splpoints") 

         return(tab) 

     } 

     else { 

         if (!inherits(x, "SpatialPoints"))  

             stop("x must be an object of class SpatialPoints or SpatialPointsDataFrame") 

         spLayerControl(name = name, legend = legend) 

         size  < - paste("[", png.width, ",", png.height, "]", sep = "") 

         tested.index  < - !sapply(list(png, size, label, popup),  

             is.null) 

         tab.max  < - length(x) 

         tab  < - list(png, size, label, popup)[tested.index] 

         tab  < - lapply(tab, rep, length.out = tab.max) 

         tested.names  < - c("png", "size", "label", "popup")[tested.index] 

         names(tab)  < - tested.names 

         legend$layer  < - name 

         tab$name  < - name 

         tab$legend  < - legend 

         tab$coords  < - coordinates(x) 

         if ("label" %in% tested.names)  

             tab$label  < - paste("\"", as.character(tab$label),  

                 "\"", sep = "") 

         if ("popup" %in% tested.names) { 

             if (popup.rmd) { 

                 tab$popup  < - sapply(as.vector(tab$popup), function(x) knitr::knit2html(output = NULL,  

                   text = x, options = c("fragment_only", "base64_images"))) 

                 tab$popup  < - gsub("\\n", " < br>", tab$popup) 

                 tab$popup  < - gsub("\"", "\\\\\"", tab$popup) 

             } 

             tab$popup  < - paste("\"", as.character(tab$popup),  

                 "\"", sep = "") 

         } 

         class(tab)  < - c("splicons") 

         return(tab) 

     } 

 } 

19 File: splayer.R, author: fkeck, license: GNU General Public License v3.0

 spLayer.SpatialLines  < - function(x, name = NULL, stroke = TRUE,  

     stroke.col = 1, stroke.lwd = 1, stroke.lty = -1, stroke.alpha = 1,  

     label = NULL, popup = "", popup.rmd = FALSE, legend = NULL,  

     ...) { 

     if (!inherits(x, "SpatialLines"))  

         stop("x must be an object of class SpatialLines or SpatialLinesDataFrame") 

     spLayerControl(name = name, legend = legend, stroke = stroke,  

         stroke.col = stroke.col, stroke.lwd = stroke.lwd, stroke.lty = stroke.lty,  

         stroke.alpha = stroke.alpha) 

     tested.index  < - !sapply(list(stroke, stroke.col, stroke.lwd,  

         stroke.lty, stroke.alpha, label, popup), is.null) 

     stroke.logical  < - stroke 

     stroke  < - paste("\"", tolower(as.character(stroke)), "\"",  

         sep = "") 

     stroke.lty  < - paste("\"", as.character(stroke.lty), "\"",  

         sep = "") 

     tab  < - list(stroke, stroke.col, stroke.lwd, stroke.lty, stroke.alpha,  

         label, popup)[tested.index] 

     tab.max  < - length(x) 

     tab  < - lapply(tab, rep, length.out = tab.max) 

     tested.names  < - c("stroke", "strokeCol", "strokeLwd", "strokeLty",  

         "strokeAlpha", "label", "popup")[tested.index] 

     names(tab)  < - tested.names 

     tab$strokeCol[!stroke.logical]  < - tab$strokeLwd[!stroke.logical]  < - tab$strokeLty[!stroke.logical]  < - 1 

     tab$strokeAlpha[!stroke.logical]  < - 0 

     tab$strokeCol  < - col2hexa(tab$strokeCol) 

     legend$layer  < - name 

     tab$name  < - name 

     tab$legend  < - legend 

     tab$coords  < - coordinates(x) 

     if (any(as.numeric(tab$strokeAlpha)  <  0) || any(as.numeric(tab$strokeAlpha) >  

         1))  

         stop("stroke.alpha must be comprise between 0 and 1") 

     if (any(as.numeric(tab$strokeLwd)  <  0))  

         stop("stroke.lwd must be positive") 

     if ("label" %in% tested.names)  

         tab$label  < - paste("\"", as.character(tab$label), "\"",  

             sep = "") 

     if ("popup" %in% tested.names) { 

         if (popup.rmd) { 

             tab$popup  < - sapply(as.vector(tab$popup), function(x) knitr::knit2html(output = NULL,  

                 text = x, options = c("fragment_only", "base64_images"))) 

             tab$popup  < - gsub("\\n", " < br>", tab$popup) 

             tab$popup  < - gsub("\"", "\\\\\"", tab$popup) 

         } 

         tab$popup  < - paste("\"", as.character(tab$popup), "\"",  

             sep = "") 

     } 

     class(tab)  < - c("spllines") 

     return(tab) 

 } 

19 File: splayer.R, author: fkeck, license: GNU General Public License v3.0

 spLayer.SpatialPolygons  < - function(x, name = NULL, stroke = TRUE,  

     stroke.col = 1, stroke.lwd = 1, stroke.lty = -1, stroke.alpha = 1,  

     fill = TRUE, fill.col = 2, fill.alpha = 0.5, label = NULL,  

     popup = "", popup.rmd = FALSE, holes = FALSE, legend = NULL,  

     ...) { 

     if (!inherits(x, "SpatialPolygons"))  

         stop("x must be an object of class SpatialPolygons or SpatialPolygonsDataFrame") 

     spLayerControl(name = name, legend = legend, stroke = stroke,  

         stroke.col = stroke.col, stroke.lwd = stroke.lwd, stroke.lty = stroke.lty,  

         stroke.alpha = stroke.alpha, fill = fill, fill.col = fill.col,  

         fill.alpha = fill.alpha) 

     tested.index  < - !sapply(list(stroke, stroke.col, stroke.lwd,  

         stroke.lty, stroke.alpha, fill, fill.col, fill.alpha,  

         label, popup), is.null) 

     stroke.logical  < - stroke 

     fill.logical  < - fill 

     stroke  < - paste("\"", tolower(as.character(stroke)), "\"",  

         sep = "") 

     fill  < - paste("\"", tolower(as.character(fill)), "\"", sep = "") 

     stroke.lty  < - paste("\"", as.character(stroke.lty), "\"",  

         sep = "") 

     tab  < - list(stroke, stroke.col, stroke.lwd, stroke.lty, stroke.alpha,  

         fill, fill.col, fill.alpha, label, popup)[tested.index] 

     tab.max  < - length(x) 

     tab  < - lapply(tab, rep, length.out = tab.max) 

     tested.names  < - c("stroke", "strokeCol", "strokeLwd", "strokeLty",  

         "strokeAlpha", "fill", "fillCol", "fillAlpha", "label",  

         "popup")[tested.index] 

     names(tab)  < - tested.names 

     tab$strokeCol[!stroke.logical]  < - tab$strokeLwd[!stroke.logical]  < - tab$strokeLty[!stroke.logical]  < - 1 

     tab$strokeAlpha[!stroke.logical]  < - 0 

     tab$strokeCol  < - col2hexa(tab$strokeCol) 

     tab$fillCol[!fill.logical]  < - 1 

     tab$fillAlpha[!fill.logical]  < - 0 

     tab$fillCol  < - col2hexa(tab$fillCol) 

     legend$layer  < - name 

     tab$name  < - name 

     tab$legend  < - legend 

     tab$coords  < - polycoords(x) 

     if (holes) { 

         tab$holes  < - polyholes(x) 

         tab$order  < - polyorder(x) 

     } 

     else { 

         tab$holes  < - tab$order  < - NULL 

     } 

     if (any(as.numeric(tab$strokeAlpha)  <  0) || any(as.numeric(tab$strokeAlpha) >  

         1))  

         stop("stroke.alpha must be comprise between 0 and 1") 

     if (any(as.numeric(tab$strokeLwd)  <  0))  

         stop("stroke.lwd must be positive") 

     if (any(as.numeric(tab$fillAlpha)  <  0) || any(as.numeric(tab$fillAlpha) >  

         1))  

         stop("fill.alpha must be comprise between 0 and 1") 

     if ("label" %in% tested.names)  

         tab$label  < - paste("\"", as.character(tab$label), "\"",  

             sep = "") 

     if ("popup" %in% tested.names) { 

         if (popup.rmd) { 

             tab$popup  < - sapply(as.vector(tab$popup), function(x) knitr::knit2html(output = NULL,  

                 text = x, options = c("fragment_only", "base64_images"))) 

             tab$popup  < - gsub("\\n", " < br>", tab$popup) 

             tab$popup  < - gsub("\"", "\\\\\"", tab$popup) 

         } 

         tab$popup  < - paste("\"", as.character(tab$popup), "\"",  

             sep = "") 

     } 

     class(tab)  < - c("splpolygons") 

     return(tab) 

 } 

19 File: server.R, author: PsyChiLin, license: MIT License

 shinyServer(function(input, output) { 

     Dataset  < - reactive({ 

         if (is.null(input$file)) { 

             dst  < - RSE 

             row.names(dst)  < - 1:256 

             return(dst) 

         } 

         if (input$dataformat == "txt") { 

             if (input$hdr == "TRUE") { 

                 Dataset  < - read.table(input$file$datapath, header = T) 

             } 

             if (input$hdr == "FALSE") { 

                 Dataset  < - read.table(input$file$datapath, header = F) 

             } 

         } 

         if (input$dataformat == "csv") { 

             if (input$hdr == "TRUE") { 

                 Dataset  < - read.csv(input$file$datapath, header = T) 

             } 

             if (input$hdr == "FALSE") { 

                 Dataset  < - read.csv(input$file$datapath, header = F) 

             } 

         } 

         if (input$datatype == "Correlation Matrix") { 

             row.names(Dataset)  < - Dataset[, 1] 

             Dataset  < - Dataset[, -1] 

         } 

         Dataset  < - na.omit(Dataset) 

         return(Dataset) 

     }) 

     output$varselect  < - renderUI({ 

         if (identical(Dataset(), "") || identical(Dataset(),  

             data.frame()))  

             return(NULL) 

         selectInput("vars", "Variables to include:", names(Dataset()),  

             names(Dataset()), multiple = TRUE) 

     }) 

     output$Nselect  < - renderUI({ 

         if (input$datatype == "Correlation Matrix") { 

             nobss  < - input$nobs 

         } 

         if (input$datatype == "Raw Data") { 

             nobss  < - dim(Dataset())[1] 

         } 

         sliderInput("Nselect", "Sample Size", 1, nobss, nobss,  

             step = 1, round = FALSE, format = NULL, locale = NULL,  

             ticks = TRUE, animate = FALSE, width = NULL, sep = ",",  

             pre = NULL, post = NULL, timeFormat = NULL, timezone = NULL,  

             dragRange = TRUE) 

     }) 

     D  < - reactive({ 

         if (is.null(input$vars) || length(input$vars) == 0) { 

             D  < - NULL 

         } 

         else { 

             if (input$datatype == "Correlation Matrix") { 

                 D  < - Dataset()[input$vars, input$vars, drop = FALSE] 

             } 

             else { 

                 D  < - Dataset()[, input$vars, drop = FALSE] 

             } 

         } 

         return(as.data.frame(D)) 

     }) 

     output$table  < - renderTable({ 

         return(D()) 

     }, rownames = T) 

     output$downloadSave_SelectData  < - downloadHandler(filename = "SelectedData.csv",  

         content = function(file) { 

             write.csv(D()[, input$vars, drop = FALSE], file,  

                 row.names = FALSE) 

         }) 

     M  < - reactive({ 

         if (input$datatype == "Correlation Matrix") { 

             M  < - as.matrix(D()) 

         } 

         if (input$datatype == "Raw Data") { 

             if (input$cortype == "Pearson") { 

                 M  < - cor(as.matrix(D())) 

             } 

             if (input$cortype == "tetrachoric") { 

                 M  < - tetrachoric(D())$rho 

             } 

             if (input$cortype == "polychoric") { 

                 M  < - polychoric(D())$rho 

             } 

         } 

         return(M) 

     }) 

     SumTable  < - reactive({ 

         if (input$datatype == "Correlation Matrix") { 

             stop("The numeric summary is not applicable for a corrleation matrix input.") 

         } 

         if (!all(sapply(D(), class) %in% c("numeric", "integer"))) { 

             stop("All input variables should be numeric or integer") 

         } 

         if (input$datatype == "Raw Data") { 

             dta_desc  < - apply(D(), 2, my_summary) 

             row.names(dta_desc)  < - c("Mean", "SD", "Skewness",  

                 "Kurtosis", "Median", "MAD") 

             rst  < - as.data.frame(t(dta_desc)) 

             rst  < - round(rst, 3) 

             return(rst) 

         } 

     }) 

     output$sum_table  < - renderTable({ 

         print(SumTable()) 

     }, rownames = T) 

     output$downloadSave_summary  < - downloadHandler(filename = "Summary.csv",  

         content = function(file) { 

             write.csv(SumTable(), file, row.names = T) 

         }) 

     observe(output$itemdist  < - renderPlotly({ 

         if (input$datatype == "Correlation Matrix") { 

             stop("The distribution plot is not applicable for a corrleation matrix input.") 

         } 

         if (!all(sapply(D(), class) %in% c("numeric", "integer"))) { 

             stop("All input variables should be numeric or integer") 

         } 

         dtalong  < - melt(D()) 

         colnames(dtalong)  < - c("Item", "Response") 

         dist1  < - ggplot(dtalong, aes(x = Response, fill = Item)) +  

             geom_histogram(bins = 10) + facet_wrap(~Item) + theme_default() +  

             labs(list(y = " ", x = " ")) 

         ggplotly(dist1) %>% layout(height = input$ploth1, width = input$plotw1) 

     })) 

     observe(output$itemdensity  < - renderPlotly({ 

         if (input$datatype == "Correlation Matrix") { 

             stop("The distribution plot is not applicable for a corrleation matrix input.") 

         } 

         if (!all(sapply(D(), class) %in% c("numeric", "integer"))) { 

             stop("All input variables should be numeric or integer") 

         } 

         dtalong  < - melt(D()) 

         colnames(dtalong)  < - c("Item", "Response") 

         dist2  < - ggplot(dtalong, aes(x = Response, fill = Item)) +  

             geom_density() + facet_wrap(~Item) + theme_default() +  

             labs(list(y = " ", x = " ")) 

         ggplotly(dist2) %>% layout(height = input$ploth1, width = input$plotw1) 

     })) 

     observe(output$distPlot  < - renderPlot({ 

         corrplot(M(), order = "hclust", method = "ellipse", type = "upper",  

             tl.pos = "lt") 

         corrplot(M(), add = TRUE, type = "lower", method = "number",  

             order = "hclust", diag = FALSE, tl.pos = "n", cl.pos = "n") 

     }, height = input$ploth1, width = input$plotw1)) 

     observe(output$ggcorPlot  < - renderPlot({ 

         ggcorrplot(M(), hc.order = T, type = "lower", lab = TRUE,  

             colors = c("#E46726", "white", "#6D9EC2")) 

     }, height = input$ploth1, width = input$plotw1)) 

     output$Nselect  < - renderUI({ 

         sliderInput("Nselect", "Sample Size", 1, dim(D())[1],  

             dim(D())[1], step = 1, round = FALSE, format = NULL,  

             locale = NULL, ticks = TRUE, animate = FALSE, width = NULL,  

             sep = ",", pre = NULL, post = NULL, timeFormat = NULL,  

             timezone = NULL, dragRange = TRUE) 

     }) 

     D2  < - reactive({ 

         if (is.null(input$vars) || length(input$vars) == 0) { 

             D2  < - NULL 

         } 

         else { 

             if (input$datatype == "Correlation Matrix") { 

                 D2  < - Dataset()[input$vars, input$vars, drop = FALSE] 

             } 

             else { 

                 D2  < - Dataset()[sort(sample(1:dim(Dataset())[1],  

                   input$Nselect)), input$vars, drop = FALSE] 

             } 

         } 

         return(as.data.frame(D2)) 

     }) 

     M2  < - reactive({ 

         if (input$datatype == "Correlation Matrix") { 

             M2  < - M() 

         } 

         if (input$datatype == "Raw Data") { 

             if (input$cortype == "Pearson") { 

                 M2  < - cor(as.matrix(D2())) 

             } 

             if (input$cortype == "tetrachoric") { 

                 M2  < - tetrachoric(D2())$rho 

             } 

             if (input$cortype == "polychoric") { 

                 M2  < - polychoric(D2())$rho 

             } 

         } 

         return(M2) 

     }) 

     observe(output$nfPlot  < - renderPlot({ 

         try(faplot(M2(), n.obs = ifelse(input$datatype == "Correlation Matrix",  

             input$nobs, input$Nselect), quant = as.numeric(input$qpa),  

             fm = input$fm, n.iter = input$npasim)) 

     }, height = input$ploth2, width = input$plotw2)) 

     VssTable  < - reactive({ 

         Vs  < - VSS(M2(), n = input$maxn, plot = F, n.obs = ifelse(input$datatype ==  

             "Correlation Matrix", input$nobs, input$Nselect)) 

         mapvss  < - data.frame(nFactor = row.names(Vs$vss.stats),  

             VSS1 = Vs$cfit.1, VSS2 = Vs$cfit.2, MAP = Vs$map) 

         otherindex  < - Vs$vss.stats[, c(6:8, 11)] 

         VssTable  < - cbind(mapvss, otherindex) 

         return(VssTable) 

     }) 

     egarst  < - reactive({ 

         bootEGA(data = D2(), n = input$npasim, medianStructure = TRUE,  

             plot.MedianStructure = TRUE, ncores = 4, layout = input$egalayout) 

     }) 

     observe(output$EGAplot  < - renderPlot({ 

         if (input$datatype == "Correlation Matrix") { 

             stop("The EGA is not applicable for a corrleation matrix input.") 

         } 

         plot(egarst()$plot) 

     })) 

     output$nfTable  < - renderTable({ 

         print(VssTable()) 

     }, rownames = F) 

     nfsummary  < - reactive({ 

         pa  < - faplot(M2(), n.obs = ifelse(input$datatype == "Correlation Matrix",  

             input$nobs, input$Nselect), quant = as.numeric(input$qpa),  

             fm = input$fm, n.iter = input$npasim) 

         nfs  < - data.frame(Method = c("Parallel analysis", colnames(VssTable())[2:8],  

             "EGA"), n_optimal = NA) 

         nfs$n_optimal  < - as.character(nfs$n_optimal) 

         nfs[1, 2]  < - pa[[2]] 

         nfs[2, 2]  < - ifelse(length(VssTable()[VssTable()[, "VSS1"] ==  

             max(VssTable()[, "VSS1"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "VSS1"] == max(VssTable()[, "VSS1"]), ]$nFactor,  

             "Multiple") 

         nfs[3, 2]  < - ifelse(length(VssTable()[VssTable()[, "VSS2"] ==  

             max(VssTable()[, "VSS2"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "VSS2"] == max(VssTable()[, "VSS2"]), ]$nFactor,  

             "Multiple") 

         nfs[4, 2]  < - ifelse(length(VssTable()[VssTable()[, "MAP"] ==  

             min(VssTable()[, "MAP"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "MAP"] == min(VssTable()[, "MAP"]), ]$nFactor, "Multiple") 

         nfs[5, 2]  < - ifelse(length(VssTable()[VssTable()[, "RMSEA"] ==  

             min(VssTable()[, "RMSEA"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "RMSEA"] == min(VssTable()[, "RMSEA"]), ]$nFactor,  

             "Multiple") 

         nfs[6, 2]  < - ifelse(length(VssTable()[VssTable()[, "BIC"] ==  

             min(VssTable()[, "BIC"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "BIC"] == min(VssTable()[, "BIC"]), ]$nFactor, "Multiple") 

         nfs[7, 2]  < - ifelse(length(VssTable()[VssTable()[, "SABIC"] ==  

             min(VssTable()[, "SABIC"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "SABIC"] == min(VssTable()[, "SABIC"]), ]$nFactor,  

             "Multiple") 

         nfs[8, 2]  < - ifelse(length(VssTable()[VssTable()[, "SRMR"] ==  

             min(VssTable()[, "SRMR"]), ]$nFactor) == 1, VssTable()[VssTable()[,  

             "SRMR"] == min(VssTable()[, "SRMR"]), ]$nFactor,  

             "Multiple") 

         nfs[9, 2]  < - egarst()$summary.table$median.dim 

         return(nfs) 

     }) 

     output$nfsum  < - renderTable({ 

         print(nfsummary()) 

     }, rownames = F) 

     output$downloadSave_nfTable  < - downloadHandler(filename = "Vss_Table.csv",  

         content = function(file) { 

             write.csv(VssTable(), file, row.names = F) 

         }) 

     farst  < - reactive({ 

         farst  < - fa(M2(), input$nfactors, n.obs = ifelse(input$datatype ==  

             "Correlation Matrix", input$nobs, input$Nselect),  

             rotate = input$rotate, fm = input$fm, max.iter = 1e+05,  

             n.iter = input$bsnum) 

         return(farst) 

     }) 

     itemorder  < - reactive({ 

         o1  < - farst() 

         o2  < - printLoadings(o1$cis$means, sort = input$sorting,  

             cutoff = 0) 

         o3  < - as.data.frame(o2) 

         return(row.names(o3)) 

     }) 

     itemorder2  < - reactive({ 

         o1  < - farst() 

         if (input$nfactors != 1) { 

             o2  < - printLoadings(o1$cis$means, sort = input$sorting2,  

                 cutoff = 0) 

         } 

         if (input$nfactors == 1) { 

             if (input$sorting2 == T) { 

                 o2  < - o1$cis$means[order(o1$cis$means[, 1], decreasing = T),  

                   ] 

             } 

             if (input$sorting2 == F) { 

                 o2  < - unclass(o1$cis$means) 

             } 

         } 

         o3  < - as.data.frame(o2) 

         return(rev(row.names(o3))) 

     }) 

     itemorder3  < - reactive({ 

         o1  < - farst() 

         if (input$nfactors != 1) { 

             o2  < - printLoadings(o1$cis$means, sort = input$sorting3,  

                 cutoff = 0) 

         } 

         if (input$nfactors == 1) { 

             if (input$sorting2 == T) { 

                 o2  < - o1$cis$means[order(o1$cis$means[, 1], decreasing = T),  

                   ] 

             } 

             if (input$sorting2 == F) { 

                 o2  < - unclass(o1$cis$means) 

             } 

         } 

         o3  < - as.data.frame(o2) 

         return(rev(row.names(o3))) 

     }) 

     PatMat_ci  < - reactive({ 

         farst  < - farst() 

         f  < - list() 

         if (input$nfactors != 1) { 

             for (i in 1:input$nfactors) { 

                 f[[i]]  < - cbind(farst$cis$ci[, i], farst$cis$means[,  

                   i], farst$cis$ci[, i + input$nfactors]) 

             } 

             fd  < - do.call(cbind, f) 

             test  < - cbind(fd, melt(unclass(farst$communality)),  

                 melt(unclass(farst$uniquenesses)), melt(unclass(farst$complexity))) 

             nam  < - list() 

             aa  < - names(as.data.frame(unclass(farst$cis$means))) 

             for (i in 1:input$nfactors) { 

                 nam[[i]]  < - c("LB", aa[i], "UB") 

             } 

             manc  < - do.call(c, nam) 

             colnames(test)[1:I(input$nfactors * 3)]  < - manc 

             colnames(test)[I(input$nfactors * 3 + 1):I(input$nfactors *  

                 3 + 3)]  < - c("h2", "u2", "com") 

             order  < - itemorder() 

             test  < - test[c(order), ] 

         } 

         if (input$nfactors == 1) { 

             f  < - cbind(farst$cis$ci[, 1], farst$cis$means[, 1],  

                 farst$cis$ci[, 2]) 

             test  < - cbind(f, melt(unclass(farst$communality)),  

                 melt(unclass(farst$uniquenesses)), melt(unclass(farst$complexity))) 

             nam  < - list() 

             aa  < - names(as.data.frame(unclass(farst$cis$means))) 

             nam  < - c(paste0(aa[1], "_Lower"), aa[1], paste0(aa[1],  

                 "_Upper")) 

             colnames(test)[1:I(1 * 3)]  < - nam 

             colnames(test)[I(1 * 3 + 1):I(1 * 3 + 3)]  < - c("h2",  

                 "u2", "com") 

             if (input$sorting == T) { 

                 test  < - test[order(test[, 2], decreasing = T),  

                   ] 

             } 

         } 

         return(test) 

     }) 

     output$textfa  < - renderTable({ 

         print(PatMat_ci()) 

     }, rownames = T) 

     output$downloadSave_PatMat  < - downloadHandler(filename = "PatternMatrix.csv",  

         content = function(file) { 

             write.csv(PatMat_ci(), file, row.names = T) 

         }) 

     FactCorr  < - reactive({ 

         FactCorr  < - as.data.frame(unclass(farst()$Phi)) 

         return(FactCorr) 

     }) 

     output$factcor  < - renderTable({ 

         print(FactCorr()) 

     }, rownames = T) 

     output$downloadSave_FactorCorr  < - downloadHandler(filename = "FactorCorr.csv",  

         content = function(file) { 

             write.csv(FactCorr(), file, row.names = T) 

         }) 

     observe(output$Diag  < - renderPlot({ 

         return(fa.diagram(farst(), simple = input$sim, cut = input$cutt,  

             sort = input$so, errors = input$errarr, main = " ",  

             e.size = input$es)) 

     }, height = input$ploth3, width = input$plotw3)) 

     observe(output$BFig  < - renderPlot({ 

         order  < - itemorder3() 

         return(bargraph(farst(), order = order, nf = input$nfactors,  

             highcol = input$highcol, lowcol = input$lowcol, ci = input$barci)) 

     }, height = input$ploth5, width = input$plotw5)) 

     observe(output$SFig  < - renderPlot({ 

         order  < - itemorder2() 

         return(stackbar(M2(), farst(), order = order, highcol = input$highcol,  

             lowcol = input$lowcol)) 

     }, height = input$ploth4, width = input$plotw4)) 

     q  < - reactive({ 

         return(efa(covmat = M2(), n.obs = ifelse(input$datatype ==  

             "Correlation Matrix", input$nobs, input$Nselect),  

             factors = input$nfactors, rotation = "CF-quartimax",  

             merror = "YES")) 

     }) 

     v  < - reactive({ 

         return(efa(covmat = M2(), n.obs = ifelse(input$datatype ==  

             "Correlation Matrix", input$nobs, input$Nselect),  

             factors = input$nfactors, rotation = "CF-varimax",  

             merror = "YES")) 

     }) 

     output$PointTable  < - renderTable(print(PointT_new(q(), v(),  

         M2(), nbf = input$nfactors)), rownames = T) 

     observe(output$SEFig  < - renderPlot({ 

         return(SEplot(q(), v(), M2(), nbf = input$nfactors)) 

     }, height = input$ploth6, width = input$plotw6)) 

     output$knitdoc  < - shiny::renderUI({ 

         progress  < - shiny::Progress$new() 

         on.exit(progress$close()) 

         progress$set(message = "Running...", value = 0) 

         input$eval 

         return(shiny::isolate(shiny::HTML(knitr::knit2html(text = input$rmd,  

             fragment.only = TRUE, quiet = TRUE)))) 

     }) 

 }) 

Categories r Tags